diff --git a/docs/binary-data-format.rst b/docs/binary-data-format.rst --- a/docs/binary-data-format.rst +++ b/docs/binary-data-format.rst @@ -12,10 +12,8 @@ not used for Futhark programs compiled to libraries, which instead use whichever format is supported by their host language. -Currently reading binary input is only supported for programs -generated by ``futhark c``/``futhark opencl``, and -``futhark py``/``futhark pyopencl``. It is *not* supported for -``futhark run``. +Currently reading binary input is only supported for compiled programs. +It is *not* supported for ``futhark run``. You can generate random data in the binary format with ``futhark dataset`` (:ref:`futhark-dataset(1)`). This tool can also be used to @@ -72,6 +70,7 @@ " u16" " u32" " u64" + " f16" " f32" " f64" "bool" diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -148,11 +148,17 @@ ------ Primitive types (``i32``, ``bool``, etc) are mapped directly to their -corresponding C type. For each distinct array type of primitives -(ignoring sizes), an opaque C struct is defined. For types that do -not map cleanly to C, including records, sum types, and arrays of -tuples, see :ref:`opaques`. +corresponding C type. The ``f16`` type is mapped to ``uint16_t``, +because C does not have a standard ``half`` type. This integer +contains the bitwise representation of the ``f16`` value in the IEEE +754 binary16 format. +For each distinct array type of primitives (ignoring sizes), an opaque +C struct is defined. Arrays of ``f16`` are presented as containing +``uint16_t`` elements. For types that do not map cleanly to C, +including records, sum types, and arrays of tuples, see +:ref:`opaques`. + All array values share a similar API, which is illustrated here for the case of the type ``[]i32``. The creation/retrieval functions are all asynchronous, so make sure to call :c:func:`futhark_context_sync` @@ -281,7 +287,7 @@ Results in the following C function: -.. c:function:: int futhark_entry_main(struct futhark_context *ctx, int32_t *out0, const struct futhark_i32_1d *in0) +.. c:function:: int futhark_entry_sum(struct futhark_context *ctx, int32_t *out0, const struct futhark_i32_1d *in0) Asynchronously call the entry point with the given arguments. Make sure to call :c:func:`futhark_context_sync` before using the value diff --git a/docs/conf.py b/docs/conf.py --- a/docs/conf.py +++ b/docs/conf.py @@ -268,6 +268,8 @@ ('man/futhark-cuda', 'futhark-cuda', 'compile Futhark to CUDA', [], 1), ('man/futhark-python', 'futhark-python', 'compile Futhark to sequential Python', [], 1), ('man/futhark-pyopencl', 'futhark-pyopencl', 'compile Futhark to Python and OpenCL', [], 1), + ('man/futhark-wasm', 'futhark-wasm', 'compile Futhark to WebAssembly', [], 1), + ('man/futhark-wasm-multicore', 'futhark-wasm-multicore', 'compile Futhark to parallel WebAssembly', [], 1), ('man/futhark-run', 'futhark-run', 'interpret Futhark program', [], 1), ('man/futhark-repl', 'futhark-repl', 'interactive Futhark read-eval-print-loop', [], 1), ('man/futhark-test', 'futhark-test', 'test Futhark programs', [], 1), diff --git a/docs/index.rst b/docs/index.rst --- a/docs/index.rst +++ b/docs/index.rst @@ -31,6 +31,7 @@ usage.rst language-reference.rst c-api.rst + js-api.rst package-management.rst server-protocol.rst c-porting-guide.rst @@ -54,6 +55,8 @@ man/futhark-pkg.rst man/futhark-pyopencl.rst man/futhark-python.rst + man/futhark-wasm.rst + man/futhark-wasm-multicore.rst man/futhark-repl.rst man/futhark-run.rst man/futhark-literate.rst diff --git a/docs/js-api.rst b/docs/js-api.rst new file mode 100644 --- /dev/null +++ b/docs/js-api.rst @@ -0,0 +1,142 @@ +.. _js-api: + +JavaScript API Reference +======================== + +The :ref:`futhark-wasm(1)` and :ref:`futhark-wasm-multicore(1)` +compilers produce JavaScript wrapper code to allow JavaScript programs +to invoke the generated WebAssembly code. This chapter describes the +API exposed by the wrapper. + +First a warning: **the JavaScript API is experimental**. It may +change incompatibly even in minor versions of the compiler. + +A Futhark program ``futlib.fut`` compiled with a WASM backend as a library +with the ``--library`` command line option produces four files: + +* ``futlib.c``, ``futlib.h``: Implementation and header C files + generated by the compiler, similar to ``futhark c``. You can delete + these - they are not needed at run-time. +* ``futlib.class.js``: An intermediate build artifact. Feel free to + delete it. +* ``futlib.wasm``: A compiled WebAssembly module, which must be + present at runtime. +* ``futlib.mjs``: An ES6 module that can can be imported by other + JavaScript code, and implements the API given in the following. + +The module exports a function, ``newFutharkContext``, which is a factory +function that returns a Promise producing a ``FutharkContext`` +instance (see below). A simple usage example: + +.. code-block:: javascript + + import { newFutharkContext } from './futlib.mjs'; + var fc; + newFutharkContext().then(x => fc = x); + +General concerns +---------------- + +Memory management is completely manual, as JavaScript does not support +finalizers that could let Futhark hook into the garbage collector. +You are responsible for eventually freeing all objects produced by the +API, using the appropriate methods. + +FutharkContext +-------------- + +FutharkContext is a class that contains information about the context +and configuration from the C API. It has methods for invoking the +Futhark entry points and creating FutharkArrays on the WebAssembly +heap. + +.. js:function:: newFutharkContext() + + Asynchronously create a new ``FutharkContext`` object. + +.. js:class:: FutharkContext() + + A bookkeeping class representing an instance of a Futhark program. + Do *not* directly invoke its constructor - always use the + ``newFutharkContext()`` factory function. + +.. js:function:: FutharkContext.free() + + Frees all memory created by the ``FutharkContext`` object. Should + be called when the ``FutharkContext`` is done being used. It is an + error use a ``FutharkArray`` or ``FutharkOpaque`` after the + ``FutharkContext`` on which they were defined has been freed. + +Values +------ + +Numeric types ``u8``, ``u16``, ``u32``, ``i8``, ``i16``, ``i32``, ``f32``, +and ``f64`` are mapped to JavaScript's standard number type. 64-bit integers +``u64``, and ``i64`` are mapped to ``BigInt``. ``bool`` is mapped to +JavaScript's ``boolean`` type. Arrays are represented by the ``FutharkArray``. +complex types (records, nested tuples, etc) are represented by the +``FutharkOpaque`` class. + +FutharkArray +------------ + +``FutharkArray`` has the following API + +.. js:function:: FutharkArray.toArray() + + Returns a nested JavaScript array + +.. js:function:: FutharkArray.toTypedArray() + + Returns a flat typed array of the underlying data. + +.. js:function:: FutharkArray.shape() + + Returns the shape of the FutharkArray as an array of BigInts. + +.. js:function:: FutharkArray.free() + + Frees the memory used by the FutharkArray class + +``FutharkContext`` also contains two functions for creating +``FutharkArrays`` from JavaScript arrays, and typed arrays for each +array type that appears in an entry point. All array types share +similar API methods on the ``FutharkContext``, which is illustrated +here for the case of the type ``[]i32``. + +.. js:function:: FutharkContext.new_i32_1d_from_jsarray(jsarray) + + Creates and returns a one-dimensional ``i32`` ``FutharkArray`` representing + the JavaScript array jsarray + +.. js:function:: FutharkContext.new_i32_1d(array, dim1) + + Creates and returns a one-dimensional ``i32`` ``FutharkArray`` representing + the typed array of array, with the size given by dim1. + + +FutharkOpaque +------------- + +Complex types (records, nested tuples, etc) are represented by +``FutharkOpaque``. It has no use outside of being accepted and +returned by entry point functions. For this reason the method only has +one function for freeing the memory when ``FutharkOpaque`` is no +longer used. + +.. js:function:: FutharkOpaque.free() + + Frees memory used by FutharkOpaque. Should be called when Futhark + Opaque is no longer used. + +Entry Points +------------ + +Each entry point in the compiled futhark program has an entry point method on +the FutharkContext + +.. js:function:: FutharkContext.(in1, ..., inN) + + The entry point function taking the N arguments of the Futhark entry point + function, and returns the result. If the result is a tuple the return value + is an array. diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -51,13 +51,12 @@ Boolean literals are written ``true`` and ``false``. The primitive types in Futhark are the signed integer types ``i8``, ``i16``, ``i32``, ``i64``, the unsigned integer types ``u8``, ``u16``, ``u32``, -``u64``, the floating-point types ``f32``, ``f64``, as well as -``bool``. An ``f32`` is always a single-precision float and a ``f64`` -is a double-precision float. +``u64``, the floating-point types ``f16``, ``f32``, ``f64``, as well +as ``bool``. .. productionlist:: int_type: "i8" | "i16" | "i32" | "i64" | "u8" | "u16" | "u32" | "u64" - float_type: "f32" | "f64" + float_type: "f16" | "f32" | "f64" Numeric literals can be suffixed with their intended type. For example ``42i8`` is of type ``i8``, and ``1337e2f64`` is of type @@ -429,6 +428,8 @@ exp: `atom` : | `exp` `qualbinop` `exp` : | `exp` `exp` + : | "!" `exp` + : | "-" `exp` : | `constructor` `exp`* : | `exp` ":" `type` : | `exp` ":>" `type` @@ -503,6 +504,10 @@ enclosed in parentheses, rather than an operator section partially applying the infix operator ``-``. +* Function application and prefix operators bind more tightly than any + infix operator. Note that the only prefix operators are ``!`` and + ``-``, and more cannot be defined. + * The following table describes the precedence and associativity of infix operators. All operators in the same row have the same precedence. The rows are listed in increasing order of precedence. @@ -1401,7 +1406,7 @@ .. productionlist:: mod_bind: "module" `id` `mod_param`* "=" [":" mod_type_exp] "=" `mod_exp` mod_param: "(" `id` ":" `mod_type_exp` ")" - mod_type_bind: "module" "type" `id` `type_param`* "=" `mod_type_exp` + mod_type_bind: "module" "type" `id` "=" `mod_type_exp` Futhark supports an ML-style higher-order module system. *Modules* can contain types, functions, and other modules and module types. @@ -1657,6 +1662,32 @@ The following expression attributes are supported. +``trace`` +......... + +Print the value produced by the attributed expression. Used for +debugging. Somewhat unreliable outside of the interpreter, and in +particular does not work for GPU device code. + +``trace(tag)`` +.............. + +Like ``trace``, but prefix output with *tag*, which must lexically be +an identifier. + +``break`` +......... + +In the interpreter, pause execution *before* evaluating the expression. +No effect for compiled code. + +``opaque`` +.......... + +The compiler will treat the attributed expression as a black box. +This is used to work around optimisation deficiencies (or bugs), +although it should hopefully rarely be necessary. + ``incremental_flattening(no_outer)`` .................................... @@ -1744,6 +1775,11 @@ Do not inline any calls to this function. If the function is then used within a parallel construct (e.g. ``map``), this will likely prevent the GPU backends from generating working code. + +``inline`` +.......... + +Always inline calls to this function. Spec attributes ~~~~~~~~~~~~~~~ diff --git a/docs/man/futhark-cuda.rst b/docs/man/futhark-cuda.rst --- a/docs/man/futhark-cuda.rst +++ b/docs/man/futhark-cuda.rst @@ -161,13 +161,19 @@ compiler to compile the generated C program into a binary. This only works if the C compiler can find the necessary CUDA libraries. On most systems, CUDA is installed in ``/usr/local/cuda``, which is -usually not part of the default compiler search path. You may need to +usually not part of the default compiler search path. You may need to set the following environment variables before running ``futhark cuda``:: LIBRARY_PATH=/usr/local/cuda/lib64 LD_LIBRARY_PATH=/usr/local/cuda/lib64/ CPATH=/usr/local/cuda/include + +At runtime the generated program must be able to find the CUDA +installation directory, which is normally located at +``/usr/local/cuda``. If you have CUDA installed elsewhere, set any of +the ``CUDA_HOME``, ``CUDA_ROOT``, or ``CUDA_PATH`` environment +variables to the proper directory. SEE ALSO ======== diff --git a/docs/man/futhark-repl.rst b/docs/man/futhark-repl.rst --- a/docs/man/futhark-repl.rst +++ b/docs/man/futhark-repl.rst @@ -25,7 +25,8 @@ colon. ``futhark repl`` uses the Futhark interpreter, which grants access to -certain special functions. See :ref:`futhark-run(1)` for a description. +the ``#[trace]`` and ``#[break]`` attributes. See +:ref:`futhark-run(1)` for a description. OPTIONS ======= diff --git a/docs/man/futhark-run.rst b/docs/man/futhark-run.rst --- a/docs/man/futhark-run.rst +++ b/docs/man/futhark-run.rst @@ -19,18 +19,10 @@ output. ``futhark run`` is very slow, and in practice only useful for testing, -teaching, and experimenting with the language. Certain special -debugging functions are available in ``futhark run``: - -``trace 'a : a -> a`` - Semantically identity, but prints the value on standard output. - -``break 'a : a -> a`` - Semantically identity, but interrupts execution at the calling - point, such that the environment can be inspected. Continue - execution by entering an empty input line. Breakpoints are only - respected when starting a program from the prompt, not when - passing a program on the command line. +teaching, and experimenting with the language. The ``#[trace]`` and +``#[break]`` attributes are fully supported in the interpreter. +Tracing prints values to stdout in contrast to compiled code, which +prints to stderr. OPTIONS ======= diff --git a/docs/man/futhark-wasm-multicore.rst b/docs/man/futhark-wasm-multicore.rst new file mode 100644 --- /dev/null +++ b/docs/man/futhark-wasm-multicore.rst @@ -0,0 +1,99 @@ +.. role:: ref(emphasis) + +.. _futhark-wasm-multicore(1): + +====================== +futhark-wasm-multicore +====================== + +SYNOPSIS +======== + +futhark wasm-multicore [options...] + +DESCRIPTION +=========== + +``futhark wasm-multicore`` translates a Futhark program to +multi-threaded WebAssembly code by first generating C as ``futhark +c``, and then using Emscripten (``emcc``). This produces a ``.js`` +file that allows the compiled code to be invoked from JavaScript. +Executables implement the Futhark server protocol and can be run with +Node.js. + +OPTIONS +======= + +-h + Print help text to standard output and exit. + +--entry-point NAME + Treat this top-level function as an entry point. + +--library + Generate a library instead of an executable. Appends ``.js`` + to the name indicated by the ``-o`` option to determine output + file names. + +-o outfile + Where to write the result. If the source program is named + ``foo.fut``, this defaults to ``foo``. + +--safe + Ignore ``unsafe`` in program and perform safety checks unconditionally. + +--server + Generate a server-mode executable that reads commands from stdin. + +-v verbose + Enable debugging output. If compilation fails due to a compiler + error, the result of the last successful compiler step will be + printed to standard error. + +-V + Print version information on standard output and exit. + +-W + Do not print any warnings. + +--Werror + Treat warnings as errors. + + + +ENVIRONMENT VARIABLES +===================== + +``CFLAGS`` + + Space-separated list of options passed to ``emcc``. Defaults + to ``-O3 -std=c99`` if unset. + +``EMCFLAGS`` + + Space-separated list of options passed to ``emcc``. + +EXECUTABLE OPTIONS +================== + +The following options are accepted by executables generated by +``futhark wasm-multicore``. + +-h, --help + + Print help text to standard output and exit. + +-D, --debugging + + Perform possibly expensive internal correctness checks and verbose + logging. Implies ``-L``. + +-L, --log + + Print various low-overhead logging information to stderr while + running. + +SEE ALSO +======== + +:ref:`futhark-c(1)`, :ref:`futhark-wasm(1)` diff --git a/docs/man/futhark-wasm.rst b/docs/man/futhark-wasm.rst new file mode 100644 --- /dev/null +++ b/docs/man/futhark-wasm.rst @@ -0,0 +1,98 @@ +.. role:: ref(emphasis) + +.. _futhark-wasm(1): + +============ +futhark-wasm +============ + +SYNOPSIS +======== + +futhark wasm [options...] + +DESCRIPTION +=========== + +``futhark wasm`` translates a Futhark program to sequential +WebAssembly code by first generating C as ``futhark c``, and then +using Emscripten (``emcc``). This produces a ``.js`` file that allows +the compiled code to be invoked from JavaScript. Executables +implement the Futhark server protocol and can be run with Node.js. + +OPTIONS +======= + +-h + Print help text to standard output and exit. + +--entry-point NAME + Treat this top-level function as an entry point. + +--library + Generate a library instead of an executable. Appends ``.js`` + to the name indicated by the ``-o`` option to determine output + file names. + +-o outfile + Where to write the result. If the source program is named + ``foo.fut``, this defaults to ``foo``. + +--safe + Ignore ``unsafe`` in program and perform safety checks unconditionally. + +--server + Generate a server-mode executable that reads commands from stdin. + This is the default. + +-v verbose + Enable debugging output. If compilation fails due to a compiler + error, the result of the last successful compiler step will be + printed to standard error. + +-V + Print version information on standard output and exit. + +-W + Do not print any warnings. + +--Werror + Treat warnings as errors. + +ENVIRONMENT VARIABLES +===================== + +``CFLAGS`` + + Space-separated list of options passed to ``emcc``. Defaults + to ``-O3 -std=c99`` if unset. + +``EMCFLAGS`` + + Space-separated list of options passed to ``emcc``. + +EXECUTABLE OPTIONS +================== + +The following options are accepted by executables generated by +``futhark wasm``. + +-h, --help + + Print help text to standard output and exit. + +-D, --debugging + + Perform possibly expensive internal correctness checks and verbose + logging. Implies ``-L``. + +-L, --log + + Print various low-overhead logging information to stderr while + running. + + +SEE ALSO +======== + +:ref:`futhark-c(1)`, :ref:`futhark-wasm-multicore(1)` diff --git a/docs/man/futhark.rst b/docs/man/futhark.rst --- a/docs/man/futhark.rst +++ b/docs/man/futhark.rst @@ -74,4 +74,4 @@ SEE ALSO ======== -:ref:`futhark-opencl(1)`, :ref:`futhark-c(1)`, :ref:`futhark-py(1)`, :ref:`futhark-pyopencl(1)`, :ref:`futhark-dataset(1)`, :ref:`futhark-doc(1)`, :ref:`futhark-test(1)`, :ref:`futhark-bench(1)`, :ref:`futhark-run(1)`, :ref:`futhark-repl(1)`, :ref:`futhark-literate(1)` +:ref:`futhark-opencl(1)`, :ref:`futhark-c(1)`, :ref:`futhark-py(1)`, :ref:`futhark-pyopencl(1)`, :ref:`futhark-wasm(1)`, :ref:`futhark-wasm-multicore(1)`, :ref:`futhark-dataset(1)`, :ref:`futhark-doc(1)`, :ref:`futhark-test(1)`, :ref:`futhark-bench(1)`, :ref:`futhark-run(1)`, :ref:`futhark-repl(1)`, :ref:`futhark-literate(1)` diff --git a/docs/server-protocol.rst b/docs/server-protocol.rst --- a/docs/server-protocol.rst +++ b/docs/server-protocol.rst @@ -71,10 +71,10 @@ The following commands are supported. -``call`` *entry* *o1* ... *oN* *i1* ... *oM* +``call`` *entry* *o1* ... *oN* *i1* ... *iM* ............................................ -Call the given entry point with input from the variables *i1* to *oM*. +Call the given entry point with input from the variables *i1* to *iM*. The results are stored in *o1* to *oN*, which must not already exist. ``restore`` *file* *v1* *t1* ... *vN* *tN* 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.19.7 +version: 0.20.1 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to @@ -35,6 +35,7 @@ extra-source-files: rts/c/*.h rts/futhark-doc/*.css + rts/javascript/*.js rts/python/*.py prelude/*.fut -- Just enough of the docs to build the manpages. @@ -70,8 +71,8 @@ Futhark.Analysis.SymbolTable Futhark.Analysis.UsageTable Futhark.Bench - Futhark.Binder - Futhark.Binder.Class + Futhark.Builder + Futhark.Builder.Class Futhark.CLI.Autotune Futhark.CLI.Bench Futhark.CLI.C @@ -84,6 +85,7 @@ Futhark.CLI.Literate Futhark.CLI.Misc Futhark.CLI.Multicore + Futhark.CLI.MulticoreWASM Futhark.CLI.OpenCL Futhark.CLI.Pkg Futhark.CLI.PyOpenCL @@ -92,6 +94,7 @@ Futhark.CLI.REPL Futhark.CLI.Run Futhark.CLI.Test + Futhark.CLI.WASM Futhark.CodeGen.Backends.CCUDA Futhark.CodeGen.Backends.CCUDA.Boilerplate Futhark.CodeGen.Backends.COpenCL @@ -102,15 +105,20 @@ Futhark.CodeGen.Backends.GenericC.Server Futhark.CodeGen.Backends.GenericPython Futhark.CodeGen.Backends.GenericPython.AST - Futhark.CodeGen.Backends.GenericPython.Definitions Futhark.CodeGen.Backends.GenericPython.Options + Futhark.CodeGen.Backends.GenericWASM Futhark.CodeGen.Backends.MulticoreC + Futhark.CodeGen.Backends.MulticoreWASM Futhark.CodeGen.Backends.PyOpenCL Futhark.CodeGen.Backends.PyOpenCL.Boilerplate Futhark.CodeGen.Backends.SequentialC Futhark.CodeGen.Backends.SequentialC.Boilerplate Futhark.CodeGen.Backends.SequentialPython + Futhark.CodeGen.Backends.SequentialWASM Futhark.CodeGen.Backends.SimpleRep + Futhark.CodeGen.RTS.C + Futhark.CodeGen.RTS.Python + Futhark.CodeGen.RTS.JavaScript Futhark.CodeGen.ImpCode Futhark.CodeGen.ImpCode.GPU Futhark.CodeGen.ImpCode.Multicore @@ -150,7 +158,7 @@ Futhark.IR Futhark.IR.Aliases Futhark.IR.GPU - Futhark.IR.GPU.Kernel + Futhark.IR.GPU.Op Futhark.IR.GPU.Simplify Futhark.IR.GPU.Sizes Futhark.IR.GPUMem @@ -303,25 +311,27 @@ , ansi-terminal >=0.6.3.1 , array >=0.4 , base >=4.13 && <5 + , base16-bytestring , binary >=0.8.3 , blaze-html >=0.9.0.1 , bytestring >=0.10.8 , bytestring-to-vector >=0.3.0.1 , bmp >=1.2.6.3 , containers >=0.6.2.1 + , cryptohash-md5 , directory >=1.3.0.0 , directory-tree >=0.12.1 , dlist >=0.6.0.1 - , file-embed >=0.0.9 + , file-embed >=0.0.14.0 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark-data >= 1.0.0.1 + , futhark-data >= 1.0.2.0 , futhark-server >= 1.1.0.0 - , gitrev >=1.2.0 - , hashable + , githash >=0.1.6.1 + , half >= 0.3 , haskeline , language-c-quote >=0.12 - , mainland-pretty >=0.6.1 + , mainland-pretty >=0.7.1 , cmark-gfm >=0.2.1 , megaparsec >=9.0.0 , mtl >=2.2.1 @@ -339,7 +349,6 @@ , time >=1.6.0.1 , transformers >=0.3 , unordered-containers >=0.2.7 - , utf8-string >=1 , vector >=0.12 , vector-binary-instances >=0.2.2.0 , versions >=5.0.0 diff --git a/prelude/math.fut b/prelude/math.fut --- a/prelude/math.fut +++ b/prelude/math.fut @@ -17,6 +17,7 @@ val u32: u32 -> t val u64: u64 -> t + val f16: f16 -> t val f32: f32 -> t val f64: f64 -> t @@ -89,8 +90,10 @@ val &: t -> t -> t val |: t -> t -> t val ^: t -> t -> t - val !: t -> t + -- | Bitwise negation. + val not: t -> t + val <<: t -> t -> t val >>: t -> t -> t val >>>: t -> t -> t @@ -111,12 +114,13 @@ val mad_hi: (a: t) -> (b: t) -> (c: t) -> t -- | Count number of zero bits preceding the most significant set - -- bit. + -- bit. Returns the number of bits in the type if the argument is + -- zero. val clz: t -> i32 -- | Count number of trailing zero bits following the least -- significant set bit. Returns the number of bits in the type if - -- the argument is all-zero. + -- the argument is zero. val ctz: t -> i32 } @@ -233,6 +237,7 @@ let u32 (x: u32) = intrinsics.itob_i32_bool (intrinsics.sign_i32 x) let u64 (x: u64) = intrinsics.itob_i64_bool (intrinsics.sign_i64 x) + let f16 (x: f16) = x != 0f16 let f32 (x: f32) = x != 0f32 let f64 (x: f64) = x != 0f64 @@ -254,7 +259,7 @@ let (x: i8) & (y: i8) = intrinsics.and8 (x, y) let (x: i8) | (y: i8) = intrinsics.or8 (x, y) let (x: i8) ^ (y: i8) = intrinsics.xor8 (x, y) - let ! (x: i8) = intrinsics.complement8 x + let not (x: i8) = intrinsics.complement8 x let (x: i8) << (y: i8) = intrinsics.shl8 (x, y) let (x: i8) >> (y: i8) = intrinsics.ashr8 (x, y) @@ -270,6 +275,7 @@ let u32 (x: u32) = intrinsics.zext_i32_i8 (intrinsics.sign_i32 x) let u64 (x: u64) = intrinsics.zext_i64_i8 (intrinsics.sign_i64 x) + let f16 (x: f16) = intrinsics.fptosi_f16_i8 x let f32 (x: f32) = intrinsics.fptosi_f32_i8 x let f64 (x: f64) = intrinsics.fptosi_f64_i8 x @@ -283,7 +289,7 @@ let (x: i8) > (y: i8) = intrinsics.slt8 (y, x) let (x: i8) <= (y: i8) = intrinsics.sle8 (x, y) let (x: i8) >= (y: i8) = intrinsics.sle8 (y, x) - let (x: i8) != (y: i8) = intrinsics.! (x == y) + let (x: i8) != (y: i8) = !(x == y) let sgn (x: i8) = intrinsics.ssignum8 x let abs (x: i8) = intrinsics.abs8 x @@ -298,7 +304,7 @@ let num_bits = 8i32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1) let set_bit (bit: i32) (x: t) (b: i32) = - ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) + ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) let popc = intrinsics.popc8 let mul_hi a b = intrinsics.mul_hi8 (i8 a, i8 b) let mad_hi a b c = intrinsics.mad_hi8 (i8 a, i8 b, i8 c) @@ -326,7 +332,7 @@ let (x: i16) & (y: i16) = intrinsics.and16 (x, y) let (x: i16) | (y: i16) = intrinsics.or16 (x, y) let (x: i16) ^ (y: i16) = intrinsics.xor16 (x, y) - let ! (x: i16) = intrinsics.complement16 x + let not (x: i16) = intrinsics.complement16 x let (x: i16) << (y: i16) = intrinsics.shl16 (x, y) let (x: i16) >> (y: i16) = intrinsics.ashr16 (x, y) @@ -342,6 +348,7 @@ let u32 (x: u32) = intrinsics.zext_i32_i16 (intrinsics.sign_i32 x) let u64 (x: u64) = intrinsics.zext_i64_i16 (intrinsics.sign_i64 x) + let f16 (x: f16) = intrinsics.fptosi_f16_i16 x let f32 (x: f32) = intrinsics.fptosi_f32_i16 x let f64 (x: f64) = intrinsics.fptosi_f64_i16 x @@ -355,7 +362,7 @@ let (x: i16) > (y: i16) = intrinsics.slt16 (y, x) let (x: i16) <= (y: i16) = intrinsics.sle16 (x, y) let (x: i16) >= (y: i16) = intrinsics.sle16 (y, x) - let (x: i16) != (y: i16) = intrinsics.! (x == y) + let (x: i16) != (y: i16) = !(x == y) let sgn (x: i16) = intrinsics.ssignum16 x let abs (x: i16) = intrinsics.abs16 x @@ -370,7 +377,7 @@ let num_bits = 16i32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1) let set_bit (bit: i32) (x: t) (b: i32) = - ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) + ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) let popc = intrinsics.popc16 let mul_hi a b = intrinsics.mul_hi16 (i16 a, i16 b) let mad_hi a b c = intrinsics.mad_hi16 (i16 a, i16 b, i16 c) @@ -401,7 +408,7 @@ let (x: i32) & (y: i32) = intrinsics.and32 (x, y) let (x: i32) | (y: i32) = intrinsics.or32 (x, y) let (x: i32) ^ (y: i32) = intrinsics.xor32 (x, y) - let ! (x: i32) = intrinsics.complement32 x + let not (x: i32) = intrinsics.complement32 x let (x: i32) << (y: i32) = intrinsics.shl32 (x, y) let (x: i32) >> (y: i32) = intrinsics.ashr32 (x, y) @@ -417,6 +424,7 @@ let u32 (x: u32) = intrinsics.zext_i32_i32 (intrinsics.sign_i32 x) let u64 (x: u64) = intrinsics.zext_i64_i32 (intrinsics.sign_i64 x) + let f16 (x: f16) = intrinsics.fptosi_f16_i32 x let f32 (x: f32) = intrinsics.fptosi_f32_i32 x let f64 (x: f64) = intrinsics.fptosi_f64_i32 x @@ -430,7 +438,7 @@ let (x: i32) > (y: i32) = intrinsics.slt32 (y, x) let (x: i32) <= (y: i32) = intrinsics.sle32 (x, y) let (x: i32) >= (y: i32) = intrinsics.sle32 (y, x) - let (x: i32) != (y: i32) = intrinsics.! (x == y) + let (x: i32) != (y: i32) = !(x == y) let sgn (x: i32) = intrinsics.ssignum32 x let abs (x: i32) = intrinsics.abs32 x @@ -445,7 +453,7 @@ let num_bits = 32i32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1) let set_bit (bit: i32) (x: t) (b: i32) = - ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) + ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) let popc = intrinsics.popc32 let mul_hi a b = intrinsics.mul_hi32 (i32 a, i32 b) let mad_hi a b c = intrinsics.mad_hi32 (i32 a, i32 b, i32 c) @@ -476,7 +484,7 @@ let (x: i64) & (y: i64) = intrinsics.and64 (x, y) let (x: i64) | (y: i64) = intrinsics.or64 (x, y) let (x: i64) ^ (y: i64) = intrinsics.xor64 (x, y) - let ! (x: i64) = intrinsics.complement64 x + let not (x: i64) = intrinsics.complement64 x let (x: i64) << (y: i64) = intrinsics.shl64 (x, y) let (x: i64) >> (y: i64) = intrinsics.ashr64 (x, y) @@ -492,6 +500,7 @@ let u32 (x: u32) = intrinsics.zext_i32_i64 (intrinsics.sign_i32 x) let u64 (x: u64) = intrinsics.zext_i64_i64 (intrinsics.sign_i64 x) + let f16 (x: f16) = intrinsics.fptosi_f16_i64 x let f32 (x: f32) = intrinsics.fptosi_f32_i64 x let f64 (x: f64) = intrinsics.fptosi_f64_i64 x @@ -505,7 +514,7 @@ let (x: i64) > (y: i64) = intrinsics.slt64 (y, x) let (x: i64) <= (y: i64) = intrinsics.sle64 (x, y) let (x: i64) >= (y: i64) = intrinsics.sle64 (y, x) - let (x: i64) != (y: i64) = intrinsics.! (x == y) + let (x: i64) != (y: i64) = !(x == y) let sgn (x: i64) = intrinsics.ssignum64 x let abs (x: i64) = intrinsics.abs64 x @@ -520,7 +529,7 @@ let num_bits = 64i32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1) let set_bit (bit: i32) (x: t) (b: i32) = - ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | intrinsics.zext_i32_i64 (b intrinsics.<< bit)) + ((x & i32 (!(1 intrinsics.<< bit))) | intrinsics.zext_i32_i64 (b intrinsics.<< bit)) let popc = intrinsics.popc64 let mul_hi a b = intrinsics.mul_hi64 (i64 a, i64 b) let mad_hi a b c = intrinsics.mad_hi64 (i64 a, i64 b, i64 c) @@ -551,7 +560,7 @@ let (x: u8) & (y: u8) = unsign (intrinsics.and8 (sign x, sign y)) let (x: u8) | (y: u8) = unsign (intrinsics.or8 (sign x, sign y)) let (x: u8) ^ (y: u8) = unsign (intrinsics.xor8 (sign x, sign y)) - let ! (x: u8) = unsign (intrinsics.complement8 (sign x)) + let not (x: u8) = unsign (intrinsics.complement8 (sign x)) let (x: u8) << (y: u8) = unsign (intrinsics.shl8 (sign x, sign y)) let (x: u8) >> (y: u8) = unsign (intrinsics.ashr8 (sign x, sign y)) @@ -567,6 +576,7 @@ let i32 (x: i32) = unsign (intrinsics.zext_i32_i8 x) let i64 (x: i64) = unsign (intrinsics.zext_i64_i8 x) + let f16 (x: f16) = unsign (intrinsics.fptoui_f16_i8 x) let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i8 x) let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i8 x) @@ -580,7 +590,7 @@ let (x: u8) > (y: u8) = intrinsics.ult8 (sign y, sign x) let (x: u8) <= (y: u8) = intrinsics.ule8 (sign x, sign y) let (x: u8) >= (y: u8) = intrinsics.ule8 (sign y, sign x) - let (x: u8) != (y: u8) = intrinsics.! (x == y) + let (x: u8) != (y: u8) = !(x == y) let sgn (x: u8) = unsign (intrinsics.usignum8 (sign x)) let abs (x: u8) = x @@ -595,7 +605,7 @@ let num_bits = 8i32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1) let set_bit (bit: i32) (x: t) (b: i32) = - ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) + ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) let popc x = intrinsics.popc8 (sign x) let mul_hi a b = unsign (intrinsics.mul_hi8 (sign a, sign b)) let mad_hi a b c = unsign (intrinsics.mad_hi8 (sign a, sign b, sign c)) @@ -626,7 +636,7 @@ let (x: u16) & (y: u16) = unsign (intrinsics.and16 (sign x, sign y)) let (x: u16) | (y: u16) = unsign (intrinsics.or16 (sign x, sign y)) let (x: u16) ^ (y: u16) = unsign (intrinsics.xor16 (sign x, sign y)) - let ! (x: u16) = unsign (intrinsics.complement16 (sign x)) + let not (x: u16) = unsign (intrinsics.complement16 (sign x)) let (x: u16) << (y: u16) = unsign (intrinsics.shl16 (sign x, sign y)) let (x: u16) >> (y: u16) = unsign (intrinsics.ashr16 (sign x, sign y)) @@ -642,6 +652,7 @@ let i32 (x: i32) = unsign (intrinsics.zext_i32_i16 x) let i64 (x: i64) = unsign (intrinsics.zext_i64_i16 x) + let f16 (x: f16) = unsign (intrinsics.fptoui_f16_i16 x) let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i16 x) let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i16 x) @@ -655,7 +666,7 @@ let (x: u16) > (y: u16) = intrinsics.ult16 (sign y, sign x) let (x: u16) <= (y: u16) = intrinsics.ule16 (sign x, sign y) let (x: u16) >= (y: u16) = intrinsics.ule16 (sign y, sign x) - let (x: u16) != (y: u16) = intrinsics.! (x == y) + let (x: u16) != (y: u16) = !(x == y) let sgn (x: u16) = unsign (intrinsics.usignum16 (sign x)) let abs (x: u16) = x @@ -670,7 +681,7 @@ let num_bits = 16i32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1) let set_bit (bit: i32) (x: t) (b: i32) = - ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) + ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) let popc x = intrinsics.popc16 (sign x) let mul_hi a b = unsign (intrinsics.mul_hi16 (sign a, sign b)) let mad_hi a b c = unsign (intrinsics.mad_hi16 (sign a, sign b, sign c)) @@ -701,7 +712,7 @@ let (x: u32) & (y: u32) = unsign (intrinsics.and32 (sign x, sign y)) let (x: u32) | (y: u32) = unsign (intrinsics.or32 (sign x, sign y)) let (x: u32) ^ (y: u32) = unsign (intrinsics.xor32 (sign x, sign y)) - let ! (x: u32) = unsign (intrinsics.complement32 (sign x)) + let not (x: u32) = unsign (intrinsics.complement32 (sign x)) let (x: u32) << (y: u32) = unsign (intrinsics.shl32 (sign x, sign y)) let (x: u32) >> (y: u32) = unsign (intrinsics.ashr32 (sign x, sign y)) @@ -717,6 +728,7 @@ let i32 (x: i32) = unsign (intrinsics.zext_i32_i32 x) let i64 (x: i64) = unsign (intrinsics.zext_i64_i32 x) + let f16 (x: f16) = unsign (intrinsics.fptoui_f16_i32 x) let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i32 x) let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i32 x) @@ -730,7 +742,7 @@ let (x: u32) > (y: u32) = intrinsics.ult32 (sign y, sign x) let (x: u32) <= (y: u32) = intrinsics.ule32 (sign x, sign y) let (x: u32) >= (y: u32) = intrinsics.ule32 (sign y, sign x) - let (x: u32) != (y: u32) = intrinsics.! (x == y) + let (x: u32) != (y: u32) = !(x == y) let sgn (x: u32) = unsign (intrinsics.usignum32 (sign x)) let abs (x: u32) = x @@ -745,7 +757,7 @@ let num_bits = 32i32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1) let set_bit (bit: i32) (x: t) (b: i32) = - ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) + ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) let popc x = intrinsics.popc32 (sign x) let mul_hi a b = unsign (intrinsics.mul_hi32 (sign a, sign b)) let mad_hi a b c = unsign (intrinsics.mad_hi32 (sign a, sign b, sign c)) @@ -776,7 +788,7 @@ let (x: u64) & (y: u64) = unsign (intrinsics.and64 (sign x, sign y)) let (x: u64) | (y: u64) = unsign (intrinsics.or64 (sign x, sign y)) let (x: u64) ^ (y: u64) = unsign (intrinsics.xor64 (sign x, sign y)) - let ! (x: u64) = unsign (intrinsics.complement64 (sign x)) + let not (x: u64) = unsign (intrinsics.complement64 (sign x)) let (x: u64) << (y: u64) = unsign (intrinsics.shl64 (sign x, sign y)) let (x: u64) >> (y: u64) = unsign (intrinsics.ashr64 (sign x, sign y)) @@ -792,6 +804,7 @@ let i32 (x: i32) = unsign (intrinsics.zext_i32_i64 x) let i64 (x: i64) = unsign (intrinsics.zext_i64_i64 x) + let f16 (x: f16) = unsign (intrinsics.fptoui_f16_i64 x) let f32 (x: f32) = unsign (intrinsics.fptoui_f32_i64 x) let f64 (x: f64) = unsign (intrinsics.fptoui_f64_i64 x) @@ -805,7 +818,7 @@ let (x: u64) > (y: u64) = intrinsics.ult64 (sign y, sign x) let (x: u64) <= (y: u64) = intrinsics.ule64 (sign x, sign y) let (x: u64) >= (y: u64) = intrinsics.ule64 (sign y, sign x) - let (x: u64) != (y: u64) = intrinsics.! (x == y) + let (x: u64) != (y: u64) = !(x == y) let sgn (x: u64) = unsign (intrinsics.usignum64 (sign x)) let abs (x: u64) = x @@ -820,7 +833,7 @@ let num_bits = 64i32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1) let set_bit (bit: i32) (x: t) (b: i32) = - ((x & i32 (intrinsics.!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) + ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit)) let popc x = intrinsics.popc64 (sign x) let mul_hi a b = unsign (intrinsics.mul_hi64 (sign a, sign b)) let mad_hi a b c = unsign (intrinsics.mad_hi64 (sign a, sign b, sign c)) @@ -857,6 +870,7 @@ let i32 (x: i32) = intrinsics.sitofp_i32_f64 x let i64 (x: i64) = intrinsics.sitofp_i64_f64 x + let f16 (x: f16) = intrinsics.fpconv_f16_f64 x let f32 (x: f32) = intrinsics.fpconv_f32_f64 x let f64 (x: f64) = intrinsics.fpconv_f64_f64 x @@ -871,7 +885,7 @@ let (x: f64) > (y: f64) = intrinsics.lt64 (y, x) let (x: f64) <= (y: f64) = intrinsics.le64 (x, y) let (x: f64) >= (y: f64) = intrinsics.le64 (y, x) - let (x: f64) != (y: f64) = intrinsics.! (x == y) + let (x: f64) != (y: f64) = !(x == y) let neg (x: t) = -x let recip (x: t) = 1/x @@ -965,6 +979,7 @@ let i32 (x: i32) = intrinsics.sitofp_i32_f32 x let i64 (x: i64) = intrinsics.sitofp_i64_f32 x + let f16 (x: f16) = intrinsics.fpconv_f16_f32 x let f32 (x: f32) = intrinsics.fpconv_f32_f32 x let f64 (x: f64) = intrinsics.fpconv_f64_f32 x @@ -979,7 +994,7 @@ let (x: f32) > (y: f32) = intrinsics.lt32 (y, x) let (x: f32) <= (y: f32) = intrinsics.le32 (x, y) let (x: f32) >= (y: f32) = intrinsics.le32 (y, x) - let (x: f32) != (y: f32) = intrinsics.! (x == y) + let (x: f32) != (y: f32) = !(x == y) let neg (x: t) = -x let recip (x: t) = 1/x @@ -1038,6 +1053,119 @@ let highest = inf let lowest = -inf let epsilon = 1.1920929e-7f32 + + let pi = f64 f64m.pi + let e = f64 f64m.e + + let sum = reduce (+) (i32 0) + let product = reduce (*) (i32 1) + let maximum = reduce max lowest + let minimum = reduce min highest +} + +-- | Emulated with single precision on systems that do not natively +-- support half precision. This means you might get more accurate +-- results than on real systems, but it is also likely to be +-- significantly slower than just using `f32` in the first place. +module f16: (float with t = f16 with int_t = u16) = { + type t = f16 + type int_t = u16 + + module i16m = i16 + module u16m = u16 + module f64m = f64 + + let (x: f16) + (y: f16) = intrinsics.fadd16 (x, y) + let (x: f16) - (y: f16) = intrinsics.fsub16 (x, y) + let (x: f16) * (y: f16) = intrinsics.fmul16 (x, y) + let (x: f16) / (y: f16) = intrinsics.fdiv16 (x, y) + let (x: f16) % (y: f16) = intrinsics.fmod16 (x, y) + let (x: f16) ** (y: f16) = intrinsics.fpow16 (x, y) + + let u8 (x: u8) = intrinsics.uitofp_i8_f16 (i8.u8 x) + let u16 (x: u16) = intrinsics.uitofp_i16_f16 (i16.u16 x) + let u32 (x: u32) = intrinsics.uitofp_i32_f16 (i32.u32 x) + let u64 (x: u64) = intrinsics.uitofp_i64_f16 (i64.u64 x) + + let i8 (x: i8) = intrinsics.sitofp_i8_f16 x + let i16 (x: i16) = intrinsics.sitofp_i16_f16 x + let i32 (x: i32) = intrinsics.sitofp_i32_f16 x + let i64 (x: i64) = intrinsics.sitofp_i64_f16 x + + let f16 (x: f16) = intrinsics.fpconv_f16_f16 x + let f32 (x: f32) = intrinsics.fpconv_f32_f16 x + let f64 (x: f64) = intrinsics.fpconv_f64_f16 x + + let bool (x: bool) = if x then 1f16 else 0f16 + + let from_fraction (x: i64) (y: i64) = i64 x / i64 y + let to_i64 (x: f16) = intrinsics.fptosi_f16_i64 x + let to_f64 (x: f16) = intrinsics.fpconv_f16_f64 x + + let (x: f16) == (y: f16) = intrinsics.eq_f16 (x, y) + let (x: f16) < (y: f16) = intrinsics.lt16 (x, y) + let (x: f16) > (y: f16) = intrinsics.lt16 (y, x) + let (x: f16) <= (y: f16) = intrinsics.le16 (x, y) + let (x: f16) >= (y: f16) = intrinsics.le16 (y, x) + let (x: f16) != (y: f16) = !(x == y) + + let neg (x: t) = -x + let recip (x: t) = 1/x + let max (x: t) (y: t) = intrinsics.fmax16 (x, y) + let min (x: t) (y: t) = intrinsics.fmin16 (x, y) + + let sgn (x: f16) = intrinsics.fsignum16 x + let abs (x: f16) = intrinsics.fabs16 x + + let sqrt (x: f16) = intrinsics.sqrt16 x + + let log (x: f16) = intrinsics.log16 x + let log2 (x: f16) = intrinsics.log2_16 x + let log10 (x: f16) = intrinsics.log10_16 x + let exp (x: f16) = intrinsics.exp16 x + let sin (x: f16) = intrinsics.sin16 x + let cos (x: f16) = intrinsics.cos16 x + let tan (x: f16) = intrinsics.tan16 x + let acos (x: f16) = intrinsics.acos16 x + let asin (x: f16) = intrinsics.asin16 x + let atan (x: f16) = intrinsics.atan16 x + let sinh (x: f16) = intrinsics.sinh16 x + let cosh (x: f16) = intrinsics.cosh16 x + let tanh (x: f16) = intrinsics.tanh16 x + let acosh (x: f16) = intrinsics.acosh16 x + let asinh (x: f16) = intrinsics.asinh16 x + let atanh (x: f16) = intrinsics.atanh16 x + let atan2 (x: f16) (y: f16) = intrinsics.atan2_16 (x, y) + let hypot (x: f16) (y: f16) = intrinsics.hypot16 (x, y) + let gamma = intrinsics.gamma16 + let lgamma = intrinsics.lgamma16 + + let lerp v0 v1 t = intrinsics.lerp16 (v0,v1,t) + let fma a b c = intrinsics.fma16 (a,b,c) + let mad a b c = intrinsics.mad16 (a,b,c) + + let ceil = intrinsics.ceil16 + let floor = intrinsics.floor16 + let trunc (x: f16) : f16 = i16 (i16m.f16 x) + + let round = intrinsics.round16 + + let to_bits (x: f16): u16 = u16m.i16 (intrinsics.to_bits16 x) + let from_bits (x: u16): f16 = intrinsics.from_bits16 (intrinsics.sign_i16 x) + + let num_bits = 16i32 + let get_bit (bit: i32) (x: t) = u16m.get_bit bit (to_bits x) + let set_bit (bit: i32) (x: t) (b: i32) = from_bits (u16m.set_bit bit (to_bits x) b) + + let isinf (x: f16) = intrinsics.isinf16 x + let isnan (x: f16) = intrinsics.isnan16 x + + let inf = 1f16 / 0f16 + let nan = 0f16 / 0f16 + + let highest = inf + let lowest = -inf + let epsilon = 1.1920929e-7f16 let pi = f64 f64m.pi let e = f64 f64m.e diff --git a/prelude/prelude.fut b/prelude/prelude.fut --- a/prelude/prelude.fut +++ b/prelude/prelude.fut @@ -20,15 +20,16 @@ -- inhibitor. The compiler will treat this function as a black box. -- You can use this to work around optimisation deficiencies (or -- bugs), although it should hopefully rarely be necessary. +-- Deprecated: use `#[opaque]` attribute instead. let opaque 't (x: t): t = - intrinsics.opaque x + #[opaque] x --- | Semantically just identity, but when run in the interpreter, the --- argument value will be printed. +-- | Semantically just identity, but at runtime, the argument value +-- will be printed. Deprecated: use `#[trace]` attribute instead. let trace 't (x: t): t = - intrinsics.trace x + #[trace(trace)] x -- | Semantically just identity, but acts as a break point in --- `futhark repl`. +-- `futhark repl`. Deprecated: use `#[break]` attribute instead. let break 't (x: t): t = - intrinsics.break x + #[break] x diff --git a/rts/c/cuda.h b/rts/c/cuda.h --- a/rts/c/cuda.h +++ b/rts/c/cuda.h @@ -345,6 +345,18 @@ opts[i++] = msgprintf("-DLOCKSTEP_WIDTH=%zu", ctx->lockstep_width); opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_block_size); + // Time for the best lines of the code in the entire compiler. + if (getenv("CUDA_HOME") != NULL) { + opts[i++] = msgprintf("-I%s/include", getenv("CUDA_HOME")); + } + if (getenv("CUDA_ROOT") != NULL) { + opts[i++] = msgprintf("-I%s/include", getenv("CUDA_ROOT")); + } + if (getenv("CUDA_PATH") != NULL) { + opts[i++] = msgprintf("-I%s/include", getenv("CUDA_PATH")); + } + opts[i++] = msgprintf("-I/usr/local/cuda/include"); + // It is crucial that the extra_opts are last, so that the free() // logic below does not cause problems. for (int j = 0; extra_opts[j] != NULL; j++) { diff --git a/rts/c/half.h b/rts/c/half.h new file mode 100644 --- /dev/null +++ b/rts/c/half.h @@ -0,0 +1,238 @@ +// Start of half.h. + +// Conversion functions are from http://half.sourceforge.net/, but +// translated to C. +// +// Copyright (c) 2012-2021 Christian Rau +// +// Permission is hereby granted, free of charge, to any person obtaining a copy +// of this software and associated documentation files (the "Software"), to deal +// in the Software without restriction, including without limitation the rights +// to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +// copies of the Software, and to permit persons to whom the Software is +// furnished to do so, subject to the following conditions: +// +// The above copyright notice and this permission notice shall be included in +// all copies or substantial portions of the Software. +// +// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +// IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +// FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +// AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +// LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +// OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +// THE SOFTWARE. + +#ifndef __OPENCL_VERSION__ +#define __constant +#endif + +__constant static const uint16_t base_table[512] = { + 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0001, 0x0002, 0x0004, 0x0008, 0x0010, 0x0020, 0x0040, 0x0080, 0x0100, + 0x0200, 0x0400, 0x0800, 0x0C00, 0x1000, 0x1400, 0x1800, 0x1C00, 0x2000, 0x2400, 0x2800, 0x2C00, 0x3000, 0x3400, 0x3800, 0x3C00, + 0x4000, 0x4400, 0x4800, 0x4C00, 0x5000, 0x5400, 0x5800, 0x5C00, 0x6000, 0x6400, 0x6800, 0x6C00, 0x7000, 0x7400, 0x7800, 0x7C00, + 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, + 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, + 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, + 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, + 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, + 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, + 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, + 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, + 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, + 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, + 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, + 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, + 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, + 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8001, 0x8002, 0x8004, 0x8008, 0x8010, 0x8020, 0x8040, 0x8080, 0x8100, + 0x8200, 0x8400, 0x8800, 0x8C00, 0x9000, 0x9400, 0x9800, 0x9C00, 0xA000, 0xA400, 0xA800, 0xAC00, 0xB000, 0xB400, 0xB800, 0xBC00, + 0xC000, 0xC400, 0xC800, 0xCC00, 0xD000, 0xD400, 0xD800, 0xDC00, 0xE000, 0xE400, 0xE800, 0xEC00, 0xF000, 0xF400, 0xF800, 0xFC00, + 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, + 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, + 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, + 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, + 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, + 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, + 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00 }; + +__constant static const unsigned char shift_table[512] = { + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 23, 22, 21, 20, 19, 18, 17, 16, 15, 14, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 13, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 23, 22, 21, 20, 19, 18, 17, 16, 15, 14, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 13 }; + +__constant static const uint32_t mantissa_table[2048] = { + 0x00000000, 0x33800000, 0x34000000, 0x34400000, 0x34800000, 0x34A00000, 0x34C00000, 0x34E00000, 0x35000000, 0x35100000, 0x35200000, 0x35300000, 0x35400000, 0x35500000, 0x35600000, 0x35700000, + 0x35800000, 0x35880000, 0x35900000, 0x35980000, 0x35A00000, 0x35A80000, 0x35B00000, 0x35B80000, 0x35C00000, 0x35C80000, 0x35D00000, 0x35D80000, 0x35E00000, 0x35E80000, 0x35F00000, 0x35F80000, + 0x36000000, 0x36040000, 0x36080000, 0x360C0000, 0x36100000, 0x36140000, 0x36180000, 0x361C0000, 0x36200000, 0x36240000, 0x36280000, 0x362C0000, 0x36300000, 0x36340000, 0x36380000, 0x363C0000, + 0x36400000, 0x36440000, 0x36480000, 0x364C0000, 0x36500000, 0x36540000, 0x36580000, 0x365C0000, 0x36600000, 0x36640000, 0x36680000, 0x366C0000, 0x36700000, 0x36740000, 0x36780000, 0x367C0000, + 0x36800000, 0x36820000, 0x36840000, 0x36860000, 0x36880000, 0x368A0000, 0x368C0000, 0x368E0000, 0x36900000, 0x36920000, 0x36940000, 0x36960000, 0x36980000, 0x369A0000, 0x369C0000, 0x369E0000, + 0x36A00000, 0x36A20000, 0x36A40000, 0x36A60000, 0x36A80000, 0x36AA0000, 0x36AC0000, 0x36AE0000, 0x36B00000, 0x36B20000, 0x36B40000, 0x36B60000, 0x36B80000, 0x36BA0000, 0x36BC0000, 0x36BE0000, + 0x36C00000, 0x36C20000, 0x36C40000, 0x36C60000, 0x36C80000, 0x36CA0000, 0x36CC0000, 0x36CE0000, 0x36D00000, 0x36D20000, 0x36D40000, 0x36D60000, 0x36D80000, 0x36DA0000, 0x36DC0000, 0x36DE0000, + 0x36E00000, 0x36E20000, 0x36E40000, 0x36E60000, 0x36E80000, 0x36EA0000, 0x36EC0000, 0x36EE0000, 0x36F00000, 0x36F20000, 0x36F40000, 0x36F60000, 0x36F80000, 0x36FA0000, 0x36FC0000, 0x36FE0000, + 0x37000000, 0x37010000, 0x37020000, 0x37030000, 0x37040000, 0x37050000, 0x37060000, 0x37070000, 0x37080000, 0x37090000, 0x370A0000, 0x370B0000, 0x370C0000, 0x370D0000, 0x370E0000, 0x370F0000, + 0x37100000, 0x37110000, 0x37120000, 0x37130000, 0x37140000, 0x37150000, 0x37160000, 0x37170000, 0x37180000, 0x37190000, 0x371A0000, 0x371B0000, 0x371C0000, 0x371D0000, 0x371E0000, 0x371F0000, + 0x37200000, 0x37210000, 0x37220000, 0x37230000, 0x37240000, 0x37250000, 0x37260000, 0x37270000, 0x37280000, 0x37290000, 0x372A0000, 0x372B0000, 0x372C0000, 0x372D0000, 0x372E0000, 0x372F0000, + 0x37300000, 0x37310000, 0x37320000, 0x37330000, 0x37340000, 0x37350000, 0x37360000, 0x37370000, 0x37380000, 0x37390000, 0x373A0000, 0x373B0000, 0x373C0000, 0x373D0000, 0x373E0000, 0x373F0000, + 0x37400000, 0x37410000, 0x37420000, 0x37430000, 0x37440000, 0x37450000, 0x37460000, 0x37470000, 0x37480000, 0x37490000, 0x374A0000, 0x374B0000, 0x374C0000, 0x374D0000, 0x374E0000, 0x374F0000, + 0x37500000, 0x37510000, 0x37520000, 0x37530000, 0x37540000, 0x37550000, 0x37560000, 0x37570000, 0x37580000, 0x37590000, 0x375A0000, 0x375B0000, 0x375C0000, 0x375D0000, 0x375E0000, 0x375F0000, + 0x37600000, 0x37610000, 0x37620000, 0x37630000, 0x37640000, 0x37650000, 0x37660000, 0x37670000, 0x37680000, 0x37690000, 0x376A0000, 0x376B0000, 0x376C0000, 0x376D0000, 0x376E0000, 0x376F0000, + 0x37700000, 0x37710000, 0x37720000, 0x37730000, 0x37740000, 0x37750000, 0x37760000, 0x37770000, 0x37780000, 0x37790000, 0x377A0000, 0x377B0000, 0x377C0000, 0x377D0000, 0x377E0000, 0x377F0000, + 0x37800000, 0x37808000, 0x37810000, 0x37818000, 0x37820000, 0x37828000, 0x37830000, 0x37838000, 0x37840000, 0x37848000, 0x37850000, 0x37858000, 0x37860000, 0x37868000, 0x37870000, 0x37878000, + 0x37880000, 0x37888000, 0x37890000, 0x37898000, 0x378A0000, 0x378A8000, 0x378B0000, 0x378B8000, 0x378C0000, 0x378C8000, 0x378D0000, 0x378D8000, 0x378E0000, 0x378E8000, 0x378F0000, 0x378F8000, + 0x37900000, 0x37908000, 0x37910000, 0x37918000, 0x37920000, 0x37928000, 0x37930000, 0x37938000, 0x37940000, 0x37948000, 0x37950000, 0x37958000, 0x37960000, 0x37968000, 0x37970000, 0x37978000, + 0x37980000, 0x37988000, 0x37990000, 0x37998000, 0x379A0000, 0x379A8000, 0x379B0000, 0x379B8000, 0x379C0000, 0x379C8000, 0x379D0000, 0x379D8000, 0x379E0000, 0x379E8000, 0x379F0000, 0x379F8000, + 0x37A00000, 0x37A08000, 0x37A10000, 0x37A18000, 0x37A20000, 0x37A28000, 0x37A30000, 0x37A38000, 0x37A40000, 0x37A48000, 0x37A50000, 0x37A58000, 0x37A60000, 0x37A68000, 0x37A70000, 0x37A78000, + 0x37A80000, 0x37A88000, 0x37A90000, 0x37A98000, 0x37AA0000, 0x37AA8000, 0x37AB0000, 0x37AB8000, 0x37AC0000, 0x37AC8000, 0x37AD0000, 0x37AD8000, 0x37AE0000, 0x37AE8000, 0x37AF0000, 0x37AF8000, + 0x37B00000, 0x37B08000, 0x37B10000, 0x37B18000, 0x37B20000, 0x37B28000, 0x37B30000, 0x37B38000, 0x37B40000, 0x37B48000, 0x37B50000, 0x37B58000, 0x37B60000, 0x37B68000, 0x37B70000, 0x37B78000, + 0x37B80000, 0x37B88000, 0x37B90000, 0x37B98000, 0x37BA0000, 0x37BA8000, 0x37BB0000, 0x37BB8000, 0x37BC0000, 0x37BC8000, 0x37BD0000, 0x37BD8000, 0x37BE0000, 0x37BE8000, 0x37BF0000, 0x37BF8000, + 0x37C00000, 0x37C08000, 0x37C10000, 0x37C18000, 0x37C20000, 0x37C28000, 0x37C30000, 0x37C38000, 0x37C40000, 0x37C48000, 0x37C50000, 0x37C58000, 0x37C60000, 0x37C68000, 0x37C70000, 0x37C78000, + 0x37C80000, 0x37C88000, 0x37C90000, 0x37C98000, 0x37CA0000, 0x37CA8000, 0x37CB0000, 0x37CB8000, 0x37CC0000, 0x37CC8000, 0x37CD0000, 0x37CD8000, 0x37CE0000, 0x37CE8000, 0x37CF0000, 0x37CF8000, + 0x37D00000, 0x37D08000, 0x37D10000, 0x37D18000, 0x37D20000, 0x37D28000, 0x37D30000, 0x37D38000, 0x37D40000, 0x37D48000, 0x37D50000, 0x37D58000, 0x37D60000, 0x37D68000, 0x37D70000, 0x37D78000, + 0x37D80000, 0x37D88000, 0x37D90000, 0x37D98000, 0x37DA0000, 0x37DA8000, 0x37DB0000, 0x37DB8000, 0x37DC0000, 0x37DC8000, 0x37DD0000, 0x37DD8000, 0x37DE0000, 0x37DE8000, 0x37DF0000, 0x37DF8000, + 0x37E00000, 0x37E08000, 0x37E10000, 0x37E18000, 0x37E20000, 0x37E28000, 0x37E30000, 0x37E38000, 0x37E40000, 0x37E48000, 0x37E50000, 0x37E58000, 0x37E60000, 0x37E68000, 0x37E70000, 0x37E78000, + 0x37E80000, 0x37E88000, 0x37E90000, 0x37E98000, 0x37EA0000, 0x37EA8000, 0x37EB0000, 0x37EB8000, 0x37EC0000, 0x37EC8000, 0x37ED0000, 0x37ED8000, 0x37EE0000, 0x37EE8000, 0x37EF0000, 0x37EF8000, + 0x37F00000, 0x37F08000, 0x37F10000, 0x37F18000, 0x37F20000, 0x37F28000, 0x37F30000, 0x37F38000, 0x37F40000, 0x37F48000, 0x37F50000, 0x37F58000, 0x37F60000, 0x37F68000, 0x37F70000, 0x37F78000, + 0x37F80000, 0x37F88000, 0x37F90000, 0x37F98000, 0x37FA0000, 0x37FA8000, 0x37FB0000, 0x37FB8000, 0x37FC0000, 0x37FC8000, 0x37FD0000, 0x37FD8000, 0x37FE0000, 0x37FE8000, 0x37FF0000, 0x37FF8000, + 0x38000000, 0x38004000, 0x38008000, 0x3800C000, 0x38010000, 0x38014000, 0x38018000, 0x3801C000, 0x38020000, 0x38024000, 0x38028000, 0x3802C000, 0x38030000, 0x38034000, 0x38038000, 0x3803C000, + 0x38040000, 0x38044000, 0x38048000, 0x3804C000, 0x38050000, 0x38054000, 0x38058000, 0x3805C000, 0x38060000, 0x38064000, 0x38068000, 0x3806C000, 0x38070000, 0x38074000, 0x38078000, 0x3807C000, + 0x38080000, 0x38084000, 0x38088000, 0x3808C000, 0x38090000, 0x38094000, 0x38098000, 0x3809C000, 0x380A0000, 0x380A4000, 0x380A8000, 0x380AC000, 0x380B0000, 0x380B4000, 0x380B8000, 0x380BC000, + 0x380C0000, 0x380C4000, 0x380C8000, 0x380CC000, 0x380D0000, 0x380D4000, 0x380D8000, 0x380DC000, 0x380E0000, 0x380E4000, 0x380E8000, 0x380EC000, 0x380F0000, 0x380F4000, 0x380F8000, 0x380FC000, + 0x38100000, 0x38104000, 0x38108000, 0x3810C000, 0x38110000, 0x38114000, 0x38118000, 0x3811C000, 0x38120000, 0x38124000, 0x38128000, 0x3812C000, 0x38130000, 0x38134000, 0x38138000, 0x3813C000, + 0x38140000, 0x38144000, 0x38148000, 0x3814C000, 0x38150000, 0x38154000, 0x38158000, 0x3815C000, 0x38160000, 0x38164000, 0x38168000, 0x3816C000, 0x38170000, 0x38174000, 0x38178000, 0x3817C000, + 0x38180000, 0x38184000, 0x38188000, 0x3818C000, 0x38190000, 0x38194000, 0x38198000, 0x3819C000, 0x381A0000, 0x381A4000, 0x381A8000, 0x381AC000, 0x381B0000, 0x381B4000, 0x381B8000, 0x381BC000, + 0x381C0000, 0x381C4000, 0x381C8000, 0x381CC000, 0x381D0000, 0x381D4000, 0x381D8000, 0x381DC000, 0x381E0000, 0x381E4000, 0x381E8000, 0x381EC000, 0x381F0000, 0x381F4000, 0x381F8000, 0x381FC000, + 0x38200000, 0x38204000, 0x38208000, 0x3820C000, 0x38210000, 0x38214000, 0x38218000, 0x3821C000, 0x38220000, 0x38224000, 0x38228000, 0x3822C000, 0x38230000, 0x38234000, 0x38238000, 0x3823C000, + 0x38240000, 0x38244000, 0x38248000, 0x3824C000, 0x38250000, 0x38254000, 0x38258000, 0x3825C000, 0x38260000, 0x38264000, 0x38268000, 0x3826C000, 0x38270000, 0x38274000, 0x38278000, 0x3827C000, + 0x38280000, 0x38284000, 0x38288000, 0x3828C000, 0x38290000, 0x38294000, 0x38298000, 0x3829C000, 0x382A0000, 0x382A4000, 0x382A8000, 0x382AC000, 0x382B0000, 0x382B4000, 0x382B8000, 0x382BC000, + 0x382C0000, 0x382C4000, 0x382C8000, 0x382CC000, 0x382D0000, 0x382D4000, 0x382D8000, 0x382DC000, 0x382E0000, 0x382E4000, 0x382E8000, 0x382EC000, 0x382F0000, 0x382F4000, 0x382F8000, 0x382FC000, + 0x38300000, 0x38304000, 0x38308000, 0x3830C000, 0x38310000, 0x38314000, 0x38318000, 0x3831C000, 0x38320000, 0x38324000, 0x38328000, 0x3832C000, 0x38330000, 0x38334000, 0x38338000, 0x3833C000, + 0x38340000, 0x38344000, 0x38348000, 0x3834C000, 0x38350000, 0x38354000, 0x38358000, 0x3835C000, 0x38360000, 0x38364000, 0x38368000, 0x3836C000, 0x38370000, 0x38374000, 0x38378000, 0x3837C000, + 0x38380000, 0x38384000, 0x38388000, 0x3838C000, 0x38390000, 0x38394000, 0x38398000, 0x3839C000, 0x383A0000, 0x383A4000, 0x383A8000, 0x383AC000, 0x383B0000, 0x383B4000, 0x383B8000, 0x383BC000, + 0x383C0000, 0x383C4000, 0x383C8000, 0x383CC000, 0x383D0000, 0x383D4000, 0x383D8000, 0x383DC000, 0x383E0000, 0x383E4000, 0x383E8000, 0x383EC000, 0x383F0000, 0x383F4000, 0x383F8000, 0x383FC000, + 0x38400000, 0x38404000, 0x38408000, 0x3840C000, 0x38410000, 0x38414000, 0x38418000, 0x3841C000, 0x38420000, 0x38424000, 0x38428000, 0x3842C000, 0x38430000, 0x38434000, 0x38438000, 0x3843C000, + 0x38440000, 0x38444000, 0x38448000, 0x3844C000, 0x38450000, 0x38454000, 0x38458000, 0x3845C000, 0x38460000, 0x38464000, 0x38468000, 0x3846C000, 0x38470000, 0x38474000, 0x38478000, 0x3847C000, + 0x38480000, 0x38484000, 0x38488000, 0x3848C000, 0x38490000, 0x38494000, 0x38498000, 0x3849C000, 0x384A0000, 0x384A4000, 0x384A8000, 0x384AC000, 0x384B0000, 0x384B4000, 0x384B8000, 0x384BC000, + 0x384C0000, 0x384C4000, 0x384C8000, 0x384CC000, 0x384D0000, 0x384D4000, 0x384D8000, 0x384DC000, 0x384E0000, 0x384E4000, 0x384E8000, 0x384EC000, 0x384F0000, 0x384F4000, 0x384F8000, 0x384FC000, + 0x38500000, 0x38504000, 0x38508000, 0x3850C000, 0x38510000, 0x38514000, 0x38518000, 0x3851C000, 0x38520000, 0x38524000, 0x38528000, 0x3852C000, 0x38530000, 0x38534000, 0x38538000, 0x3853C000, + 0x38540000, 0x38544000, 0x38548000, 0x3854C000, 0x38550000, 0x38554000, 0x38558000, 0x3855C000, 0x38560000, 0x38564000, 0x38568000, 0x3856C000, 0x38570000, 0x38574000, 0x38578000, 0x3857C000, + 0x38580000, 0x38584000, 0x38588000, 0x3858C000, 0x38590000, 0x38594000, 0x38598000, 0x3859C000, 0x385A0000, 0x385A4000, 0x385A8000, 0x385AC000, 0x385B0000, 0x385B4000, 0x385B8000, 0x385BC000, + 0x385C0000, 0x385C4000, 0x385C8000, 0x385CC000, 0x385D0000, 0x385D4000, 0x385D8000, 0x385DC000, 0x385E0000, 0x385E4000, 0x385E8000, 0x385EC000, 0x385F0000, 0x385F4000, 0x385F8000, 0x385FC000, + 0x38600000, 0x38604000, 0x38608000, 0x3860C000, 0x38610000, 0x38614000, 0x38618000, 0x3861C000, 0x38620000, 0x38624000, 0x38628000, 0x3862C000, 0x38630000, 0x38634000, 0x38638000, 0x3863C000, + 0x38640000, 0x38644000, 0x38648000, 0x3864C000, 0x38650000, 0x38654000, 0x38658000, 0x3865C000, 0x38660000, 0x38664000, 0x38668000, 0x3866C000, 0x38670000, 0x38674000, 0x38678000, 0x3867C000, + 0x38680000, 0x38684000, 0x38688000, 0x3868C000, 0x38690000, 0x38694000, 0x38698000, 0x3869C000, 0x386A0000, 0x386A4000, 0x386A8000, 0x386AC000, 0x386B0000, 0x386B4000, 0x386B8000, 0x386BC000, + 0x386C0000, 0x386C4000, 0x386C8000, 0x386CC000, 0x386D0000, 0x386D4000, 0x386D8000, 0x386DC000, 0x386E0000, 0x386E4000, 0x386E8000, 0x386EC000, 0x386F0000, 0x386F4000, 0x386F8000, 0x386FC000, + 0x38700000, 0x38704000, 0x38708000, 0x3870C000, 0x38710000, 0x38714000, 0x38718000, 0x3871C000, 0x38720000, 0x38724000, 0x38728000, 0x3872C000, 0x38730000, 0x38734000, 0x38738000, 0x3873C000, + 0x38740000, 0x38744000, 0x38748000, 0x3874C000, 0x38750000, 0x38754000, 0x38758000, 0x3875C000, 0x38760000, 0x38764000, 0x38768000, 0x3876C000, 0x38770000, 0x38774000, 0x38778000, 0x3877C000, + 0x38780000, 0x38784000, 0x38788000, 0x3878C000, 0x38790000, 0x38794000, 0x38798000, 0x3879C000, 0x387A0000, 0x387A4000, 0x387A8000, 0x387AC000, 0x387B0000, 0x387B4000, 0x387B8000, 0x387BC000, + 0x387C0000, 0x387C4000, 0x387C8000, 0x387CC000, 0x387D0000, 0x387D4000, 0x387D8000, 0x387DC000, 0x387E0000, 0x387E4000, 0x387E8000, 0x387EC000, 0x387F0000, 0x387F4000, 0x387F8000, 0x387FC000, + 0x38000000, 0x38002000, 0x38004000, 0x38006000, 0x38008000, 0x3800A000, 0x3800C000, 0x3800E000, 0x38010000, 0x38012000, 0x38014000, 0x38016000, 0x38018000, 0x3801A000, 0x3801C000, 0x3801E000, + 0x38020000, 0x38022000, 0x38024000, 0x38026000, 0x38028000, 0x3802A000, 0x3802C000, 0x3802E000, 0x38030000, 0x38032000, 0x38034000, 0x38036000, 0x38038000, 0x3803A000, 0x3803C000, 0x3803E000, + 0x38040000, 0x38042000, 0x38044000, 0x38046000, 0x38048000, 0x3804A000, 0x3804C000, 0x3804E000, 0x38050000, 0x38052000, 0x38054000, 0x38056000, 0x38058000, 0x3805A000, 0x3805C000, 0x3805E000, + 0x38060000, 0x38062000, 0x38064000, 0x38066000, 0x38068000, 0x3806A000, 0x3806C000, 0x3806E000, 0x38070000, 0x38072000, 0x38074000, 0x38076000, 0x38078000, 0x3807A000, 0x3807C000, 0x3807E000, + 0x38080000, 0x38082000, 0x38084000, 0x38086000, 0x38088000, 0x3808A000, 0x3808C000, 0x3808E000, 0x38090000, 0x38092000, 0x38094000, 0x38096000, 0x38098000, 0x3809A000, 0x3809C000, 0x3809E000, + 0x380A0000, 0x380A2000, 0x380A4000, 0x380A6000, 0x380A8000, 0x380AA000, 0x380AC000, 0x380AE000, 0x380B0000, 0x380B2000, 0x380B4000, 0x380B6000, 0x380B8000, 0x380BA000, 0x380BC000, 0x380BE000, + 0x380C0000, 0x380C2000, 0x380C4000, 0x380C6000, 0x380C8000, 0x380CA000, 0x380CC000, 0x380CE000, 0x380D0000, 0x380D2000, 0x380D4000, 0x380D6000, 0x380D8000, 0x380DA000, 0x380DC000, 0x380DE000, + 0x380E0000, 0x380E2000, 0x380E4000, 0x380E6000, 0x380E8000, 0x380EA000, 0x380EC000, 0x380EE000, 0x380F0000, 0x380F2000, 0x380F4000, 0x380F6000, 0x380F8000, 0x380FA000, 0x380FC000, 0x380FE000, + 0x38100000, 0x38102000, 0x38104000, 0x38106000, 0x38108000, 0x3810A000, 0x3810C000, 0x3810E000, 0x38110000, 0x38112000, 0x38114000, 0x38116000, 0x38118000, 0x3811A000, 0x3811C000, 0x3811E000, + 0x38120000, 0x38122000, 0x38124000, 0x38126000, 0x38128000, 0x3812A000, 0x3812C000, 0x3812E000, 0x38130000, 0x38132000, 0x38134000, 0x38136000, 0x38138000, 0x3813A000, 0x3813C000, 0x3813E000, + 0x38140000, 0x38142000, 0x38144000, 0x38146000, 0x38148000, 0x3814A000, 0x3814C000, 0x3814E000, 0x38150000, 0x38152000, 0x38154000, 0x38156000, 0x38158000, 0x3815A000, 0x3815C000, 0x3815E000, + 0x38160000, 0x38162000, 0x38164000, 0x38166000, 0x38168000, 0x3816A000, 0x3816C000, 0x3816E000, 0x38170000, 0x38172000, 0x38174000, 0x38176000, 0x38178000, 0x3817A000, 0x3817C000, 0x3817E000, + 0x38180000, 0x38182000, 0x38184000, 0x38186000, 0x38188000, 0x3818A000, 0x3818C000, 0x3818E000, 0x38190000, 0x38192000, 0x38194000, 0x38196000, 0x38198000, 0x3819A000, 0x3819C000, 0x3819E000, + 0x381A0000, 0x381A2000, 0x381A4000, 0x381A6000, 0x381A8000, 0x381AA000, 0x381AC000, 0x381AE000, 0x381B0000, 0x381B2000, 0x381B4000, 0x381B6000, 0x381B8000, 0x381BA000, 0x381BC000, 0x381BE000, + 0x381C0000, 0x381C2000, 0x381C4000, 0x381C6000, 0x381C8000, 0x381CA000, 0x381CC000, 0x381CE000, 0x381D0000, 0x381D2000, 0x381D4000, 0x381D6000, 0x381D8000, 0x381DA000, 0x381DC000, 0x381DE000, + 0x381E0000, 0x381E2000, 0x381E4000, 0x381E6000, 0x381E8000, 0x381EA000, 0x381EC000, 0x381EE000, 0x381F0000, 0x381F2000, 0x381F4000, 0x381F6000, 0x381F8000, 0x381FA000, 0x381FC000, 0x381FE000, + 0x38200000, 0x38202000, 0x38204000, 0x38206000, 0x38208000, 0x3820A000, 0x3820C000, 0x3820E000, 0x38210000, 0x38212000, 0x38214000, 0x38216000, 0x38218000, 0x3821A000, 0x3821C000, 0x3821E000, + 0x38220000, 0x38222000, 0x38224000, 0x38226000, 0x38228000, 0x3822A000, 0x3822C000, 0x3822E000, 0x38230000, 0x38232000, 0x38234000, 0x38236000, 0x38238000, 0x3823A000, 0x3823C000, 0x3823E000, + 0x38240000, 0x38242000, 0x38244000, 0x38246000, 0x38248000, 0x3824A000, 0x3824C000, 0x3824E000, 0x38250000, 0x38252000, 0x38254000, 0x38256000, 0x38258000, 0x3825A000, 0x3825C000, 0x3825E000, + 0x38260000, 0x38262000, 0x38264000, 0x38266000, 0x38268000, 0x3826A000, 0x3826C000, 0x3826E000, 0x38270000, 0x38272000, 0x38274000, 0x38276000, 0x38278000, 0x3827A000, 0x3827C000, 0x3827E000, + 0x38280000, 0x38282000, 0x38284000, 0x38286000, 0x38288000, 0x3828A000, 0x3828C000, 0x3828E000, 0x38290000, 0x38292000, 0x38294000, 0x38296000, 0x38298000, 0x3829A000, 0x3829C000, 0x3829E000, + 0x382A0000, 0x382A2000, 0x382A4000, 0x382A6000, 0x382A8000, 0x382AA000, 0x382AC000, 0x382AE000, 0x382B0000, 0x382B2000, 0x382B4000, 0x382B6000, 0x382B8000, 0x382BA000, 0x382BC000, 0x382BE000, + 0x382C0000, 0x382C2000, 0x382C4000, 0x382C6000, 0x382C8000, 0x382CA000, 0x382CC000, 0x382CE000, 0x382D0000, 0x382D2000, 0x382D4000, 0x382D6000, 0x382D8000, 0x382DA000, 0x382DC000, 0x382DE000, + 0x382E0000, 0x382E2000, 0x382E4000, 0x382E6000, 0x382E8000, 0x382EA000, 0x382EC000, 0x382EE000, 0x382F0000, 0x382F2000, 0x382F4000, 0x382F6000, 0x382F8000, 0x382FA000, 0x382FC000, 0x382FE000, + 0x38300000, 0x38302000, 0x38304000, 0x38306000, 0x38308000, 0x3830A000, 0x3830C000, 0x3830E000, 0x38310000, 0x38312000, 0x38314000, 0x38316000, 0x38318000, 0x3831A000, 0x3831C000, 0x3831E000, + 0x38320000, 0x38322000, 0x38324000, 0x38326000, 0x38328000, 0x3832A000, 0x3832C000, 0x3832E000, 0x38330000, 0x38332000, 0x38334000, 0x38336000, 0x38338000, 0x3833A000, 0x3833C000, 0x3833E000, + 0x38340000, 0x38342000, 0x38344000, 0x38346000, 0x38348000, 0x3834A000, 0x3834C000, 0x3834E000, 0x38350000, 0x38352000, 0x38354000, 0x38356000, 0x38358000, 0x3835A000, 0x3835C000, 0x3835E000, + 0x38360000, 0x38362000, 0x38364000, 0x38366000, 0x38368000, 0x3836A000, 0x3836C000, 0x3836E000, 0x38370000, 0x38372000, 0x38374000, 0x38376000, 0x38378000, 0x3837A000, 0x3837C000, 0x3837E000, + 0x38380000, 0x38382000, 0x38384000, 0x38386000, 0x38388000, 0x3838A000, 0x3838C000, 0x3838E000, 0x38390000, 0x38392000, 0x38394000, 0x38396000, 0x38398000, 0x3839A000, 0x3839C000, 0x3839E000, + 0x383A0000, 0x383A2000, 0x383A4000, 0x383A6000, 0x383A8000, 0x383AA000, 0x383AC000, 0x383AE000, 0x383B0000, 0x383B2000, 0x383B4000, 0x383B6000, 0x383B8000, 0x383BA000, 0x383BC000, 0x383BE000, + 0x383C0000, 0x383C2000, 0x383C4000, 0x383C6000, 0x383C8000, 0x383CA000, 0x383CC000, 0x383CE000, 0x383D0000, 0x383D2000, 0x383D4000, 0x383D6000, 0x383D8000, 0x383DA000, 0x383DC000, 0x383DE000, + 0x383E0000, 0x383E2000, 0x383E4000, 0x383E6000, 0x383E8000, 0x383EA000, 0x383EC000, 0x383EE000, 0x383F0000, 0x383F2000, 0x383F4000, 0x383F6000, 0x383F8000, 0x383FA000, 0x383FC000, 0x383FE000, + 0x38400000, 0x38402000, 0x38404000, 0x38406000, 0x38408000, 0x3840A000, 0x3840C000, 0x3840E000, 0x38410000, 0x38412000, 0x38414000, 0x38416000, 0x38418000, 0x3841A000, 0x3841C000, 0x3841E000, + 0x38420000, 0x38422000, 0x38424000, 0x38426000, 0x38428000, 0x3842A000, 0x3842C000, 0x3842E000, 0x38430000, 0x38432000, 0x38434000, 0x38436000, 0x38438000, 0x3843A000, 0x3843C000, 0x3843E000, + 0x38440000, 0x38442000, 0x38444000, 0x38446000, 0x38448000, 0x3844A000, 0x3844C000, 0x3844E000, 0x38450000, 0x38452000, 0x38454000, 0x38456000, 0x38458000, 0x3845A000, 0x3845C000, 0x3845E000, + 0x38460000, 0x38462000, 0x38464000, 0x38466000, 0x38468000, 0x3846A000, 0x3846C000, 0x3846E000, 0x38470000, 0x38472000, 0x38474000, 0x38476000, 0x38478000, 0x3847A000, 0x3847C000, 0x3847E000, + 0x38480000, 0x38482000, 0x38484000, 0x38486000, 0x38488000, 0x3848A000, 0x3848C000, 0x3848E000, 0x38490000, 0x38492000, 0x38494000, 0x38496000, 0x38498000, 0x3849A000, 0x3849C000, 0x3849E000, + 0x384A0000, 0x384A2000, 0x384A4000, 0x384A6000, 0x384A8000, 0x384AA000, 0x384AC000, 0x384AE000, 0x384B0000, 0x384B2000, 0x384B4000, 0x384B6000, 0x384B8000, 0x384BA000, 0x384BC000, 0x384BE000, + 0x384C0000, 0x384C2000, 0x384C4000, 0x384C6000, 0x384C8000, 0x384CA000, 0x384CC000, 0x384CE000, 0x384D0000, 0x384D2000, 0x384D4000, 0x384D6000, 0x384D8000, 0x384DA000, 0x384DC000, 0x384DE000, + 0x384E0000, 0x384E2000, 0x384E4000, 0x384E6000, 0x384E8000, 0x384EA000, 0x384EC000, 0x384EE000, 0x384F0000, 0x384F2000, 0x384F4000, 0x384F6000, 0x384F8000, 0x384FA000, 0x384FC000, 0x384FE000, + 0x38500000, 0x38502000, 0x38504000, 0x38506000, 0x38508000, 0x3850A000, 0x3850C000, 0x3850E000, 0x38510000, 0x38512000, 0x38514000, 0x38516000, 0x38518000, 0x3851A000, 0x3851C000, 0x3851E000, + 0x38520000, 0x38522000, 0x38524000, 0x38526000, 0x38528000, 0x3852A000, 0x3852C000, 0x3852E000, 0x38530000, 0x38532000, 0x38534000, 0x38536000, 0x38538000, 0x3853A000, 0x3853C000, 0x3853E000, + 0x38540000, 0x38542000, 0x38544000, 0x38546000, 0x38548000, 0x3854A000, 0x3854C000, 0x3854E000, 0x38550000, 0x38552000, 0x38554000, 0x38556000, 0x38558000, 0x3855A000, 0x3855C000, 0x3855E000, + 0x38560000, 0x38562000, 0x38564000, 0x38566000, 0x38568000, 0x3856A000, 0x3856C000, 0x3856E000, 0x38570000, 0x38572000, 0x38574000, 0x38576000, 0x38578000, 0x3857A000, 0x3857C000, 0x3857E000, + 0x38580000, 0x38582000, 0x38584000, 0x38586000, 0x38588000, 0x3858A000, 0x3858C000, 0x3858E000, 0x38590000, 0x38592000, 0x38594000, 0x38596000, 0x38598000, 0x3859A000, 0x3859C000, 0x3859E000, + 0x385A0000, 0x385A2000, 0x385A4000, 0x385A6000, 0x385A8000, 0x385AA000, 0x385AC000, 0x385AE000, 0x385B0000, 0x385B2000, 0x385B4000, 0x385B6000, 0x385B8000, 0x385BA000, 0x385BC000, 0x385BE000, + 0x385C0000, 0x385C2000, 0x385C4000, 0x385C6000, 0x385C8000, 0x385CA000, 0x385CC000, 0x385CE000, 0x385D0000, 0x385D2000, 0x385D4000, 0x385D6000, 0x385D8000, 0x385DA000, 0x385DC000, 0x385DE000, + 0x385E0000, 0x385E2000, 0x385E4000, 0x385E6000, 0x385E8000, 0x385EA000, 0x385EC000, 0x385EE000, 0x385F0000, 0x385F2000, 0x385F4000, 0x385F6000, 0x385F8000, 0x385FA000, 0x385FC000, 0x385FE000, + 0x38600000, 0x38602000, 0x38604000, 0x38606000, 0x38608000, 0x3860A000, 0x3860C000, 0x3860E000, 0x38610000, 0x38612000, 0x38614000, 0x38616000, 0x38618000, 0x3861A000, 0x3861C000, 0x3861E000, + 0x38620000, 0x38622000, 0x38624000, 0x38626000, 0x38628000, 0x3862A000, 0x3862C000, 0x3862E000, 0x38630000, 0x38632000, 0x38634000, 0x38636000, 0x38638000, 0x3863A000, 0x3863C000, 0x3863E000, + 0x38640000, 0x38642000, 0x38644000, 0x38646000, 0x38648000, 0x3864A000, 0x3864C000, 0x3864E000, 0x38650000, 0x38652000, 0x38654000, 0x38656000, 0x38658000, 0x3865A000, 0x3865C000, 0x3865E000, + 0x38660000, 0x38662000, 0x38664000, 0x38666000, 0x38668000, 0x3866A000, 0x3866C000, 0x3866E000, 0x38670000, 0x38672000, 0x38674000, 0x38676000, 0x38678000, 0x3867A000, 0x3867C000, 0x3867E000, + 0x38680000, 0x38682000, 0x38684000, 0x38686000, 0x38688000, 0x3868A000, 0x3868C000, 0x3868E000, 0x38690000, 0x38692000, 0x38694000, 0x38696000, 0x38698000, 0x3869A000, 0x3869C000, 0x3869E000, + 0x386A0000, 0x386A2000, 0x386A4000, 0x386A6000, 0x386A8000, 0x386AA000, 0x386AC000, 0x386AE000, 0x386B0000, 0x386B2000, 0x386B4000, 0x386B6000, 0x386B8000, 0x386BA000, 0x386BC000, 0x386BE000, + 0x386C0000, 0x386C2000, 0x386C4000, 0x386C6000, 0x386C8000, 0x386CA000, 0x386CC000, 0x386CE000, 0x386D0000, 0x386D2000, 0x386D4000, 0x386D6000, 0x386D8000, 0x386DA000, 0x386DC000, 0x386DE000, + 0x386E0000, 0x386E2000, 0x386E4000, 0x386E6000, 0x386E8000, 0x386EA000, 0x386EC000, 0x386EE000, 0x386F0000, 0x386F2000, 0x386F4000, 0x386F6000, 0x386F8000, 0x386FA000, 0x386FC000, 0x386FE000, + 0x38700000, 0x38702000, 0x38704000, 0x38706000, 0x38708000, 0x3870A000, 0x3870C000, 0x3870E000, 0x38710000, 0x38712000, 0x38714000, 0x38716000, 0x38718000, 0x3871A000, 0x3871C000, 0x3871E000, + 0x38720000, 0x38722000, 0x38724000, 0x38726000, 0x38728000, 0x3872A000, 0x3872C000, 0x3872E000, 0x38730000, 0x38732000, 0x38734000, 0x38736000, 0x38738000, 0x3873A000, 0x3873C000, 0x3873E000, + 0x38740000, 0x38742000, 0x38744000, 0x38746000, 0x38748000, 0x3874A000, 0x3874C000, 0x3874E000, 0x38750000, 0x38752000, 0x38754000, 0x38756000, 0x38758000, 0x3875A000, 0x3875C000, 0x3875E000, + 0x38760000, 0x38762000, 0x38764000, 0x38766000, 0x38768000, 0x3876A000, 0x3876C000, 0x3876E000, 0x38770000, 0x38772000, 0x38774000, 0x38776000, 0x38778000, 0x3877A000, 0x3877C000, 0x3877E000, + 0x38780000, 0x38782000, 0x38784000, 0x38786000, 0x38788000, 0x3878A000, 0x3878C000, 0x3878E000, 0x38790000, 0x38792000, 0x38794000, 0x38796000, 0x38798000, 0x3879A000, 0x3879C000, 0x3879E000, + 0x387A0000, 0x387A2000, 0x387A4000, 0x387A6000, 0x387A8000, 0x387AA000, 0x387AC000, 0x387AE000, 0x387B0000, 0x387B2000, 0x387B4000, 0x387B6000, 0x387B8000, 0x387BA000, 0x387BC000, 0x387BE000, + 0x387C0000, 0x387C2000, 0x387C4000, 0x387C6000, 0x387C8000, 0x387CA000, 0x387CC000, 0x387CE000, 0x387D0000, 0x387D2000, 0x387D4000, 0x387D6000, 0x387D8000, 0x387DA000, 0x387DC000, 0x387DE000, + 0x387E0000, 0x387E2000, 0x387E4000, 0x387E6000, 0x387E8000, 0x387EA000, 0x387EC000, 0x387EE000, 0x387F0000, 0x387F2000, 0x387F4000, 0x387F6000, 0x387F8000, 0x387FA000, 0x387FC000, 0x387FE000 }; +__constant static const uint32_t exponent_table[64] = { + 0x00000000, 0x00800000, 0x01000000, 0x01800000, 0x02000000, 0x02800000, 0x03000000, 0x03800000, 0x04000000, 0x04800000, 0x05000000, 0x05800000, 0x06000000, 0x06800000, 0x07000000, 0x07800000, + 0x08000000, 0x08800000, 0x09000000, 0x09800000, 0x0A000000, 0x0A800000, 0x0B000000, 0x0B800000, 0x0C000000, 0x0C800000, 0x0D000000, 0x0D800000, 0x0E000000, 0x0E800000, 0x0F000000, 0x47800000, + 0x80000000, 0x80800000, 0x81000000, 0x81800000, 0x82000000, 0x82800000, 0x83000000, 0x83800000, 0x84000000, 0x84800000, 0x85000000, 0x85800000, 0x86000000, 0x86800000, 0x87000000, 0x87800000, + 0x88000000, 0x88800000, 0x89000000, 0x89800000, 0x8A000000, 0x8A800000, 0x8B000000, 0x8B800000, 0x8C000000, 0x8C800000, 0x8D000000, 0x8D800000, 0x8E000000, 0x8E800000, 0x8F000000, 0xC7800000 }; +__constant static const unsigned short offset_table[64] = { + 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) { + union { float x; uint32_t y; } u; + u.x = value; + uint32_t bits = u.y; + + uint16_t hbits = base_table[bits>>23] + (uint16_t)((bits&0x7FFFFF)>>shift_table[bits>>23]);; + + return hbits; +} + +static 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; + u.x = bits; + return u.y; +} + +// End of half.h. diff --git a/rts/c/opencl.h b/rts/c/opencl.h --- a/rts/c/opencl.h +++ b/rts/c/opencl.h @@ -195,7 +195,7 @@ } } -static void opencl_succeed_fatal(unsigned int ret, +static void opencl_succeed_fatal(cl_int ret, const char *call, const char *file, int line) { @@ -205,7 +205,7 @@ } } -static char* opencl_succeed_nonfatal(unsigned int ret, +static char* opencl_succeed_nonfatal(cl_int ret, const char *call, const char *file, int line) { @@ -734,6 +734,12 @@ for (int i = 0; extra_build_opts[i] != NULL; i++) { w += snprintf(compile_opts+w, compile_opts_size-w, "%s ", extra_build_opts[i]); + } + + // Oclgrind claims to support cl_khr_fp16, but this is not actually + // the case. + if (strcmp(device_option.platform_name, "Oclgrind") == 0) { + w += snprintf(compile_opts+w, compile_opts_size-w, "-DEMULATE_F16 "); } if (ctx->cfg.debugging) { diff --git a/rts/c/scalar.h b/rts/c/scalar.h new file mode 100644 --- /dev/null +++ b/rts/c/scalar.h @@ -0,0 +1,1654 @@ +// Start of scalar.h. + +// Implementation of the primitive scalar operations. Very +// repetitive. This code is inserted directly into both CUDA and +// OpenCL programs, as well as the CPU code, so it has some #ifdefs to +// work everywhere. Some operations are defined as macros because +// this allows us to use them as constant expressions in things like +// array sizes and static initialisers. + +// Some of the #ifdefs are because OpenCL uses type-generic functions +// for some operations (e.g. sqrt), while C and CUDA sensibly use +// distinct functions for different precisions (e.g. sqrtf() and +// sqrt()). This is quite annoying. Due to C's unfortunate casting +// rules, it is also really easy to accidentally implement +// floating-point functions in the wrong precision, so be careful. + +// 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; +} + +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; +} + +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; +} + +static inline bool itob_i16_bool(int16_t x) { + return x; +} + +static inline bool itob_i32_bool(int32_t x) { + return x; +} + +static inline bool itob_i64_bool(int64_t x) { + return x; +} + +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__) + 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_mul_hi8(uint8_t a, uint8_t b) { + return mul_hi(a, b); +} + +static uint16_t futrts_mul_hi16(uint16_t a, uint16_t b) { + return mul_hi(a, b); +} + +static uint32_t futrts_mul_hi32(uint32_t a, uint32_t b) { + return mul_hi(a, b); +} + +static uint64_t futrts_mul_hi64(uint64_t a, uint64_t b) { + return mul_hi(a, b); +} + +#elif defined(__CUDA_ARCH__) + +static uint8_t futrts_mul_hi8(uint8_t a, uint8_t b) { + uint16_t aa = a; + uint16_t bb = b; + + return aa * bb >> 8; +} + +static uint16_t futrts_mul_hi16(uint16_t a, uint16_t b) { + uint32_t aa = a; + uint32_t bb = b; + + return aa * bb >> 16; +} + +static uint32_t futrts_mul_hi32(uint32_t a, uint32_t b) { + return mulhi(a, b); +} + +static uint64_t futrts_mul_hi64(uint64_t a, uint64_t b) { + return mul64hi(a, b); +} + +#else // Not OpenCL or CUDA, but plain C. + +static uint8_t futrts_mul_hi8(uint8_t a, uint8_t b) { + uint16_t aa = a; + uint16_t bb = b; + + return aa * bb >> 8; +} + +static uint16_t futrts_mul_hi16(uint16_t a, uint16_t b) { + uint32_t aa = a; + uint32_t bb = b; + + return aa * bb >> 16; +} + +static uint32_t futrts_mul_hi32(uint32_t a, uint32_t b) { + uint64_t aa = a; + uint64_t bb = b; + + return aa * bb >> 32; +} + +static uint64_t futrts_mul_hi64(uint64_t a, uint64_t b) { + __uint128_t aa = a; + __uint128_t bb = b; + + return aa * bb >> 64; +} +#endif + +#if defined(__OPENCL_VERSION__) +static uint8_t futrts_mad_hi8(uint8_t a, uint8_t b, uint8_t c) { + return mad_hi(a, b, c); +} + +static uint16_t futrts_mad_hi16(uint16_t a, uint16_t b, uint16_t c) { + return mad_hi(a, b, c); +} + +static uint32_t futrts_mad_hi32(uint32_t a, uint32_t b, uint32_t c) { + return mad_hi(a, b, c); +} + +static uint64_t futrts_mad_hi64(uint64_t a, uint64_t b, uint64_t c) { + return mad_hi(a, b, c); +} + +#else // Not OpenCL + +static uint8_t futrts_mad_hi8(uint8_t a, uint8_t b, uint8_t c) { + return futrts_mul_hi8(a, b) + c; +} + +static uint16_t futrts_mad_hi16(uint16_t a, uint16_t b, uint16_t c) { + return futrts_mul_hi16(a, b) + c; +} + +static uint32_t futrts_mad_hi32(uint32_t a, uint32_t b, uint32_t c) { + return futrts_mul_hi32(a, b) + c; +} + +static uint64_t futrts_mad_hi64(uint64_t a, uint64_t b, uint64_t c) { + return futrts_mul_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); +} + +#else // Not OpenCL 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; +} + +#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; +} + +static inline int8_t fptosi_f32_i8(float x) { + return (int8_t) x; +} + +static inline int16_t fptosi_f32_i16(float x) { + return (int16_t) x; +} + +static inline int32_t fptosi_f32_i32(float x) { + return (int32_t) x; +} + +static inline int64_t fptosi_f32_i64(float x) { + return (int64_t) x; +} + +static inline uint8_t fptoui_f32_i8(float x) { + return (uint8_t) x; +} + +static inline uint16_t fptoui_f32_i16(float x) { + return (uint16_t) x; +} + +static inline uint32_t fptoui_f32_i32(float x) { + return (uint32_t) x; +} + +static inline uint64_t fptoui_f32_i64(float x) { + return (uint64_t) 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); +} + +#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); +} + +static inline bool futrts_isinf32(float x) { + return isinf(x); +} + +#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_sqrt32(float x) { + return sqrt(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 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_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); +} + +#else // Not OpenCL, 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_sqrt32(float x) { + return sqrtf(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 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_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 + +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; +} + +static inline float fsignum32(float x) { + return futrts_isnan32(x) ? x : (x > 0) - (x < 0); +} + +#ifdef FUTHARK_F64_ENABLED + +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 int8_t fptosi_f64_i8(double x) { + return (int8_t) x; +} + +static inline int16_t fptosi_f64_i16(double x) { + return (int16_t) x; +} + +static inline int32_t fptosi_f64_i32(double x) { + return (int32_t) x; +} + +static inline int64_t fptosi_f64_i64(double x) { + return (int64_t) x; +} + +static inline uint8_t fptoui_f64_i8(double x) { + return (uint8_t) x; +} + +static inline uint16_t fptoui_f64_i16(double x) { + return (uint16_t) x; +} + +static inline uint32_t fptoui_f64_i32(double x) { + return (uint32_t) x; +} + +static inline uint64_t fptoui_f64_i64(double x) { + return (uint64_t) 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_sqrt64(double x) { + return sqrt(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_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 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 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) { + return (double) x; +} + +#endif + +// End of scalar.h. diff --git a/rts/c/scalar_f16.h b/rts/c/scalar_f16.h new file mode 100644 --- /dev/null +++ b/rts/c/scalar_f16.h @@ -0,0 +1,627 @@ +// Start of scalar_f16.h. + +// Half-precision is emulated if needed (e.g. in straight C) with the +// native type used if possible. The emulation works by typedef'ing +// 'float' to 'f16', and then implementing all operations on single +// precision. To cut down on duplication, we use the same code for +// those Futhark functions that require just operators or casts. The +// in-memory representation for arrays will still be 16 bits even +// under emulation, so the compiler will have to be careful when +// generating reads or writes. + +#if !defined(cl_khr_fp16) && !(defined(__CUDA_ARCH__) && __CUDA_ARCH__ >= 600) +#define EMULATE_F16 +#endif + +#if !defined(EMULATE_F16) && defined(__OPENCL_VERSION__) +#pragma OPENCL EXTENSION cl_khr_fp16 : enable +#endif + +#ifdef EMULATE_F16 + +// Note that the half-precision storage format is still 16 bits - the +// compiler will have to be real careful! +typedef float f16; + +#else + +#ifdef __CUDA_ARCH__ +#include +#endif + +typedef half f16; + +#endif + +// Some of these functions convert to single precision because half +// precision versions are not available. + +static inline f16 fadd16(f16 x, f16 y) { + return x + y; +} + +static inline f16 fsub16(f16 x, f16 y) { + return x - y; +} + +static inline f16 fmul16(f16 x, f16 y) { + return x * y; +} + +static inline bool cmplt16(f16 x, f16 y) { + return x < y; +} + +static inline bool cmple16(f16 x, f16 y) { + return x <= y; +} + +static inline f16 sitofp_i8_f16(int8_t x) { + return (f16) x; +} + +static inline f16 sitofp_i16_f16(int16_t x) { + return (f16) x; +} + +static inline f16 sitofp_i32_f16(int32_t x) { + return (f16) x; +} + +static inline f16 sitofp_i64_f16(int64_t x) { + return (f16) x; +} + +static inline f16 uitofp_i8_f16(uint8_t x) { + return (f16) x; +} + +static inline f16 uitofp_i16_f16(uint16_t x) { + return (f16) x; +} + +static inline f16 uitofp_i32_f16(uint32_t x) { + return (f16) x; +} + +static inline f16 uitofp_i64_f16(uint64_t x) { + return (f16) x; +} + +static inline int8_t fptosi_f16_i8(f16 x) { + return (int8_t) (float) x; +} + +static inline int16_t fptosi_f16_i16(f16 x) { + return (int16_t) x; +} + +static inline int32_t fptosi_f16_i32(f16 x) { + return (int32_t) x; +} + +static inline int64_t fptosi_f16_i64(f16 x) { + return (int64_t) x; +} + +static inline uint8_t fptoui_f16_i8(f16 x) { + return (uint8_t) (float) x; +} + +static inline uint16_t fptoui_f16_i16(f16 x) { + return (uint16_t) x; +} + +static inline uint32_t fptoui_f16_i32(f16 x) { + return (uint32_t) x; +} + +static inline uint64_t fptoui_f16_i64(f16 x) { + return (uint64_t) x; +} + +#ifndef EMULATE_F16 + +#ifdef __OPENCL_VERSION__ +static inline f16 fabs16(f16 x) { + return fabs(x); +} + +static inline f16 fmax16(f16 x, f16 y) { + return fmax(x, y); +} + +static inline f16 fmin16(f16 x, f16 y) { + return fmin(x, y); +} + +static inline f16 fpow16(f16 x, f16 y) { + return pow(x, y); +} + +#else // Assuming CUDA. + +static inline f16 fabs16(f16 x) { + return fabsf(x); +} + +static inline f16 fmax16(f16 x, f16 y) { + return fmaxf(x, y); +} + +static inline f16 fmin16(f16 x, f16 y) { + return fminf(x, y); +} + +static inline f16 fpow16(f16 x, f16 y) { + return powf(x, y); +} +#endif + +static inline bool futrts_isnan16(f16 x) { + return isnan((float)x); +} + +static inline bool futrts_isinf16(f16 x) { + return isinf((float)x); +} + +#ifdef __OPENCL_VERSION__ +static inline f16 futrts_log16(f16 x) { + return log(x); +} + +static inline f16 futrts_log2_16(f16 x) { + return log2(x); +} + +static inline f16 futrts_log10_16(f16 x) { + return log10(x); +} + +static inline f16 futrts_sqrt16(f16 x) { + return sqrt(x); +} + +static inline f16 futrts_exp16(f16 x) { + return exp(x); +} + +static inline f16 futrts_cos16(f16 x) { + return cos(x); +} + +static inline f16 futrts_sin16(f16 x) { + return sin(x); +} + +static inline f16 futrts_tan16(f16 x) { + return tan(x); +} + +static inline f16 futrts_acos16(f16 x) { + return acos(x); +} + +static inline f16 futrts_asin16(f16 x) { + return asin(x); +} + +static inline f16 futrts_atan16(f16 x) { + return atan(x); +} + +static inline f16 futrts_cosh16(f16 x) { + return cosh(x); +} + +static inline f16 futrts_sinh16(f16 x) { + return sinh(x); +} + +static inline f16 futrts_tanh16(f16 x) { + return tanh(x); +} + +static inline f16 futrts_acosh16(f16 x) { + return acosh(x); +} + +static inline f16 futrts_asinh16(f16 x) { + return asinh(x); +} + +static inline f16 futrts_atanh16(f16 x) { + return atanh(x); +} + +static inline f16 futrts_atan2_16(f16 x, f16 y) { + return atan2(x, y); +} + +static inline f16 futrts_hypot16(f16 x, f16 y) { + return hypot(x, y); +} + +static inline f16 futrts_gamma16(f16 x) { + return tgamma(x); +} + +static inline f16 futrts_lgamma16(f16 x) { + return lgamma(x); +} + +static inline f16 fmod16(f16 x, f16 y) { + return fmod(x, y); +} + +static inline f16 futrts_round16(f16 x) { + return rint(x); +} + +static inline f16 futrts_floor16(f16 x) { + return floor(x); +} + +static inline f16 futrts_ceil16(f16 x) { + return ceil(x); +} + +static inline 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) { + return mad(a, b, c); +} + +static inline f16 futrts_fma16(f16 a, f16 b, f16 c) { + return fma(a, b, c); +} + +#else // Assume CUDA. + +static inline f16 futrts_log16(f16 x) { + return hlog(x); +} + +static inline f16 futrts_log2_16(f16 x) { + return hlog2(x); +} + +static inline f16 futrts_log10_16(f16 x) { + return hlog10(x); +} + +static inline f16 futrts_sqrt16(f16 x) { + return hsqrt(x); +} + +static inline f16 futrts_exp16(f16 x) { + return hexp(x); +} + +static inline f16 futrts_cos16(f16 x) { + return hcos(x); +} + +static inline f16 futrts_sin16(f16 x) { + return hsin(x); +} + +static inline f16 futrts_tan16(f16 x) { + return tanf(x); +} + +static inline f16 futrts_acos16(f16 x) { + return acosf(x); +} + +static inline f16 futrts_asin16(f16 x) { + return asinf(x); +} + +static inline f16 futrts_atan16(f16 x) { + return atanf(x); +} + +static inline f16 futrts_cosh16(f16 x) { + return coshf(x); +} + +static inline f16 futrts_sinh16(f16 x) { + return sinhf(x); +} + +static inline f16 futrts_tanh16(f16 x) { + return tanhf(x); +} + +static inline f16 futrts_acosh16(f16 x) { + return acoshf(x); +} + +static inline f16 futrts_asinh16(f16 x) { + return asinhf(x); +} + +static inline f16 futrts_atanh16(f16 x) { + return atanhf(x); +} + +static inline f16 futrts_atan2_16(f16 x, f16 y) { + return atan2f(x, y); +} + +static inline f16 futrts_hypot16(f16 x, f16 y) { + return hypotf(x, y); +} + +static inline f16 futrts_gamma16(f16 x) { + return tgammaf(x); +} + +static inline f16 futrts_lgamma16(f16 x) { + return lgammaf(x); +} + +static inline f16 fmod16(f16 x, f16 y) { + return fmodf(x, y); +} + +static inline f16 futrts_round16(f16 x) { + return rintf(x); +} + +static inline f16 futrts_floor16(f16 x) { + return hfloor(x); +} + +static inline f16 futrts_ceil16(f16 x) { + return hceil(x); +} + +static inline 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) { + return a * b + c; +} + +static inline f16 futrts_fma16(f16 a, f16 b, f16 c) { + return fmaf(a, b, c); +} + +#endif + +// 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) { + return __half_as_ushort(x); +} +static inline f16 futrts_from_bits16(int16_t x) { + return __ushort_as_half(x); +} +#else +static inline int16_t futrts_to_bits16(f16 x) { + union { + f16 f; + int16_t t; + } p; + + p.f = x; + return p.t; +} + +static inline f16 futrts_from_bits16(int16_t x) { + union { + int16_t f; + f16 t; + } p; + + p.f = x; + return p.t; +} +#endif + +#else // No native f16 - emulate. + +static inline f16 fabs16(f16 x) { + return fabs32(x); +} + +static inline f16 fmax16(f16 x, f16 y) { + return fmax32(x, y); +} + +static inline f16 fmin16(f16 x, f16 y) { + return fmin32(x, y); +} + +static inline f16 fpow16(f16 x, f16 y) { + return fpow32(x, y); +} + +static inline bool futrts_isnan16(f16 x) { + return futrts_isnan32(x); +} + +static inline bool futrts_isinf16(f16 x) { + return futrts_isinf32(x); +} + +static inline f16 futrts_log16(f16 x) { + return futrts_log32(x); +} + +static inline f16 futrts_log2_16(f16 x) { + return futrts_log2_32(x); +} + +static inline f16 futrts_log10_16(f16 x) { + return futrts_log10_32(x); +} + +static inline f16 futrts_sqrt16(f16 x) { + return futrts_sqrt32(x); +} + +static inline f16 futrts_exp16(f16 x) { + return futrts_exp32(x); +} + +static inline f16 futrts_cos16(f16 x) { + return futrts_cos32(x); +} + +static inline f16 futrts_sin16(f16 x) { + return futrts_sin32(x); +} + +static inline f16 futrts_tan16(f16 x) { + return futrts_tan32(x); +} + +static inline f16 futrts_acos16(f16 x) { + return futrts_acos32(x); +} + +static inline f16 futrts_asin16(f16 x) { + return futrts_asin32(x); +} + +static inline f16 futrts_atan16(f16 x) { + return futrts_atan32(x); +} + +static inline f16 futrts_cosh16(f16 x) { + return futrts_cosh32(x); +} + +static inline f16 futrts_sinh16(f16 x) { + return futrts_sinh32(x); +} + +static inline f16 futrts_tanh16(f16 x) { + return futrts_tanh32(x); +} + +static inline f16 futrts_acosh16(f16 x) { + return futrts_acosh32(x); +} + +static inline f16 futrts_asinh16(f16 x) { + return futrts_asinh32(x); +} + +static inline f16 futrts_atanh16(f16 x) { + return futrts_atanh32(x); +} + +static inline f16 futrts_atan2_16(f16 x, f16 y) { + return futrts_atan2_32(x, y); +} + +static inline f16 futrts_hypot16(f16 x, f16 y) { + return futrts_hypot32(x, y); +} + +static inline f16 futrts_gamma16(f16 x) { + return futrts_gamma32(x); +} + +static inline f16 futrts_lgamma16(f16 x) { + return futrts_lgamma32(x); +} + +static inline f16 fmod16(f16 x, f16 y) { + return fmod32(x, y); +} + +static inline f16 futrts_round16(f16 x) { + return futrts_round32(x); +} + +static inline f16 futrts_floor16(f16 x) { + return futrts_floor32(x); +} + +static inline f16 futrts_ceil16(f16 x) { + return futrts_ceil32(x); +} + +static inline 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) { + return futrts_mad32(a, b, c); +} + +static inline f16 futrts_fma16(f16 a, f16 b, f16 c) { + return futrts_fma32(a, b, c); +} + +// Even when we are using an OpenCL that does not support cl_khr_fp16, +// it must still support vload_half for actually creating a +// half-precision number, which can then be efficiently converted to a +// float. Similarly for vstore_half. +#ifdef __OPENCL_VERSION__ + +static inline 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) { + return (f16)vload_half(0, (half*)&x); +} + +#else + +static inline int16_t futrts_to_bits16(f16 x) { + return (int16_t)float2halfbits(x); +} + +static inline f16 futrts_from_bits16(int16_t x) { + return halfbits2float((uint16_t)x); +} + +static inline f16 fsignum16(f16 x) { + return futrts_isnan16(x) ? x : (x > 0) - (x < 0); +} + +#endif + +#endif + +static inline float fpconv_f16_f16(f16 x) { + return x; +} + +static inline float fpconv_f16_f32(f16 x) { + return x; +} + +static inline f16 fpconv_f32_f16(float x) { + return x; +} + +#ifdef FUTHARK_F64_ENABLED + +static inline double fpconv_f16_f64(f16 x) { + return (double) x; +} + +static inline f16 fpconv_f64_f16(double x) { + return (f16) x; +} + +#endif + + +// End of scalar_f16.h. diff --git a/rts/c/scheduler.h b/rts/c/scheduler.h --- a/rts/c/scheduler.h +++ b/rts/c/scheduler.h @@ -100,6 +100,11 @@ #include #include #include +#elif defined(__EMSCRIPTEN__) +#include +#include +#include +#include #endif /* Multicore Utility functions */ @@ -128,7 +133,7 @@ } else { errno = EINVAL; } -#elif defined(__linux__) +#elif defined(__linux__) || __EMSCRIPTEN__ err = getrusage(RUSAGE_THREAD, rusage); #endif return err; @@ -152,6 +157,8 @@ return ncores; #elif defined(__linux__) return get_nprocs(); +#elif __EMSCRIPTEN__ + return emscripten_num_logical_cores(); #else fprintf(stderr, "operating system not recognised\n"); return -1; diff --git a/rts/c/server.h b/rts/c/server.h --- a/rts/c/server.h +++ b/rts/c/server.h @@ -57,6 +57,7 @@ DEF_SCALAR_TYPE(u16); DEF_SCALAR_TYPE(u32); DEF_SCALAR_TYPE(u64); +DEF_SCALAR_TYPE(f16); DEF_SCALAR_TYPE(f32); DEF_SCALAR_TYPE(f64); DEF_SCALAR_TYPE(bool); @@ -75,6 +76,7 @@ uint32_t v_u32; uint64_t v_u64; + uint16_t v_f16; float v_f32; double v_f64; @@ -107,6 +109,9 @@ if (v->type == &type_u64) { return &v->value.v_u64; } + if (v->type == &type_f16) { + return &v->value.v_f16; + } if (v->type == &type_f32) { return &v->value.v_f32; } @@ -286,8 +291,9 @@ int num_outs = entry_num_outs(e); int num_ins = entry_num_ins(e); - void* outs[num_outs]; - void* ins[num_ins]; + // +1 to avoid zero-size arrays, which is UB. + void* outs[num_outs+1]; + void* ins[num_ins+1]; for (int i = 0; i < num_ins; i++) { const char *in_name = get_arg(args, 1+num_outs+i); diff --git a/rts/c/tuning.h b/rts/c/tuning.h --- a/rts/c/tuning.h +++ b/rts/c/tuning.h @@ -20,7 +20,7 @@ if (eql) { *eql = 0; int value = atoi(eql+1); - if (set_size(cfg, line, value) != 0) { + if (set_size(cfg, line, (size_t)value) != 0) { char* err = (char*) malloc(max_line_len + 50); snprintf(err, max_line_len + 50, "Unknown name '%s' on line %d.", line, lineno); free(line); diff --git a/rts/c/util.h b/rts/c/util.h --- a/rts/c/util.h +++ b/rts/c/util.h @@ -7,6 +7,14 @@ static const char *fut_progname = "(embedded Futhark)"; +static void futhark_panic(int eval, const char *fmt, ...) __attribute__((noreturn)); +static char* msgprintf(const char *s, ...); +static void* slurp_file(const char *filename, size_t *size); +static int dump_file(const char *file, const void *buf, size_t n); +struct str_builder; +static void str_builder_init(struct str_builder *b); +static void str_builder(struct str_builder *b, const char *s, ...); + static void futhark_panic(int eval, const char *fmt, ...) { va_list ap; va_start(ap, fmt); @@ -28,7 +36,6 @@ return buffer; } - static inline void check_err(int errval, int sets_errno, const char *fun, int line, const char *msg, ...) { if (errval) { @@ -46,18 +53,18 @@ } } -#define CHECK_ERR(err, msg...) check_err(err, 0, __func__, __LINE__, msg) -#define CHECK_ERRNO(err, msg...) check_err(err, 1, __func__, __LINE__, msg) +#define CHECK_ERR(err, ...) check_err(err, 0, __func__, __LINE__, __VA_ARGS__) +#define CHECK_ERRNO(err, ...) check_err(err, 1, __func__, __LINE__, __VA_ARGS__) // Read the rest of an open file into a NUL-terminated string; returns // NULL on error. static void* fslurp_file(FILE *f, size_t *size) { - size_t start = ftell(f); + long start = ftell(f); fseek(f, 0, SEEK_END); - size_t src_size = ftell(f)-start; + long src_size = ftell(f)-start; fseek(f, start, SEEK_SET); - unsigned char *s = (unsigned char*) malloc(src_size + 1); - if (fread(s, 1, src_size, f) != src_size) { + unsigned char *s = (unsigned char*) malloc((size_t)src_size + 1); + if (fread(s, 1, (size_t)src_size, f) != (size_t)src_size) { free(s); s = NULL; } else { @@ -65,7 +72,7 @@ } if (size) { - *size = src_size; + *size = (size_t)src_size; } return s; diff --git a/rts/c/values.h b/rts/c/values.h --- a/rts/c/values.h +++ b/rts/c/values.h @@ -107,7 +107,7 @@ int ret; int first = 1; char *knows_dimsize = (char*) calloc((size_t)dims, sizeof(char)); - int cur_dim = dims-1; + int cur_dim = (int)dims-1; int64_t *elems_read_in_dim = (int64_t*) calloc((size_t)dims, sizeof(int64_t)); while (1) { @@ -337,16 +337,40 @@ READ_STR(SCNu64, uint64_t, "u64"); } +static int read_str_f16(char *buf, void* dest) { + remove_underscores(buf); + if (strcmp(buf, "f16.nan") == 0) { + *(uint16_t*)dest = float2halfbits(NAN); + return 0; + } else if (strcmp(buf, "f16.inf") == 0) { + *(uint16_t*)dest = float2halfbits(INFINITY); + return 0; + } else if (strcmp(buf, "-f16.inf") == 0) { + *(uint16_t*)dest = float2halfbits(-INFINITY); + return 0; + } else { + int j; + float x; + if (sscanf(buf, "%f%n", &x, &j) == 1) { + if (strcmp(buf+j, "") == 0 || strcmp(buf+j, "f16") == 0) { + *(uint16_t*)dest = float2halfbits(x); + return 0; + } + } + return 1; + } +} + static int read_str_f32(char *buf, void* dest) { remove_underscores(buf); if (strcmp(buf, "f32.nan") == 0) { - *(float*)dest = NAN; + *(float*)dest = (float)NAN; return 0; } else if (strcmp(buf, "f32.inf") == 0) { - *(float*)dest = INFINITY; + *(float*)dest = (float)INFINITY; return 0; } else if (strcmp(buf, "-f32.inf") == 0) { - *(float*)dest = -INFINITY; + *(float*)dest = (float)-INFINITY; return 0; } else { READ_STR("f", float, "f32"); @@ -356,13 +380,13 @@ static int read_str_f64(char *buf, void* dest) { remove_underscores(buf); if (strcmp(buf, "f64.nan") == 0) { - *(double*)dest = NAN; + *(double*)dest = (double)NAN; return 0; } else if (strcmp(buf, "f64.inf") == 0) { - *(double*)dest = INFINITY; + *(double*)dest = (double)INFINITY; return 0; } else if (strcmp(buf, "-f64.inf") == 0) { - *(double*)dest = -INFINITY; + *(double*)dest = (double)-INFINITY; return 0; } else { READ_STR("lf", double, "f64"); @@ -413,6 +437,19 @@ return fprintf(out, "%"PRIu64"u64", *src); } +static int write_str_f16(FILE *out, uint16_t *src) { + float x = halfbits2float(*src); + if (isnan(x)) { + return fprintf(out, "f16.nan"); + } else if (isinf(x) && x >= 0) { + return fprintf(out, "f16.inf"); + } else if (isinf(x)) { + return fprintf(out, "-f16.inf"); + } else { + return fprintf(out, "%.6ff16", x); + } +} + static int write_str_f32(FILE *out, float *src) { float x = *src; if (isnan(x)) { @@ -448,10 +485,10 @@ #define BINARY_FORMAT_VERSION 2 #define IS_BIG_ENDIAN (!*(unsigned char *)&(uint16_t){1}) -static void flip_bytes(int elem_size, unsigned char *elem) { - for (int j=0; jwrite_str(out, (void*)data); + elem_type->write_str(out, (const void*)data); } else { int64_t len = (int64_t)shape[0]; int64_t slice_size = 1; @@ -691,7 +731,7 @@ } else if (rank==1) { fputc('[', out); for (int64_t i = 0; i < len; i++) { - elem_type->write_str(out, (void*) (data + i * elem_size)); + elem_type->write_str(out, (const void*) (data + i * elem_size)); if (i != len-1) { fprintf(out, ", "); } @@ -763,8 +803,8 @@ return expected_type->read_str(buf, dest); } else { read_bin_ensure_scalar(f, expected_type); - int64_t elem_size = expected_type->size; - int num_elems_read = fread(dest, (size_t)elem_size, 1, f); + size_t elem_size = (size_t)expected_type->size; + size_t num_elems_read = fread(dest, elem_size, 1, f); if (IS_BIG_ENDIAN) { flip_bytes(elem_size, (unsigned char*) dest); } diff --git a/rts/javascript/server.js b/rts/javascript/server.js new file mode 100644 --- /dev/null +++ b/rts/javascript/server.js @@ -0,0 +1,251 @@ +// Start of server.js + +class Server { + + constructor(ctx) { + this.ctx = ctx; + this._vars = {}; + this._types = {}; + this._commands = [ 'inputs', + 'outputs', + 'call', + 'restore', + 'store', + 'free', + 'clear', + 'pause_profiling', + 'unpause_profiling', + 'report', + 'rename' + ]; + } + + _get_arg(args, i) { + if (i < args.length) { + return args[i]; + } else { + throw 'Insufficient command args'; + } + } + + _get_entry_point(entry) { + if (entry in this.ctx.get_entry_points()) { + return this.ctx.get_entry_points()[entry]; + } else { + throw "Unkown entry point: " + entry; + } + } + + _check_var(vname) { + if (!(vname in this._vars)) { + throw 'Unknown variable: ' + vname; + } + } + + _set_var(vname, v, t) { + this._vars[vname] = v; + this._types[vname] = t; + } + + _get_type(vname) { + this._check_var(vname); + return this._types[vname]; + } + + _get_var(vname) { + this._check_var(vname); + return this._vars[vname]; + } + + _cmd_inputs(args) { + var entry = this._get_arg(args, 0); + var inputs = this._get_entry_point(entry)[0]; + for (var i = 0; i < inputs.length; i++) { + console.log(inputs[i]); + } + } + + _cmd_outputs(args) { + var entry = this._get_arg(args, 0); + var outputs = this._get_entry_point(entry)[1]; + for (var i = 0; i < outputs.length; i++) { + console.log(outputs[i]); + } + } + + _cmd_dummy(args) { + // pass + } + + _cmd_free(args) { + for (var i = 0; i < args.length; i++) { + var vname = args[i]; + this._check_var(vname); + delete this._vars[vname]; + } + } + + _cmd_rename(args) { + var oldname = this._get_arg(args, 0) + var newname = this._get_arg(args, 1) + if (newname in this._vars) { + throw "Variable already exists: " + newname; + } + this._vars[newname] = this._vars[oldname]; + this._types[newname] = this._types[oldname]; + delete this._vars[oldname]; + delete this._types[oldname]; + } + + _cmd_call(args) { + var entry = this._get_entry_point(this._get_arg(args, 0)); + var num_ins = entry[0].length; + var num_outs = entry[1].length; + var expected_len = 1 + num_outs + num_ins + + if (args.length != expected_len) { + throw "Invalid argument count, expected " + expected_len + } + + var out_vnames = args.slice(1, num_outs+1) + for (var i = 0; i < out_vnames.length; i++) { + var out_vname = out_vnames[i]; + if (out_vname in this._vars) { + throw "Variable already exists: " + out_vname; + } + } + var in_vnames = args.slice(1+num_outs); + var ins = []; + for (var i = 0; i < in_vnames.length; i++) { + ins.push(this._get_var(in_vnames[i])); + } + // Call entry point function from string name + var bef = performance.now()*1000; + var vals = this.ctx[args[0]].apply(this.ctx, ins); + var aft = performance.now()*1000; + if (num_outs == 1) { + this._set_var(out_vnames[0], vals, entry[1][0]); + } else { + for (var i = 0; i < out_vnames.length; i++) { + this._set_var(out_vnames[i], vals[i], entry[1][i]); + } + } + console.log("runtime: " + Math.round(aft-bef)); + } + + _cmd_store(args) { + var fname = this._get_arg(args, 0); + for (var i = 1; i < args.length; i++) { + var vname = args[i]; + var value = this._get_var(vname); + var typ = this._get_type(vname); + var fs = require("fs"); + var bin_val = construct_binary_value(value, typ); + fs.appendFileSync(fname, bin_val, 'binary') + } + } + + fut_to_dim_typ(typ) { + var type = typ; + var count = 0; + while (type.substr(0, 2) == '[]') { + count = count + 1; + type = type.slice(2); + } + return [count, type]; + } + + _cmd_restore(args) { + if (args.length % 2 == 0) { + throw "Invalid argument count"; + } + + var fname = args[0]; + var args = args.slice(1); + + var as = args; + var reader = new Reader(fname); + while (as.length != 0) { + var vname = as[0]; + var typename = as[1]; + as = as.slice(2); + + if (vname in this._vars) { + throw "Variable already exists: " + vname; + } + try { + var value = read_value(typename, reader); + if (typeof value == 'number' || typeof value == 'bigint') { + this._set_var(vname, value, typename); + } else { + // We are working with an array and need to create to convert [shape, arr] to futhark ptr + var shape= value[0]; + var arr = value[1]; + var dimtyp = this.fut_to_dim_typ(typename); + var dim = dimtyp[0]; + var typ = dimtyp[1]; + var arg_list = [arr, ...shape]; + var fnam = "new_" + typ + "_" + dim + "d"; + var ptr = this.ctx[fnam].apply(this.ctx, arg_list); + this._set_var(vname, ptr, typename); + } + } catch (err) { + var err_msg = "Failed to restore variable " + vname + ".\nPossibly malformed data in " + fname + ".\n" + err.toString(); + throw err_msg; + } + } + skip_spaces(reader); + if (reader.get_buff().length != 0) { + throw "Expected EOF after reading values"; + } + } + + _process_line(line) { + // TODO make sure it splits on anywhite space + var words = line.split(" "); + if (words.length == 0) { + throw "Empty line"; + } else { + var cmd = words[0]; + var args = words.splice(1); + if (this._commands.includes(cmd)) { + switch (cmd) { + case 'inputs': this._cmd_inputs(args); break; + case 'outputs': this._cmd_outputs(args); break + case 'call': this._cmd_call(args); break + case 'restore': this._cmd_restore(args); break + case 'store': this._cmd_store(args); break + case 'free': this._cmd_free(args); break + case 'clear': this._cmd_dummy(args); break + case 'pause_profiling': this._cmd_dummy(args); break + case 'unpause_profiling': this._cmd_dummy(args); break + case 'report': this._cmd_dummy(args); break + case 'rename': this._cmd_rename(args); break + } + } else { + throw "Unknown command: " + cmd; + } + } + } + + run() { + console.log('%%% OK'); // TODO figure out if flushing is neccesary for JS + const readline = require('readline'); + const rl = readline.createInterface(process.stdin); + rl.on('line', (line) => { + if (line == "") { + rl.close(); + } + try { + this._process_line(line); + console.log('%%% OK'); + } catch (err) { + console.log('%%% FAILURE'); + console.log(err); + console.log('%%% OK'); + } + }).on('close', () => { process.exit(0); }); + } +} + +// End of server.js diff --git a/rts/javascript/values.js b/rts/javascript/values.js new file mode 100644 --- /dev/null +++ b/rts/javascript/values.js @@ -0,0 +1,165 @@ +// Start of values.js + +var typToType = { ' i8' : Int8Array , + ' i16' : Int16Array , + ' i32' : Int32Array , + ' i64' : BigInt64Array , + ' u8' : Uint8Array , + ' u16' : Uint16Array , + ' u32' : Uint32Array , + ' u64' : BigUint64Array , + ' f16' : Uint16Array , + ' f32' : Float32Array , + ' f64' : Float64Array , + 'bool' : Uint8Array + }; + +function binToStringArray(buff, array) { + for (var i = 0; i < array.length; i++) { + array[i] = buff[i]; + } +} + +function fileToBuff(fname) { + var readline = require('readline'); + var fs = require('fs'); + var buff = fs.readFileSync(fname); + return buff; +} + +var typToSize = { + "bool" : 1, + " u8" : 1, + " i8" : 1, + " u16" : 2, + " i16" : 2, + " u32" : 4, + " i32" : 4, + " f16" : 2, + " f32" : 4, + " u64" : 8, + " i64" : 8, + " f64" : 8, +} + +function toU8(ta) { + return new Uint8Array(ta.buffer, ta.byteOffset, ta.byteLength); +} + +function construct_binary_value(v, typ) { + var dims; + var payload_bytes; + var filler; + if (v instanceof FutharkOpaque) { + throw "Opaques are not supported"; + } else if (v instanceof FutharkArray) { + var t = v.futharkType(); + var ftype = " ".slice(t.length) + t; + var shape = v.shape(); + var ta = v.toTypedArray(shape); + var da = new BigInt64Array(shape); + dims = shape.length; + payload_bytes = da.byteLength + ta.byteLength; + filler = (bytes) => { + bytes.set(toU8(da), 7); + bytes.set(toU8(ta), 7 + da.byteLength); + } + } else { + var ftype = " ".slice(typ.length) + typ; + dims = 0; + payload_bytes = typToSize[ftype]; + filler = (bytes) => { + var scalar = new (typToType[ftype])([v]); + bytes.set(toU8(scalar), 7); + } + } + var total_bytes = 7 + payload_bytes; + var bytes = new Uint8Array(total_bytes); + bytes[0] = Buffer.from('b').readUInt8(); + bytes[1] = 2; + bytes[2] = dims; + for (var i = 0; i < 4; i++) { + bytes[3+i] = ftype.charCodeAt(i); + } + filler(bytes); + return Buffer.from(bytes); +} + +class Reader { + constructor(f) { + this.f = f; + this.buff = fileToBuff(f); + } + + read_bin_array(num_dim, typ) { + var u8_array = new Uint8Array(num_dim * 8); + binToStringArray(this.buff.slice(0, num_dim * 8), u8_array); + var shape = new BigInt64Array(u8_array.buffer); + var length = shape[0]; + for (var i = 1; i < shape.length; i++) { + length = length * shape[i]; + } + length = Number(length); + var dbytes = typToSize[typ]; + var u8_data = new Uint8Array(length * dbytes); + binToStringArray(this.buff.slice(num_dim * 8, num_dim * 8 + dbytes * length), u8_data); + var data = new (typToType[typ])(u8_data.buffer); + var tmp_buff = this.buff.slice(num_dim * 8, num_dim * 8 + dbytes * length); + this.buff = this.buff.slice(num_dim * 8 + dbytes * length); + return [shape, data]; + } + + read_bin_scalar(typ) { + var size = typToSize[typ]; + var u8_array = new Uint8Array(size); + binToStringArray(this.buff, u8_array); + var array = new (typToType[typ])(u8_array.buffer); + this.buff = this.buff.slice(u8_array.length); // Update buff to be unread part of the string + return array[0]; + } + + skip_spaces() { + while (this.buff.length > 0 && this.buff.slice(0, 1).toString().trim() == "") { + this.buff = this.buff.slice(1); + } + } + + read_binary() { + // Skip leading white space + while (this.buff.slice(0, 1).toString().trim() == "") { + this.buff = this.buff.slice(1); + } + if (this.buff[0] != 'b'.charCodeAt(0)) { + throw "Not in binary format" + } + var version = this.buff[1]; + if (version != 2) { + throw "Not version 2"; + } + var num_dim = this.buff[2]; + var typ = this.buff.slice(3, 7); + this.buff = this.buff.slice(7); + if (num_dim == 0) { + return this.read_bin_scalar(typ); + } else { + return this.read_bin_array(num_dim, typ); + } + } + + get_buff() { + return this.buff; + } +} + +// Function is redudant but is helpful for keeping consistent with python implementation +function skip_spaces(reader) { + reader.skip_spaces(); +} + +function read_value(typename, reader) { + // TODO include typename in implementation + var val = reader.read_binary(); + return val; +} + +// End of values.js diff --git a/rts/javascript/wrapperclasses.js b/rts/javascript/wrapperclasses.js new file mode 100644 --- /dev/null +++ b/rts/javascript/wrapperclasses.js @@ -0,0 +1,83 @@ +// Start of wrapperclasses.js + +class FutharkArray { + constructor(ctx, ptr, type_name, dim, heap, fshape, fvalues, ffree) { + this.ctx = ctx; + this.ptr = ptr; + this.type_name = type_name; + this.dim = dim; + this.heap = heap; + this.fshape = fshape; + this.fvalues = fvalues; + this.ffree = ffree; + this.valid = true; + } + + validCheck() { + if (!this.valid) { + throw "Using freed memory" + } + } + + futharkType() { + return this.type_name; + } + + free() { + this.validCheck(); + this.ffree(this.ctx.ctx, this.ptr); + this.valid = false; + } + + shape() { + this.validCheck(); + var s = this.fshape(this.ctx.ctx, this.ptr) >> 3; + return Array.from(this.ctx.wasm.HEAP64.subarray(s, s + this.dim)); + } + + toTypedArray(dims = this.shape()) { + this.validCheck(); + console.assert(dims.length === this.dim, "dim=%s,dims=%s", this.dim, dims.toString()); + var length = Number(dims.reduce((a, b) => a * b)); + var v = this.fvalues(this.ctx.ctx, this.ptr) / this.heap.BYTES_PER_ELEMENT; + return this.heap.subarray(v, v + length); + } + + toArray() { + this.validCheck(); + var dims = this.shape(); + var ta = this.toTypedArray(dims); + return (function nest(offs, ds) { + var d0 = Number(ds[0]); + if (ds.length === 1) { + return Array.from(ta.subarray(offs, offs + d0)); + } else { + var d1 = Number(ds[1]); + return Array.from(Array(d0), (x,i) => nest(offs + i * d1, ds.slice(1))); + } + })(0, dims); + } +} + +class FutharkOpaque { + constructor(ctx, ptr, ffree) { + this.ctx = ctx; + this.ptr = ptr; + this.ffree = ffree; + this.valid = true; + } + + validCheck() { + if (!this.valid) { + throw "Using freed memory" + } + } + + free() { + this.validCheck(); + this.ffree(this.ctx.ctx, this.ptr); + this.valid = false; + } +} + +// End of wrapperclasses.js diff --git a/rts/python/memory.py b/rts/python/memory.py --- a/rts/python/memory.py +++ b/rts/python/memory.py @@ -19,16 +19,16 @@ def unwrapArray(x): return normaliseArray(x).ctypes.data_as(ct.POINTER(ct.c_byte)) -def createArray(x, shape): +def createArray(x, shape, t): # HACK: np.ctypeslib.as_array may fail if the shape contains zeroes, # for some reason. if any(map(lambda x: x == 0, shape)): - return np.ndarray(shape, dtype=x._type_) + return np.ndarray(shape, dtype=t) else: - return np.ctypeslib.as_array(x, shape=shape) + return np.ctypeslib.as_array(x, shape=shape).view(t) -def indexArray(x, offset, bt, nptype): - return nptype(addressOffset(x, offset*ct.sizeof(bt), bt)[0]) +def indexArray(x, offset, bt): + return addressOffset(x, offset*ct.sizeof(bt), bt)[0] def writeScalarArray(x, offset, v): ct.memmove(ct.addressof(x.contents)+int(offset)*ct.sizeof(v), ct.addressof(v), ct.sizeof(v)) diff --git a/rts/python/opencl.py b/rts/python/opencl.py --- a/rts/python/opencl.py +++ b/rts/python/opencl.py @@ -214,9 +214,16 @@ # compiler should provide us with the variables to which # parameters are mapped. if (len(program_src) >= 0): - return cl.Program(self.ctx, program_src).build( - ["-DLOCKSTEP_WIDTH={}".format(lockstep_width)] - + ["-D{}={}".format(s.replace('z', 'zz').replace('.', 'zi').replace('#', 'zh'),v) for (s,v) in self.sizes.items()]) + build_options = [] + + build_options += ["-DLOCKSTEP_WIDTH={}".format(lockstep_width)] + + build_options += ["-D{}={}".format(s.replace('z', 'zz').replace('.', 'zi').replace('#', 'zh'),v) for (s,v) in self.sizes.items()] + + if (self.platform.name == 'Oclgrind'): + build_options += ['-DEMULATE_F16'] + + return cl.Program(self.ctx, program_src).build(build_options) def opencl_alloc(self, min_size, tag): min_size = 1 if min_size == 0 else min_size diff --git a/rts/python/scalar.py b/rts/python/scalar.py --- a/rts/python/scalar.py +++ b/rts/python/scalar.py @@ -238,9 +238,9 @@ umax8 = umax16 = umax32 = umax64 = umaxN umin8 = umin16 = umin32 = umin64 = uminN pow8 = pow16 = pow32 = pow64 = powN -fpow32 = fpow64 = fpowN -fmax32 = fmax64 = fmaxN -fmin32 = fmin64 = fminN +fpow16 = fpow32 = fpow64 = fpowN +fmax16 = fmax32 = fmax64 = fmaxN +fmin16 = fmin32 = fmin64 = fminN sle8 = sle16 = sle32 = sle64 = sleN slt8 = slt16 = slt32 = slt64 = sltN ule8 = ule16 = ule32 = ule64 = uleN @@ -309,39 +309,51 @@ def fptosi_T_i8(x): return np.int8(np.trunc(x)) -fptosi_f32_i8 = fptosi_f64_i8 = fptosi_T_i8 +fptosi_f16_i8 = fptosi_f32_i8 = fptosi_f64_i8 = fptosi_T_i8 def fptosi_T_i16(x): return np.int16(np.trunc(x)) -fptosi_f32_i16 = fptosi_f64_i16 = fptosi_T_i16 +fptosi_f16_i16 = fptosi_f32_i16 = fptosi_f64_i16 = fptosi_T_i16 def fptosi_T_i32(x): return np.int32(np.trunc(x)) -fptosi_f32_i32 = fptosi_f64_i32 = fptosi_T_i32 +fptosi_f16_i32 = fptosi_f32_i32 = fptosi_f64_i32 = fptosi_T_i32 def fptosi_T_i64(x): return np.int64(np.trunc(x)) -fptosi_f32_i64 = fptosi_f64_i64 = fptosi_T_i64 +fptosi_f16_i64 = fptosi_f32_i64 = fptosi_f64_i64 = fptosi_T_i64 def fptoui_T_i8(x): return np.uint8(np.trunc(x)) -fptoui_f32_i8 = fptoui_f64_i8 = fptoui_T_i8 +fptoui_f16_i8 = fptoui_f32_i8 = fptoui_f64_i8 = fptoui_T_i8 def fptoui_T_i16(x): return np.uint16(np.trunc(x)) -fptoui_f32_i16 = fptoui_f64_i16 = fptoui_T_i16 +fptoui_f16_i16 = fptoui_f32_i16 = fptoui_f64_i16 = fptoui_T_i16 def fptoui_T_i32(x): return np.uint32(np.trunc(x)) -fptoui_f32_i32 = fptoui_f64_i32 = fptoui_T_i32 +fptoui_f16_i32 = fptoui_f32_i32 = fptoui_f64_i32 = fptoui_T_i32 def fptoui_T_i64(x): return np.uint64(np.trunc(x)) -fptoui_f32_i64 = fptoui_f64_i64 = fptoui_T_i64 +fptoui_f16_i64 = fptoui_f32_i64 = fptoui_f64_i64 = fptoui_T_i64 +def fpconv_f16_f32(x): + return np.float32(x) + +def fpconv_f16_f64(x): + return np.float64(x) + +def fpconv_f32_f16(x): + return np.float16(x) + def fpconv_f32_f64(x): return np.float64(x) +def fpconv_f64_f16(x): + return np.float16(x) + def fpconv_f64_f32(x): return np.float32(x) @@ -550,16 +562,111 @@ s = struct.pack('>l', x) return np.float32(struct.unpack('>f', s)[0]) +def futhark_log16(x): + return np.float16(np.log(x)) + +def futhark_log2_16(x): + return np.float16(np.log2(x)) + +def futhark_log10_16(x): + return np.float16(np.log10(x)) + +def futhark_sqrt16(x): + return np.float16(np.sqrt(x)) + +def futhark_exp16(x): + return np.exp(x) + +def futhark_cos16(x): + return np.cos(x) + +def futhark_sin16(x): + return np.sin(x) + +def futhark_tan16(x): + return np.tan(x) + +def futhark_acos16(x): + return np.arccos(x) + +def futhark_asin16(x): + return np.arcsin(x) + +def futhark_atan16(x): + return np.arctan(x) + +def futhark_cosh16(x): + return np.cosh(x) + +def futhark_sinh16(x): + return np.sinh(x) + +def futhark_tanh16(x): + return np.tanh(x) + +def futhark_acosh16(x): + return np.arccosh(x) + +def futhark_asinh16(x): + return np.arcsinh(x) + +def futhark_atanh16(x): + return np.arctanh(x) + +def futhark_atan2_16(x, y): + return np.arctan2(x, y) + +def futhark_hypot16(x, y): + return np.hypot(x, y) + +def futhark_gamma16(x): + return np.float16(math.gamma(x)) + +def futhark_lgamma16(x): + return np.float16(math.lgamma(x)) + +def futhark_round16(x): + return np.round(x) + +def futhark_ceil16(x): + return np.ceil(x) + +def futhark_floor16(x): + return np.floor(x) + +def futhark_isnan16(x): + return np.isnan(x) + +def futhark_isinf16(x): + return np.isinf(x) + +def futhark_to_bits16(x): + s = struct.pack('>e', x) + return np.int16(struct.unpack('>H', s)[0]) + +def futhark_from_bits16(x): + s = struct.pack('>H', np.uint16(x)) + return np.float16(struct.unpack('>e', s)[0]) + +def futhark_lerp16(v0, v1, t): + return v0 + (v1-v0)*t + def futhark_lerp32(v0, v1, t): return v0 + (v1-v0)*t def futhark_lerp64(v0, v1, t): return v0 + (v1-v0)*t +def futhark_mad16(a, b, c): + return a * b + c + def futhark_mad32(a, b, c): return a * b + c def futhark_mad64(a, b, c): + return a * b + c + +def futhark_fma16(a, b, c): return a * b + c def futhark_fma32(a, b, c): diff --git a/rts/python/values.py b/rts/python/values.py --- a/rts/python/values.py +++ b/rts/python/values.py @@ -249,6 +249,24 @@ expt = b'0' return float(sign + bef + b'.' + aft + b'E' + expt) +def read_str_f16(f): + skip_spaces(f) + try: + parse_specific_string(f, 'f16.nan') + return np.float32(np.nan) + except ValueError: + try: + parse_specific_string(f, 'f16.inf') + return np.float32(np.inf) + except ValueError: + try: + parse_specific_string(f, '-f16.inf') + return np.float32(-np.inf) + except ValueError: + x = read_str_decimal(f) + optional_specific_string(f, 'f16') + return x + def read_str_f32(f): skip_spaces(f) try: @@ -385,6 +403,7 @@ read_bin_u32 = mk_bin_scalar_reader('u32') read_bin_u64 = mk_bin_scalar_reader('u64') +read_bin_f16 = mk_bin_scalar_reader('f16') read_bin_f32 = mk_bin_scalar_reader('f32') read_bin_f64 = mk_bin_scalar_reader('f64') @@ -460,6 +479,13 @@ 'bin_format': 'Q', 'numpy_type': np.uint64 }, + 'f16': {'binname' : b" f16", + 'size' : 2, + 'bin_reader': read_bin_f16, + 'str_reader': read_str_f16, + 'bin_format': 'e', + 'numpy_type': np.float16 }, + 'f32': {'binname' : b" f32", 'size' : 4, 'bin_reader': read_bin_f32, @@ -600,6 +626,16 @@ out.write("true") else: out.write("false") + elif type(v) == np.float16: + if np.isnan(v): + out.write('f16.nan') + elif np.isinf(v): + if v >= 0: + out.write('f16.inf') + else: + out.write('-f16.inf') + else: + out.write("%.6ff16" % v) elif type(v) == np.float32: if np.isnan(v): out.write('f32.nan') @@ -644,6 +680,7 @@ np.dtype('uint16'): b' u16', np.dtype('uint32'): b' u32', np.dtype('uint64'): b' u64', + np.dtype('float16'): b' f16', np.dtype('float32'): b' f32', np.dtype('float64'): b' f64', np.dtype('bool'): b'bool'} diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -1,18 +1,22 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -- | All (almost) compiler pipelines end with an 'Action', which does -- something with the result of the pipeline. module Futhark.Actions ( printAction, printAliasesAction, + callGraphAction, impCodeGenAction, kernelImpCodeGenAction, multicoreImpCodeGenAction, metricsAction, compileCAction, + compileCtoWASMAction, compileOpenCLAction, compileCUDAAction, compileMulticoreAction, + compileMulticoreToWASMAction, compilePythonAction, compilePyOpenCLAction, ) @@ -20,15 +24,21 @@ import Control.Monad import Control.Monad.IO.Class +import Data.List (intercalate) import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T import Futhark.Analysis.Alias +import Futhark.Analysis.CallGraph (buildCallGraph) import Futhark.Analysis.Metrics import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL import qualified Futhark.CodeGen.Backends.MulticoreC as MulticoreC +import qualified Futhark.CodeGen.Backends.MulticoreWASM as MulticoreWASM import qualified Futhark.CodeGen.Backends.PyOpenCL as PyOpenCL import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC import qualified Futhark.CodeGen.Backends.SequentialPython as SequentialPy +import qualified Futhark.CodeGen.Backends.SequentialWASM as SequentialWASM import qualified Futhark.CodeGen.ImpGen.GPU as ImpGenGPU import qualified Futhark.CodeGen.ImpGen.Multicore as ImpGenMulticore import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGenSequential @@ -37,6 +47,7 @@ import Futhark.IR.GPUMem (GPUMem) import Futhark.IR.MCMem (MCMem) import Futhark.IR.Prop.Aliases +import Futhark.IR.SOACS (SOACS) import Futhark.IR.SeqMem (SeqMem) import Futhark.Util (runProgramWithExitCode, unixEnvironment) import Futhark.Version (versionString) @@ -63,6 +74,15 @@ actionProcedure = liftIO . putStrLn . pretty . aliasAnalysis } +-- | Print call graph to stdout. +callGraphAction :: Action SOACS +callGraphAction = + Action + { actionName = "call-graph", + actionDescription = "Prettyprint the callgraph of the result to standard output.", + actionProcedure = liftIO . putStrLn . pretty . buildCallGraph + } + -- | Print metrics about AST node counts to stdout. metricsAction :: OpMetrics (Op rep) => Action rep metricsAction = @@ -100,20 +120,20 @@ } -- Lines that we prepend (in comments) to generated code. -headerLines :: [String] -headerLines = lines $ "Generated by Futhark " ++ versionString +headerLines :: [T.Text] +headerLines = T.lines $ "Generated by Futhark " <> T.pack versionString -cHeaderLines :: [String] +cHeaderLines :: [T.Text] cHeaderLines = map ("// " <>) headerLines -pyHeaderLines :: [String] +pyHeaderLines :: [T.Text] pyHeaderLines = map ("# " <>) headerLines -cPrependHeader :: String -> String -cPrependHeader = (unlines cHeaderLines ++) +cPrependHeader :: T.Text -> T.Text +cPrependHeader = (T.unlines cHeaderLines <>) -pyPrependHeader :: String -> String -pyPrependHeader = (unlines pyHeaderLines ++) +pyPrependHeader :: T.Text -> T.Text +pyPrependHeader = (T.unlines pyHeaderLines <>) cmdCC :: String cmdCC = fromMaybe "cc" $ lookup "CC" unixEnvironment @@ -163,13 +183,13 @@ case mode of ToLibrary -> do let (header, impl) = SequentialC.asLibrary cprog - liftIO $ writeFile hpath $ cPrependHeader header - liftIO $ writeFile cpath $ cPrependHeader impl + liftIO $ T.writeFile hpath $ cPrependHeader header + liftIO $ T.writeFile cpath $ cPrependHeader impl ToExecutable -> do - liftIO $ writeFile cpath $ SequentialC.asExecutable cprog + liftIO $ T.writeFile cpath $ SequentialC.asExecutable cprog runCC cpath outpath ["-O3", "-std=c99"] ["-lm"] ToServer -> do - liftIO $ writeFile cpath $ SequentialC.asServer cprog + liftIO $ T.writeFile cpath $ SequentialC.asServer cprog runCC cpath outpath ["-O3", "-std=c99"] ["-lm"] -- | The @futhark opencl@ action. @@ -196,13 +216,13 @@ case mode of ToLibrary -> do let (header, impl) = COpenCL.asLibrary cprog - liftIO $ writeFile hpath $ cPrependHeader header - liftIO $ writeFile cpath $ cPrependHeader impl + liftIO $ T.writeFile hpath $ cPrependHeader header + liftIO $ T.writeFile cpath $ cPrependHeader impl ToExecutable -> do - liftIO $ writeFile cpath $ cPrependHeader $ COpenCL.asExecutable cprog + liftIO $ T.writeFile cpath $ cPrependHeader $ COpenCL.asExecutable cprog runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options) ToServer -> do - liftIO $ writeFile cpath $ cPrependHeader $ COpenCL.asServer cprog + liftIO $ T.writeFile cpath $ cPrependHeader $ COpenCL.asServer cprog runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options) -- | The @futhark cuda@ action. @@ -226,13 +246,13 @@ case mode of ToLibrary -> do let (header, impl) = CCUDA.asLibrary cprog - liftIO $ writeFile hpath $ cPrependHeader header - liftIO $ writeFile cpath $ cPrependHeader impl + liftIO $ T.writeFile hpath $ cPrependHeader header + liftIO $ T.writeFile cpath $ cPrependHeader impl ToExecutable -> do - liftIO $ writeFile cpath $ cPrependHeader $ CCUDA.asExecutable cprog + liftIO $ T.writeFile cpath $ cPrependHeader $ CCUDA.asExecutable cprog runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options) ToServer -> do - liftIO $ writeFile cpath $ cPrependHeader $ CCUDA.asServer cprog + liftIO $ T.writeFile cpath $ cPrependHeader $ CCUDA.asServer cprog runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options) -- | The @futhark multicore@ action. @@ -252,17 +272,17 @@ case mode of ToLibrary -> do let (header, impl) = MulticoreC.asLibrary cprog - liftIO $ writeFile hpath $ cPrependHeader header - liftIO $ writeFile cpath $ cPrependHeader impl + liftIO $ T.writeFile hpath $ cPrependHeader header + liftIO $ T.writeFile cpath $ cPrependHeader impl ToExecutable -> do - liftIO $ writeFile cpath $ cPrependHeader $ MulticoreC.asExecutable cprog - runCC cpath outpath ["-O", "-std=c99"] ["-lm", "-pthread"] + liftIO $ T.writeFile cpath $ cPrependHeader $ MulticoreC.asExecutable cprog + runCC cpath outpath ["-O3", "-std=c99"] ["-lm", "-pthread"] ToServer -> do - liftIO $ writeFile cpath $ cPrependHeader $ MulticoreC.asServer cprog - runCC cpath outpath ["-O", "-std=c99"] ["-lm", "-pthread"] + liftIO $ T.writeFile cpath $ cPrependHeader $ MulticoreC.asServer cprog + runCC cpath outpath ["-O3", "-std=c99"] ["-lm", "-pthread"] pythonCommon :: - (CompilerMode -> String -> prog -> FutharkM (Warnings, String)) -> + (CompilerMode -> String -> prog -> FutharkM (Warnings, T.Text)) -> FutharkConfig -> CompilerMode -> FilePath -> @@ -277,12 +297,13 @@ case mode of ToLibrary -> - liftIO $ writeFile (outpath `addExtension` "py") $ pyPrependHeader pyprog + liftIO $ T.writeFile (outpath `addExtension` "py") $ pyPrependHeader pyprog _ -> liftIO $ do - writeFile outpath $ "#!/usr/bin/env python3\n" ++ pyPrependHeader pyprog + T.writeFile outpath $ "#!/usr/bin/env python3\n" <> pyPrependHeader pyprog perms <- liftIO $ getPermissions outpath setPermissions outpath $ setOwnerExecutable True perms +-- | The @futhark python@ action. compilePythonAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem compilePythonAction fcfg mode outpath = Action @@ -291,6 +312,7 @@ actionProcedure = pythonCommon SequentialPy.compileProg fcfg mode outpath } +-- | The @futhark pyopencl@ action. compilePyOpenCLAction :: FutharkConfig -> CompilerMode -> FilePath -> Action GPUMem compilePyOpenCLAction fcfg mode outpath = Action @@ -298,3 +320,109 @@ actionDescription = "Compile to Python with OpenCL", actionProcedure = pythonCommon PyOpenCL.compileProg fcfg mode outpath } + +cmdEMCFLAGS :: [String] -> [String] +cmdEMCFLAGS def = maybe def words $ lookup "EMCFLAGS" unixEnvironment + +runEMCC :: String -> String -> FilePath -> [String] -> [String] -> [String] -> Bool -> FutharkM () +runEMCC cpath outpath classpath cflags_def ldflags expfuns lib = do + ret <- + liftIO $ + runProgramWithExitCode + "emcc" + ( [cpath, "-o", outpath] + ++ ["-lnodefs.js"] + ++ ["-s", "--extern-post-js", classpath] + ++ ( if lib + then ["-s", "EXPORT_NAME=loadWASM"] + else [] + ) + ++ ["-s", "WASM_BIGINT"] + ++ cmdCFLAGS cflags_def + ++ cmdEMCFLAGS [""] + ++ [ "-s", + "EXPORTED_FUNCTIONS=[" + ++ intercalate "," ("'_malloc'" : "'_free'" : expfuns) + ++ "]" + ] + -- The default LDFLAGS are always added. + ++ ldflags + ) + mempty + case ret of + Left err -> + externalErrorS $ "Failed to run emcc: " ++ show err + Right (ExitFailure code, _, emccerr) -> + externalErrorS $ + "emcc failed with code " + ++ show code + ++ ":\n" + ++ emccerr + Right (ExitSuccess, _, _) -> + return () + +-- | The @futhark wasm@ action. +compileCtoWASMAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem +compileCtoWASMAction fcfg mode outpath = + Action + { actionName = "Compile to sequential C", + actionDescription = "Compile to sequential C", + actionProcedure = helper + } + where + helper prog = do + (cprog, jsprog, exps) <- handleWarnings fcfg $ SequentialWASM.compileProg prog + case mode of + ToLibrary -> do + writeLibs cprog jsprog + liftIO $ T.appendFile classpath SequentialWASM.libraryExports + runEMCC cpath mjspath classpath ["-O3", "-msimd128"] ["-lm"] exps True + _ -> do + -- Non-server executables are not supported. + writeLibs cprog jsprog + liftIO $ T.appendFile classpath SequentialWASM.runServer + runEMCC cpath outpath classpath ["-O3", "-msimd128"] ["-lm"] exps False + writeLibs cprog jsprog = do + let (h, imp) = SequentialC.asLibrary cprog + liftIO $ T.writeFile hpath h + liftIO $ T.writeFile cpath imp + liftIO $ T.writeFile classpath jsprog + + cpath = outpath `addExtension` "c" + hpath = outpath `addExtension` "h" + mjspath = outpath `addExtension` "mjs" + classpath = outpath `addExtension` ".class.js" + +-- | The @futhark wasm-multicore@ action. +compileMulticoreToWASMAction :: FutharkConfig -> CompilerMode -> FilePath -> Action MCMem +compileMulticoreToWASMAction fcfg mode outpath = + Action + { actionName = "Compile to sequential C", + actionDescription = "Compile to sequential C", + actionProcedure = helper + } + where + helper prog = do + (cprog, jsprog, exps) <- handleWarnings fcfg $ MulticoreWASM.compileProg prog + + case mode of + ToLibrary -> do + writeLibs cprog jsprog + liftIO $ T.appendFile classpath MulticoreWASM.libraryExports + runEMCC cpath mjspath classpath ["-O3", "-msimd128"] ["-lm", "-pthread"] exps True + _ -> do + -- Non-server executables are not supported. + writeLibs cprog jsprog + liftIO $ T.appendFile classpath MulticoreWASM.runServer + runEMCC cpath outpath classpath ["-O3", "-msimd128"] ["-lm", "-pthread"] exps False + + writeLibs cprog jsprog = do + let (h, imp) = MulticoreC.asLibrary cprog + liftIO $ T.writeFile hpath h + liftIO $ T.writeFile cpath imp + liftIO $ T.writeFile classpath jsprog + + cpath = outpath `addExtension` "c" + hpath = outpath `addExtension` "h" + mjspath = outpath `addExtension` "mjs" + classpath = outpath `addExtension` ".class.js" 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 @@ -72,7 +72,7 @@ Stm (Aliases rep) analyseStm aliases (Let pat (StmAux cs attrs dec) e) = let e' = analyseExp aliases e - pat' = addAliasesToPattern pat e' + pat' = addAliasesToPat pat e' rep' = (AliasDec $ consumedInExp e', dec) in Let pat' (StmAux cs attrs rep') e' 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 @@ -9,6 +9,7 @@ calls, calledByConsts, allCalledBy, + numOccurences, findNoninlined, ) where @@ -16,9 +17,10 @@ import Control.Monad.Writer.Strict import Data.List (foldl') import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) +import Data.Maybe (isJust) import qualified Data.Set as S import Futhark.IR.SOACS +import Futhark.Util.Pretty type FunctionTable = M.Map Name (FunDef SOACS) @@ -27,45 +29,78 @@ where expand ftab f = M.insert (funDefName f) f ftab -type FunGraph = M.Map Name (S.Set Name) +-- | A unique (at least within a function) name identifying a function +-- call. In practice the first element of the corresponding pattern. +type CallId = VName +data FunCalls = FunCalls + { fcMap :: M.Map CallId (Attrs, Name), + fcAllCalled :: S.Set Name + } + deriving (Eq, Ord, Show) + +instance Monoid FunCalls where + mempty = FunCalls mempty mempty + +instance Semigroup FunCalls where + FunCalls x1 y1 <> FunCalls x2 y2 = FunCalls (x1 <> x2) (y1 <> y2) + +fcCalled :: Name -> FunCalls -> Bool +fcCalled f fcs = f `S.member` fcAllCalled fcs + +type FunGraph = M.Map Name FunCalls + -- | The call graph is a mapping from a function name, i.e., the --- caller, to a set of the names of functions called *directly* (not +-- caller, to a record of the names of functions called *directly* (not -- transitively!) by the function. -- -- We keep track separately of the functions called by constants. data CallGraph = CallGraph - { calledByFuns :: M.Map Name (S.Set Name), - calledInConsts :: S.Set Name + { cgCalledByFuns :: FunGraph, + cgCalledByConsts :: FunCalls } + deriving (Eq, Ord, Show) -- | Is the given function known to the call graph? isFunInCallGraph :: Name -> CallGraph -> Bool -isFunInCallGraph f = M.member f . calledByFuns +isFunInCallGraph f = M.member f . cgCalledByFuns -- | Does the first function call the second? calls :: Name -> Name -> CallGraph -> Bool calls caller callee = - maybe False (S.member callee) . M.lookup caller . calledByFuns + maybe False (fcCalled callee) . M.lookup caller . cgCalledByFuns -- | Is the function called in any of the constants? calledByConsts :: Name -> CallGraph -> Bool -calledByConsts f = S.member f . calledInConsts +calledByConsts callee = fcCalled callee . cgCalledByConsts -- | All functions called by this function. allCalledBy :: Name -> CallGraph -> S.Set Name -allCalledBy f = fromMaybe mempty . M.lookup f . calledByFuns +allCalledBy f = maybe mempty fcAllCalled . M.lookup f . cgCalledByFuns -- | @buildCallGraph prog@ build the program's call graph. buildCallGraph :: Prog SOACS -> CallGraph buildCallGraph prog = - CallGraph fg $ buildFGStms $ progConsts prog + CallGraph fg cg where fg = foldl' (buildFGfun ftable) M.empty entry_points + cg = buildFGStms $ progConsts prog - entry_points = map funDefName $ progFuns prog + entry_points = + S.fromList (map funDefName (filter (isJust . funDefEntryPoint) $ progFuns prog)) + <> fcAllCalled cg ftable = buildFunctionTable prog +count :: Ord k => [k] -> M.Map k Int +count ks = M.fromListWith (+) $ zip ks $ repeat 1 + +-- | Produce a mapping of the number of occurences in the call graph +-- of each function. Only counts functions that are called at least +-- once. +numOccurences :: CallGraph -> M.Map Name Int +numOccurences (CallGraph funs consts) = + count $ map snd $ M.elems (fcMap consts <> foldMap fcMap (M.elems funs)) + -- | @buildCallGraph ftable fg fname@ updates @fg@ with the -- contributions of function @fname@. buildFGfun :: FunctionTable -> FunGraph -> Name -> FunGraph @@ -77,18 +112,19 @@ let callees = buildFGBody $ funDefBody f fg' = M.insert fname callees fg -- recursively build the callees - foldl' (buildFGfun ftable) fg' callees + foldl' (buildFGfun ftable) fg' $ fcAllCalled callees _ -> fg -buildFGStms :: Stms SOACS -> S.Set Name -buildFGStms = mconcat . map (buildFGexp . stmExp) . stmsToList +buildFGStms :: Stms SOACS -> FunCalls +buildFGStms = mconcat . map buildFGstm . stmsToList -buildFGBody :: Body -> S.Set Name +buildFGBody :: Body -> FunCalls buildFGBody = buildFGStms . bodyStms -buildFGexp :: Exp -> S.Set Name -buildFGexp (Apply fname _ _ _) = S.singleton fname -buildFGexp (Op op) = execWriter $ mapSOACM folder op +buildFGstm :: Stm -> FunCalls +buildFGstm (Let (Pat (p : _)) aux (Apply fname _ _ _)) = + FunCalls (M.singleton (patElemName p) (stmAuxAttrs aux, fname)) (S.singleton fname) +buildFGstm (Let _ _ (Op op)) = execWriter $ mapSOACM folder op where folder = identitySOACMapper @@ -96,7 +132,7 @@ tell $ buildFGBody $ lambdaBody lam return lam } -buildFGexp e = execWriter $ mapExpM folder e +buildFGstm (Let _ _ e) = execWriter $ mapExpM folder e where folder = identityMapper @@ -137,3 +173,18 @@ S.singleton $ funDefName fd | otherwise = mempty + +instance Pretty FunCalls where + ppr = stack . map f . M.toList . fcMap + where + f (x, (attrs, y)) = "=>" <+> ppr y <+> parens ("at" <+> ppr x <+> ppr attrs) + +instance Pretty CallGraph where + ppr (CallGraph fg cg) = + stack $ + punctuate line $ + ppFunCalls ("called at top level", cg) : map ppFunCalls (M.toList fg) + where + ppFunCalls (f, fcalls) = + ppr f text (map (const '=') (nameToString f)) + indent 2 (ppr fcalls) 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 @@ -32,7 +32,7 @@ let tdeps = dataDependencies' deps tb fdeps = dataDependencies' deps fb cdeps = depsOf deps c - comb (pe, tres, fres) = + comb (pe, SubExpRes _ tres, SubExpRes _ fres) = ( patElemName pe, mconcat $ [freeIn pe, cdeps, depsOf tdeps tres, depsOf fdeps fres] @@ -42,14 +42,14 @@ M.fromList $ map comb $ zip3 - (patternElements pat) + (patElems pat) (bodyResult tb) (bodyResult fb) in M.unions [branchdeps, deps, tdeps, fdeps] grow deps (Let pat _ e) = let free = freeIn pat <> freeIn e freeDeps = mconcat $ map (depsOfVar deps) $ namesToList free - in M.fromList [(name, freeDeps) | name <- patternNames pat] `M.union` deps + in M.fromList [(name, freeDeps) | name <- patNames pat] `M.union` deps depsOf :: Dependencies -> SubExp -> Names depsOf _ (Constant _) = mempty 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 @@ -60,7 +60,7 @@ setDepth n nw = n {nestingWidth = nw} fromSOAC :: - ( Bindable rep, + ( Buildable rep, MonadFreshNames m, LocalScope rep m, Op rep ~ Futhark.SOAC rep @@ -70,7 +70,7 @@ fromSOAC = fromSOAC' mempty fromSOAC' :: - ( Bindable rep, + ( Buildable rep, MonadFreshNames m, LocalScope rep m, Op rep ~ Futhark.SOAC rep @@ -83,7 +83,7 @@ bodyResult $ lambdaBody lam ) of ([Let pat _ e], res) - | res == map Var (patternNames pat) -> + | map resSubExp res == map Var (patNames pat) -> localScope (scopeOfLParams $ lambdaParams lam) $ SOAC.fromExp e >>= either (return . Left) (fmap (Right . fmap (pat,)) . fromSOAC' bound') @@ -102,7 +102,7 @@ let n' = Nesting { nestingParamNames = ps, - nestingResult = patternNames pat, + nestingResult = patNames pat, nestingReturnType = typeOf mn, nestingWidth = inner_w } @@ -143,8 +143,8 @@ toSOAC :: ( MonadFreshNames m, HasScope rep m, - Bindable rep, - BinderOps rep, + Buildable rep, + BuilderOps rep, Op rep ~ Futhark.SOAC rep ) => MapNest rep -> @@ -153,7 +153,7 @@ return $ SOAC.Screma w (Futhark.mapSOAC lam) inps toSOAC (MapNest w lam (Nesting npnames nres nrettype nw : ns) inps) = do let nparams = zipWith Param npnames $ map SOAC.inputRowType inps - body <- runBodyBinder $ + body <- runBodyBuilder $ localScope (scopeOfLParams nparams) $ do letBindNames nres =<< SOAC.toExp =<< toSOAC (MapNest nw lam ns $ map (SOAC.identInput . paramIdent) nparams) 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 @@ -99,15 +99,15 @@ -- create a list, use 'ArrayTransforms' instead. data ArrayTransform = -- | A permutation of an otherwise valid input. - Rearrange Certificates [Int] + Rearrange Certs [Int] | -- | A reshaping of an otherwise valid input. - Reshape Certificates (ShapeChange SubExp) + Reshape Certs (ShapeChange SubExp) | -- | A reshaping of the outer dimension. - ReshapeOuter Certificates (ShapeChange SubExp) + ReshapeOuter Certs (ShapeChange SubExp) | -- | A reshaping of everything but the outer dimension. - ReshapeInner Certificates (ShapeChange SubExp) + ReshapeInner Certs (ShapeChange SubExp) | -- | Replicate the rows of the array a number of times. - Replicate Certificates Shape + Replicate Certs Shape deriving (Show, Eq, Ord) instance Substitute ArrayTransform where @@ -226,7 +226,7 @@ -- an input transformation of an array variable. If so, return the -- variable and the transformation. Only 'Rearrange' and 'Reshape' -- are possible to express this way. -transformFromExp :: Certificates -> Exp rep -> Maybe (VName, ArrayTransform) +transformFromExp :: Certs -> Exp rep -> Maybe (VName, ArrayTransform) transformFromExp cs (BasicOp (Futhark.Rearrange perm v)) = Just (v, Rearrange cs perm) transformFromExp cs (BasicOp (Futhark.Reshape shape v)) = @@ -288,7 +288,7 @@ -- | Convert SOAC inputs to the corresponding expressions. inputsToSubExps :: - (MonadBinder m) => + (MonadBuilder m) => [Input] -> m [VName] inputsToSubExps = mapM inputToExp' @@ -472,14 +472,14 @@ -- | Convert a SOAC to the corresponding expression. toExp :: - (MonadBinder m, Op (Rep m) ~ Futhark.SOAC (Rep m)) => + (MonadBuilder m, Op (Rep m) ~ Futhark.SOAC (Rep m)) => SOAC (Rep m) -> m (Exp (Rep m)) toExp soac = Op <$> toSOAC soac -- | Convert a SOAC to a Futhark-level SOAC. toSOAC :: - MonadBinder m => + MonadBuilder m => SOAC (Rep m) -> m (Futhark.SOAC (Rep m)) toSOAC (Stream w form lam nes inps) = @@ -520,7 +520,7 @@ -- Returns the Stream SOAC and the -- extra-accumulator body-result ident if any. soacToStream :: - (MonadFreshNames m, Bindable rep, Op rep ~ Futhark.SOAC rep) => + (MonadFreshNames m, Buildable rep, Op rep ~ Futhark.SOAC rep) => SOAC rep -> m (SOAC rep, [Ident]) soacToStream soac = do @@ -547,8 +547,8 @@ let insoac = Futhark.Screma chvar (map paramName strm_inpids) $ Futhark.mapSOAC lam' - insbnd = mkLet [] strm_resids $ Op insoac - strmbdy = mkBody (oneStm insbnd) $ map (Futhark.Var . identName) strm_resids + insbnd = mkLet strm_resids $ Op insoac + strmbdy = mkBody (oneStm insbnd) $ map (subExpRes . Futhark.Var . identName) strm_resids strmpar = chunk_param : strm_inpids strmlam = Lambda strmpar strmbdy loutps empty_lam = Lambda [] (mkBody mempty []) [] @@ -582,56 +582,48 @@ outszm1id <- newIdent "szm1" $ Prim int64 -- 1. let (scan0_ids,map_resids) = scanomap(scan_lam,nes,map_lam,a_ch) let insbnd = - mkLet [] (scan0_ids ++ map_resids) $ - Op $ - Futhark.Screma chvar (map paramName strm_inpids) $ - Futhark.scanomapSOAC [Futhark.Scan scan_lam nes] lam' + mkLet (scan0_ids ++ map_resids) . Op $ + Futhark.Screma chvar (map paramName strm_inpids) $ + Futhark.scanomapSOAC [Futhark.Scan scan_lam nes] lam' -- 2. let outerszm1id = chunksize - 1 outszm1bnd = - mkLet [] [outszm1id] $ - BasicOp $ - BinOp - (Sub Int64 OverflowUndef) - (Futhark.Var $ paramName chunk_param) - (constant (1 :: Int64)) + mkLet [outszm1id] . BasicOp $ + BinOp + (Sub Int64 OverflowUndef) + (Futhark.Var $ paramName chunk_param) + (constant (1 :: Int64)) -- 3. let lasteel_ids = ... empty_arr_bnd = - mkLet [] [empty_arr] $ - BasicOp $ - CmpOp - (CmpSlt Int64) - (Futhark.Var $ identName outszm1id) - (constant (0 :: Int64)) + mkLet [empty_arr] . BasicOp $ + CmpOp + (CmpSlt Int64) + (Futhark.Var $ identName outszm1id) + (constant (0 :: Int64)) leltmpbnds = zipWith ( \lid arrid -> - mkLet [] [lid] $ - BasicOp $ - Index (identName arrid) $ - fullSlice - (identType arrid) - [DimFix $ Futhark.Var $ identName outszm1id] + mkLet [lid] . BasicOp $ + Index (identName arrid) $ + fullSlice + (identType arrid) + [DimFix $ Futhark.Var $ identName outszm1id] ) lastel_tmp_ids scan0_ids lelbnd = - mkLet [] lastel_ids $ + mkLet lastel_ids $ If (Futhark.Var $ identName empty_arr) - (mkBody mempty nes) + (mkBody mempty $ subExpsRes nes) ( mkBody (stmsFromList leltmpbnds) $ - map (Futhark.Var . identName) lastel_tmp_ids + varsRes $ map identName lastel_tmp_ids ) $ ifCommon $ map identType lastel_tmp_ids -- 4. let strm_resids = map (acc `+`,nes, scan0_ids) maplam <- mkMapPlusAccLam (map (Futhark.Var . paramName) inpacc_ids) scan_lam let mapbnd = - mkLet [] strm_resids $ - Op $ - Futhark.Screma - chvar - (map identName scan0_ids) - (Futhark.mapSOAC maplam) + mkLet strm_resids . Op $ + Futhark.Screma chvar (map identName scan0_ids) (Futhark.mapSOAC maplam) -- 5. let acc' = acc + lasteel_ids addlelbdy <- mkPlusBnds scan_lam $ @@ -641,7 +633,7 @@ let (addlelbnd, addlelres) = (bodyStms addlelbdy, bodyResult addlelbdy) strmbdy = mkBody (stmsFromList [insbnd, outszm1bnd, empty_arr_bnd, lelbnd, mapbnd] <> addlelbnd) $ - addlelres ++ map (Futhark.Var . identName) (strm_resids ++ map_resids) + addlelres ++ map (subExpRes . Futhark.Var . identName) (strm_resids ++ map_resids) strmpar = chunk_param : inpacc_ids ++ strm_inpids strmlam = Lambda strmpar strmbdy (accrtps ++ loutps) return @@ -670,7 +662,7 @@ chvar (map paramName strm_inpids) $ Futhark.redomapSOAC [Futhark.Reduce comm lamin nes] foldlam - insbnd = mkLet [] (acc0_ids ++ strm_resids) $ Op insoac + insbnd = mkLet (acc0_ids ++ strm_resids) $ Op insoac -- 2. let acc' = acc + acc0_ids in addaccbdy <- mkPlusBnds lamin $ @@ -680,7 +672,7 @@ let (addaccbnd, addaccres) = (bodyStms addaccbdy, bodyResult addaccbdy) strmbdy = mkBody (oneStm insbnd <> addaccbnd) $ - addaccres ++ map (Futhark.Var . identName) strm_resids + addaccres ++ map (subExpRes . Futhark.Var . identName) strm_resids strmpar = chunk_param : inpacc_ids ++ strm_inpids strmlam = Lambda strmpar strmbdy (accrtps ++ loutps') lam0 <- renameLambda lamin @@ -690,7 +682,7 @@ _ -> return (soac, []) where mkMapPlusAccLam :: - (MonadFreshNames m, Bindable rep) => + (MonadFreshNames m, Buildable rep) => [SubExp] -> Lambda rep -> m (Lambda rep) @@ -698,12 +690,7 @@ let (accpars, rempars) = splitAt (length accs) $ lambdaParams plus parbnds = zipWith - ( \par se -> - mkLet - [] - [paramIdent par] - (BasicOp $ SubExp se) - ) + (\par se -> mkLet [paramIdent par] (BasicOp $ SubExp se)) accpars accs plus_bdy = lambdaBody plus @@ -715,7 +702,7 @@ renameLambda $ Lambda rempars newlambdy $ lambdaReturnType plus mkPlusBnds :: - (MonadFreshNames m, Bindable rep) => + (MonadFreshNames m, Buildable rep) => Lambda rep -> [SubExp] -> m (Body rep) @@ -723,12 +710,7 @@ plus' <- renameLambda plus let parbnds = zipWith - ( \par se -> - mkLet - [] - [paramIdent par] - (BasicOp $ SubExp se) - ) + (\par se -> mkLet [paramIdent par] (BasicOp $ SubExp se)) (lambdaParams plus') accels body = lambdaBody plus' 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 @@ -11,24 +11,24 @@ import Data.Functor ((<&>)) import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Set (Set) import qualified Data.Set as S import Futhark.Analysis.LastUse (LastUseMap) import Futhark.IR.GPUMem import Futhark.Util (invertMap) --- | The set of `VName` currently in use. +-- | The set of 'VName' currently in use. type InUse = Names --- | The set of `VName` that are no longer in use. +-- | The set of 'VName' that are no longer in use. type LastUsed = Names --- | An interference graph. An element `(x, y)` in the set means that there is --- an undirected edge between `x` and `y`, and therefore the lifetimes of `x` --- and `y` overlap and they "interfere" with each other. We assume that pairs --- are always normalized, such that `x` < `y`, before inserting. This should --- prevent any duplicates. We also don't allow any pairs where `x == y`. +-- | An interference graph. An element @(x, y)@ in the set means that there is +-- an undirected edge between @x@ and @y@, and therefore the lifetimes of @x@ +-- and @y@ overlap and they "interfere" with each other. We assume that pairs +-- are always normalized, such that @x@ < @y@, before inserting. This should +-- prevent any duplicates. We also don't allow any pairs where @x == y@. type Graph a = Set (a, a) -- | Insert an edge between two values into the graph. @@ -52,11 +52,11 @@ m (InUse, LastUsed, Graph VName) analyseStm lumap inuse0 stm = inScopeOf stm $ do - let pat_name = patElemName $ head $ patternValueElements $ stmPattern stm + let pat_name = patElemName $ head $ patElems $ stmPat stm new_mems <- - stmPattern stm - & patternValueElements + stmPat stm + & patElems & mapM (memInfo . patElemName) <&> catMaybes <&> namesFromList @@ -91,6 +91,23 @@ (namesToList $ inuse_outside <> inuse <> lus <> last_use_mems) ) +-- We conservatively treat all memory arguments to a DoLoop 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 +-- probably very few programs would benefit from this. +analyseLoopParams :: + [(FParam GPUMem, SubExp)] -> + (InUse, LastUsed, Graph VName) -> + (InUse, LastUsed, Graph VName) +analyseLoopParams merge (inuse, lastused, graph) = + (inuse, lastused, cartesian makeEdge mems (mems <> inner_mems) <> graph) + where + mems = mapMaybe isMemArg merge + inner_mems = namesToList lastused <> namesToList inuse + isMemArg (Param _ MemMem {}, Var v) = Just v + isMemArg _ = Nothing + analyseExp :: LocalScope GPUMem m => LastUseMap -> @@ -103,8 +120,8 @@ res1 <- analyseBody lumap inuse_outside then_body res2 <- analyseBody lumap inuse_outside else_body return $ res1 <> res2 - DoLoop _ _ _ body -> do - analyseBody lumap inuse_outside body + DoLoop merge _ body -> + analyseLoopParams merge <$> analyseBody lumap inuse_outside body Op (Inner (SegOp segop)) -> do analyseSegOp lumap inuse_outside segop _ -> @@ -235,7 +252,7 @@ where memSizesStm :: LocalScope GPUMem m => Stm GPUMem -> m (Map VName Int) memSizesStm (Let pat _ e) = do - arraySizes <- fmap mconcat <$> mapM memElemSize $ patternNames pat + arraySizes <- fmap mconcat <$> mapM memElemSize $ patNames pat arraySizes' <- memSizesExp e return $ arraySizes <> arraySizes' memSizesExp :: LocalScope GPUMem m => Exp GPUMem -> m (Map VName Int) @@ -249,7 +266,7 @@ then_res <- memSizes $ bodyStms then_body else_res <- memSizes $ bodyStms else_body return $ then_res <> else_res - memSizesExp (DoLoop _ _ _ body) = + memSizesExp (DoLoop _ _ body) = memSizes $ bodyStms body memSizesExp _ = return mempty @@ -259,7 +276,7 @@ return $ foldMap getSpacesStm stms where getSpacesStm :: Stm GPUMem -> Map VName Space - getSpacesStm (Let (Pattern [] [PatElem name _]) _ (Op (Alloc _ sp))) = + getSpacesStm (Let (Pat [PatElem name _]) _ (Op (Alloc _ sp))) = M.singleton name sp getSpacesStm (Let _ _ (Op (Alloc _ _))) = error "impossible" getSpacesStm (Let _ _ (Op (Inner (SegOp segop)))) = @@ -267,7 +284,7 @@ getSpacesStm (Let _ _ (If _ then_body else_body _)) = foldMap getSpacesStm (bodyStms then_body) <> foldMap getSpacesStm (bodyStms else_body) - getSpacesStm (Let _ _ (DoLoop _ _ _ body)) = + getSpacesStm (Let _ _ (DoLoop _ _ body)) = foldMap getSpacesStm (bodyStms body) getSpacesStm _ = mempty @@ -290,18 +307,18 @@ res1 <- analyseGPU' lumap (bodyStms then_body) res2 <- analyseGPU' lumap (bodyStms else_body) return (res1 <> res2) - helper stm@Let {stmExp = DoLoop _ _ _ body} = - inScopeOf stm $ + helper stm@Let {stmExp = DoLoop merge _ body} = + fmap (analyseLoopParams merge) . inScopeOf stm $ analyseGPU' lumap $ bodyStms body helper stm = inScopeOf stm $ return mempty -nameInfoToMemInfo :: Mem rep => NameInfo rep -> MemBound NoUniqueness +nameInfoToMemInfo :: Mem rep inner => NameInfo rep -> MemBound NoUniqueness nameInfoToMemInfo info = case info of FParamName summary -> noUniquenessReturns summary LParamName summary -> summary - LetName summary -> summary + LetName summary -> letDecMem summary IndexName it -> MemPrim $ IntType it memInfo :: LocalScope GPUMem m => VName -> m (Maybe VName) 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 @@ -34,7 +34,7 @@ analyseProg prog = let consts = progConsts prog - & concatMap (toList . fmap patElemName . patternValueElements . stmPattern) + & concatMap (toList . fmap patElemName . patElems . stmPat) & namesFromList funs = progFuns $ aliasAnalysis prog (lus, used) = foldMap (analyseFun mempty consts) funs @@ -50,7 +50,7 @@ analyseStm :: Stm (Aliases GPUMem) -> (LastUse, Used) -> (LastUse, Used) analyseStm (Let pat _ e) (lumap0, used0) = - let (lumap', used') = patternValueElements pat & foldl helper (lumap0, used0) + let (lumap', used') = patElems pat & foldl helper (lumap0, used0) in analyseExp (lumap', used') e where helper (lumap_acc, used_acc) (PatElem name (aliases, _)) = @@ -62,7 +62,7 @@ used_acc <> unAliases aliases ) - pat_name = patElemName $ head $ patternValueElements pat + pat_name = patElemName $ head $ patElems pat analyseExp :: (LastUse, Used) -> Exp (Aliases GPUMem) -> (LastUse, Used) analyseExp (lumap, used) (BasicOp _) = let nms = freeIn e `namesSubtract` used @@ -76,9 +76,9 @@ used' = used_then <> used_else nms = ((freeIn cse <> freeIn dec) `namesSubtract` used') in (insertNames pat_name nms (lumap_then <> lumap_else), used' <> nms) - analyseExp (lumap, used) (DoLoop ctx vals form body) = + analyseExp (lumap, used) (DoLoop merge form body) = let (lumap', used') = analyseBody lumap used body - nms = (freeIn ctx <> freeIn vals <> freeIn form) `namesSubtract` used' + nms = (freeIn merge <> freeIn form) `namesSubtract` used' in (insertNames pat_name nms lumap', used' <> nms) analyseExp (lumap, used) (Op (Alloc se sp)) = let nms = (freeIn se <> freeIn sp) `namesSubtract` used 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 @@ -100,10 +100,10 @@ expMetrics :: OpMetrics (Op rep) => Exp rep -> MetricsM () expMetrics (BasicOp op) = - seen "BasicOp" >> primOpMetrics op -expMetrics (DoLoop _ _ ForLoop {} body) = + seen "BasicOp" >> basicOpMetrics op +expMetrics (DoLoop _ ForLoop {} body) = inside "DoLoop" $ seen "ForLoop" >> bodyMetrics body -expMetrics (DoLoop _ _ WhileLoop {} body) = +expMetrics (DoLoop _ WhileLoop {} body) = inside "DoLoop" $ seen "WhileLoop" >> bodyMetrics body expMetrics (If _ tb fb _) = inside "If" $ do @@ -116,27 +116,29 @@ expMetrics (Op op) = opMetrics op -primOpMetrics :: BasicOp -> MetricsM () -primOpMetrics (SubExp _) = seen "SubExp" -primOpMetrics (Opaque _) = seen "Opaque" -primOpMetrics ArrayLit {} = seen "ArrayLit" -primOpMetrics BinOp {} = seen "BinOp" -primOpMetrics UnOp {} = seen "UnOp" -primOpMetrics ConvOp {} = seen "ConvOp" -primOpMetrics CmpOp {} = seen "ConvOp" -primOpMetrics Assert {} = seen "Assert" -primOpMetrics Index {} = seen "Index" -primOpMetrics Update {} = seen "Update" -primOpMetrics Concat {} = seen "Concat" -primOpMetrics Copy {} = seen "Copy" -primOpMetrics Manifest {} = seen "Manifest" -primOpMetrics Iota {} = seen "Iota" -primOpMetrics Replicate {} = seen "Replicate" -primOpMetrics Scratch {} = seen "Scratch" -primOpMetrics Reshape {} = seen "Reshape" -primOpMetrics Rearrange {} = seen "Rearrange" -primOpMetrics Rotate {} = seen "Rotate" -primOpMetrics UpdateAcc {} = seen "UpdateAcc" +basicOpMetrics :: BasicOp -> MetricsM () +basicOpMetrics (SubExp _) = seen "SubExp" +basicOpMetrics (Opaque _ _) = seen "Opaque" +basicOpMetrics ArrayLit {} = seen "ArrayLit" +basicOpMetrics BinOp {} = seen "BinOp" +basicOpMetrics UnOp {} = seen "UnOp" +basicOpMetrics ConvOp {} = seen "ConvOp" +basicOpMetrics CmpOp {} = seen "ConvOp" +basicOpMetrics Assert {} = seen "Assert" +basicOpMetrics Index {} = seen "Index" +basicOpMetrics Update {} = seen "Update" +basicOpMetrics FlatIndex {} = seen "FlatIndex" +basicOpMetrics FlatUpdate {} = seen "FlatUpdate" +basicOpMetrics Concat {} = seen "Concat" +basicOpMetrics Copy {} = seen "Copy" +basicOpMetrics Manifest {} = seen "Manifest" +basicOpMetrics Iota {} = seen "Iota" +basicOpMetrics Replicate {} = seen "Replicate" +basicOpMetrics Scratch {} = seen "Scratch" +basicOpMetrics Reshape {} = seen "Reshape" +basicOpMetrics Rearrange {} = seen "Rearrange" +basicOpMetrics Rotate {} = seen "Rotate" +basicOpMetrics UpdateAcc {} = seen "UpdateAcc" -- | Compute metrics for this lambda. lambdaMetrics :: OpMetrics (Op rep) => Lambda rep -> MetricsM () 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 @@ -13,6 +13,7 @@ isInt32, isInt64, isBool, + isF16, isF32, isF64, evalPrimExp, @@ -147,6 +148,10 @@ isBool :: PrimExp v -> TPrimExp Bool v isBool = TPrimExp +-- | This expression is of type t'Half'. +isF16 :: PrimExp v -> TPrimExp Half v +isF16 = TPrimExp + -- | This expression is of type t'Float'. isF32 :: PrimExp v -> TPrimExp Float v isF32 = TPrimExp @@ -258,6 +263,10 @@ -- | Construct a typed expression from a rational. fromRational' :: Rational -> TPrimExp t v +instance NumExp Half where + fromInteger' = isF16 . ValueExp . FloatValue . Float16Value . fromInteger + fromBoolExp = isF16 . ConvOpExp (SIToFP Int16 Float16) . ConvOpExp (BToI Int16) . untyped + instance NumExp Float where fromInteger' = isF32 . ValueExp . FloatValue . Float32Value . fromInteger fromBoolExp = isF32 . ConvOpExp (SIToFP Int32 Float32) . ConvOpExp (BToI Int32) . untyped @@ -266,6 +275,9 @@ fromInteger' = TPrimExp . ValueExp . FloatValue . Float64Value . fromInteger fromBoolExp = isF64 . ConvOpExp (SIToFP Int32 Float64) . ConvOpExp (BToI Int32) . untyped +instance FloatExp Half where + fromRational' = TPrimExp . ValueExp . FloatValue . Float16Value . fromRational + instance FloatExp Float where fromRational' = TPrimExp . ValueExp . FloatValue . Float32Value . fromRational @@ -317,6 +329,24 @@ | otherwise = numBad "/" (x, y) fromRational = fromRational' + +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 + log x = isF16 $ FunExp "log16" [untyped x] $ FloatType Float16 + sin x = isF16 $ FunExp "sin16" [untyped x] $ FloatType Float16 + cos x = isF16 $ FunExp "cos16" [untyped x] $ FloatType Float16 + tan x = isF16 $ FunExp "tan16" [untyped x] $ FloatType Float16 + asin x = isF16 $ FunExp "asin16" [untyped x] $ FloatType Float16 + acos x = isF16 $ FunExp "acos16" [untyped x] $ FloatType Float16 + atan x = isF16 $ FunExp "atan16" [untyped x] $ FloatType Float16 + sinh x = isF16 $ FunExp "sinh16" [untyped x] $ FloatType Float16 + cosh x = isF16 $ FunExp "cosh16" [untyped x] $ FloatType Float16 + tanh x = isF16 $ FunExp "tanh16" [untyped x] $ FloatType Float16 + asinh x = isF16 $ FunExp "asinh16" [untyped x] $ FloatType Float16 + 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 x ** y = isF32 $ BinOpExp (FPow Float32) (untyped x) (untyped y) 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 @@ -90,19 +90,19 @@ primExpFromSubExp t (Var v) = LeafExp v t primExpFromSubExp _ (Constant v) = ValueExp v --- | Shorthand for constructing a 'TPrimExp' of type 'Int32'. +-- | Shorthand for constructing a 'TPrimExp' of type v'Int32'. pe32 :: SubExp -> TPrimExp Int32 VName pe32 = isInt32 . primExpFromSubExp int32 --- | Shorthand for constructing a 'TPrimExp' of type 'Int32', from a leaf. +-- | Shorthand for constructing a 'TPrimExp' of type v'Int32', from a leaf. le32 :: a -> TPrimExp Int32 a le32 = isInt32 . flip LeafExp int32 --- | Shorthand for constructing a 'TPrimExp' of type 'Int64'. +-- | Shorthand for constructing a 'TPrimExp' of type v'Int64'. pe64 :: SubExp -> TPrimExp Int64 VName pe64 = isInt64 . primExpFromSubExp int64 --- | Shorthand for constructing a 'TPrimExp' of type 'Int64', from a leaf. +-- | Shorthand for constructing a 'TPrimExp' of type v'Int64', from a leaf. le64 :: a -> TPrimExp Int64 a le64 = isInt64 . flip LeafExp int64 @@ -110,15 +110,15 @@ f32pe :: SubExp -> TPrimExp Float VName f32pe = isF32 . primExpFromSubExp float32 --- | Shorthand for constructing a 'TPrimExp' of type 'Float32', from a leaf. +-- | Shorthand for constructing a 'TPrimExp' of type v'Float32', from a leaf. f32le :: a -> TPrimExp Float a f32le = isF32 . flip LeafExp float32 --- | Shorthand for constructing a 'TPrimExp' of type 'Float64'. +-- | Shorthand for constructing a 'TPrimExp' of type v'Float64'. f64pe :: SubExp -> TPrimExp Double VName f64pe = isF64 . primExpFromSubExp float64 --- | Shorthand for constructing a 'TPrimExp' of type 'Float64', from a leaf. +-- | Shorthand for constructing a 'TPrimExp' of type v'Float64', from a leaf. f64le :: a -> TPrimExp Double a f64le = isF64 . flip LeafExp float64 @@ -162,10 +162,10 @@ substituteInPrimExp tab = replaceInPrimExp $ \v t -> fromMaybe (LeafExp v t) $ M.lookup v tab --- | Convert a 'SubExp' slice to a 'PrimExp' slice. +-- | Convert a t'SubExp' slice to a 'PrimExp' slice. primExpSlice :: Slice SubExp -> Slice (TPrimExp Int64 VName) -primExpSlice = map $ fmap pe64 +primExpSlice = fmap pe64 --- | Convert a 'PrimExp' slice to a 'SubExp' slice. -subExpSlice :: MonadBinder m => Slice (TPrimExp Int64 VName) -> m (Slice SubExp) -subExpSlice = mapM $ traverse $ toSubExp "slice" +-- | Convert a 'PrimExp' slice to a t'SubExp' slice. +subExpSlice :: MonadBuilder m => Slice (TPrimExp Int64 VName) -> m (Slice SubExp) +subExpSlice = traverse $ toSubExp "slice" diff --git a/src/Futhark/Analysis/PrimExp/Parse.hs b/src/Futhark/Analysis/PrimExp/Parse.hs --- a/src/Futhark/Analysis/PrimExp/Parse.hs +++ b/src/Futhark/Analysis/PrimExp/Parse.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Building blocks for parsing prim primexpressions. *Not* an infix +-- representation. module Futhark.Analysis.PrimExp.Parse ( pPrimExp, pPrimValue, @@ -42,6 +44,7 @@ parens :: Parser a -> Parser a parens = between (lexeme "(") (lexeme ")") +-- | Parse a 'PrimExp' given a leaf parser. pPrimExp :: Parser (v, PrimType) -> Parser (PrimExp v) pPrimExp pLeaf = choice diff --git a/src/Futhark/Analysis/Rephrase.hs b/src/Futhark/Analysis/Rephrase.hs --- a/src/Futhark/Analysis/Rephrase.hs +++ b/src/Futhark/Analysis/Rephrase.hs @@ -9,7 +9,7 @@ rephraseBody, rephraseStm, rephraseLambda, - rephrasePattern, + rephrasePat, rephrasePatElem, Rephraser (..), ) @@ -56,17 +56,17 @@ rephraseStm :: Monad m => Rephraser m from to -> Stm from -> m (Stm to) rephraseStm rephraser (Let pat (StmAux cs attrs dec) e) = Let - <$> rephrasePattern (rephraseLetBoundDec rephraser) pat + <$> rephrasePat (rephraseLetBoundDec rephraser) pat <*> (StmAux cs attrs <$> rephraseExpDec rephraser dec) <*> rephraseExp rephraser e -- | Rephrase a pattern. -rephrasePattern :: +rephrasePat :: Monad m => (from -> m to) -> - PatternT from -> - m (PatternT to) -rephrasePattern = traverse + PatT from -> + m (PatT to) +rephrasePat = traverse -- | Rephrase a pattern element. rephrasePatElem :: Monad m => (from -> m to) -> PatElemT from -> m (PatElemT to) 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 @@ -109,12 +109,12 @@ data Indexed = -- | A PrimExp based on the indexes (that is, without -- accessing any actual array). - Indexed Certificates (PrimExp VName) + Indexed Certs (PrimExp VName) | -- | The indexing corresponds to another (perhaps more -- advantageous) array. - IndexedArray Certificates VName [TPrimExp Int64 VName] + IndexedArray Certs VName [TPrimExp Int64 VName] -indexedAddCerts :: Certificates -> Indexed -> Indexed +indexedAddCerts :: Certs -> Indexed -> Indexed indexedAddCerts cs1 (Indexed cs2 v) = Indexed (cs1 <> cs2) v indexedAddCerts cs1 (IndexedArray cs2 arr v) = IndexedArray (cs1 <> cs2) arr v @@ -210,10 +210,10 @@ lookupStm :: VName -> SymbolTable rep -> Maybe (Stm rep) lookupStm name vtable = entryStm =<< lookup name vtable -lookupExp :: VName -> SymbolTable rep -> Maybe (Exp rep, Certificates) +lookupExp :: VName -> SymbolTable rep -> Maybe (Exp rep, Certs) lookupExp name vtable = (stmExp &&& stmCerts) <$> lookupStm name vtable -lookupBasicOp :: VName -> SymbolTable rep -> Maybe (BasicOp, Certificates) +lookupBasicOp :: VName -> SymbolTable rep -> Maybe (BasicOp, Certs) lookupBasicOp name vtable = case lookupExp name vtable of Just (BasicOp e, cs) -> Just (e, cs) _ -> Nothing @@ -225,7 +225,7 @@ lookupSubExpType (Var v) = lookupType v lookupSubExpType (Constant v) = const $ Just $ Prim $ primValueType v -lookupSubExp :: VName -> SymbolTable rep -> Maybe (SubExp, Certificates) +lookupSubExp :: VName -> SymbolTable rep -> Maybe (SubExp, Certs) lookupSubExp name vtable = do (e, cs) <- lookupExp name vtable case e of @@ -279,9 +279,8 @@ case entryType entry of LetBound entry' | Just k <- - elemIndex name $ - patternValueNames $ - stmPattern $ letBoundStm entry' -> + elemIndex name . patNames . stmPat $ + letBoundStm entry' -> letBoundIndex entry' k is FreeVar entry' -> freeVarIndex entry' name is @@ -333,7 +332,7 @@ is in index' v is' table indexExp table (BasicOp (Index v slice)) _ is = - index' v (adjust slice is) table + index' v (adjust (unSlice slice) is) table where adjust (DimFix j : js') is' = pe64 j : adjust js' is' @@ -367,7 +366,7 @@ SymbolTable rep -> [LetBoundEntry rep] bindingEntries bnd@(Let pat _ _) vtable = do - pat_elem <- patternElements pat + pat_elem <- patElems pat return $ defBndEntry vtable pat_elem (Aliases.aliasesOf pat_elem) bnd adjustSeveral :: Ord k => (v -> v) -> [k] -> M.Map k v -> M.Map k v @@ -412,10 +411,10 @@ SymbolTable rep insertStm stm vtable = flip (foldl' $ flip consume) (namesToList stm_consumed) $ - flip (foldl' addRevAliases) (patternElements $ stmPattern stm) $ + flip (foldl' addRevAliases) (patElems $ stmPat stm) $ insertEntries (zip names $ map LetBound $ bindingEntries stm vtable) vtable where - names = patternNames $ stmPattern stm + names = patNames $ stmPat stm stm_consumed = expandAliases (Aliases.consumedInStm stm) vtable addRevAliases vtable' pe = vtable' {bindings = adjustSeveral update inedges $ bindings vtable'} @@ -490,12 +489,12 @@ -- parameters. insertLoopMerge :: ASTRep rep => - [(AST.FParam rep, SubExp, SubExp)] -> + [(AST.FParam rep, SubExp, SubExpRes)] -> SymbolTable rep -> SymbolTable rep insertLoopMerge = flip $ foldl' $ flip bind where - bind (p, initial, res) = + bind (p, initial, SubExpRes _ res) = insertEntry (paramName p) $ FParam FParamEntry @@ -555,4 +554,4 @@ hideCertified :: Names -> SymbolTable rep -> SymbolTable rep hideCertified to_hide = hideIf $ maybe False hide . entryStm where - hide = any (`nameIn` to_hide) . unCertificates . stmCerts + hide = any (`nameIn` to_hide) . unCerts . stmCerts 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 @@ -157,10 +157,10 @@ where usageInPat = usages - ( mconcat (map freeIn $ patternElements pat) - `namesSubtract` namesFromList (patternNames pat) + ( mconcat (map freeIn $ patElems pat) + `namesSubtract` namesFromList (patNames pat) ) - <> sizeUsages (foldMap (freeIn . patElemType) (patternElements pat)) + <> sizeUsages (foldMap (freeIn . patElemType) (patElems pat)) usageInExpDec = usages $ freeIn rep @@ -181,7 +181,9 @@ foldMap inputUsage inputs <> usageInBody (lambdaBody lam) where inputUsage (_, arrs, _) = foldMap consumedUsage arrs -usageInExp (BasicOp (Update src _ _)) = +usageInExp (BasicOp (Update _ src _ _)) = + consumedUsage src +usageInExp (BasicOp (FlatUpdate src _ _)) = consumedUsage src usageInExp (Op op) = mconcat $ map consumedUsage (namesToList $ consumedInOp op) diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -38,6 +38,8 @@ newtype RunResult = RunResult {runMicroseconds :: Int} deriving (Eq, Show) +-- | The measurements resulting from various successful runs of a +-- benchmark (same dataset). data Result = Result { runResults :: [RunResult], memoryMap :: M.Map T.Text Int, diff --git a/src/Futhark/Binder.hs b/src/Futhark/Binder.hs deleted file mode 100644 --- a/src/Futhark/Binder.hs +++ /dev/null @@ -1,259 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module defines a convenience monad/typeclass for creating --- normalised programs. The fundamental building block is 'BinderT' --- and its execution functions, but it is usually easier to use --- 'Binder'. --- --- See "Futhark.Construct" for a high-level description. -module Futhark.Binder - ( -- * A concrete @MonadBinder@ monad. - BinderT, - runBinderT, - runBinderT_, - runBinderT', - runBinderT'_, - BinderOps (..), - Binder, - runBinder, - runBinder_, - runBodyBinder, - - -- * The 'MonadBinder' typeclass - module Futhark.Binder.Class, - ) -where - -import Control.Arrow (second) -import Control.Monad.Error.Class -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Monad.Writer -import qualified Data.Map.Strict as M -import Futhark.Binder.Class -import Futhark.IR - --- | A 'BinderT' (and by extension, a 'Binder') is only an instance of --- 'MonadBinder' for representations that implement this type class, --- which contains methods for constructing statements. -class ASTRep rep => BinderOps rep where - mkExpDecB :: - (MonadBinder m, Rep m ~ rep) => - Pattern rep -> - Exp rep -> - m (ExpDec rep) - mkBodyB :: - (MonadBinder m, Rep m ~ rep) => - Stms rep -> - Result -> - m (Body rep) - mkLetNamesB :: - (MonadBinder m, Rep m ~ rep) => - [VName] -> - Exp rep -> - m (Stm rep) - - default mkExpDecB :: - (MonadBinder m, Bindable rep) => - Pattern rep -> - Exp rep -> - m (ExpDec rep) - mkExpDecB pat e = return $ mkExpDec pat e - - default mkBodyB :: - (MonadBinder m, Bindable rep) => - Stms rep -> - Result -> - m (Body rep) - mkBodyB stms res = return $ mkBody stms res - - default mkLetNamesB :: - (MonadBinder m, Rep m ~ rep, Bindable rep) => - [VName] -> - Exp rep -> - m (Stm rep) - mkLetNamesB = mkLetNames - --- | A monad transformer that tracks statements and provides a --- 'MonadBinder' instance, assuming that the underlying monad provides --- a name source. In almost all cases, this is what you will use for --- constructing statements (possibly as part of a larger monad stack). --- If you find yourself needing to implement 'MonadBinder' from --- scratch, then it is likely that you are making a mistake. -newtype BinderT rep m a = BinderT (StateT (Stms rep, Scope rep) m a) - deriving (Functor, Monad, Applicative) - -instance MonadTrans (BinderT rep) where - lift = BinderT . lift - --- | The most commonly used binder monad. -type Binder rep = BinderT rep (State VNameSource) - -instance MonadFreshNames m => MonadFreshNames (BinderT rep m) where - getNameSource = lift getNameSource - putNameSource = lift . putNameSource - -instance - (ASTRep rep, Monad m) => - HasScope rep (BinderT rep m) - where - lookupType name = do - t <- BinderT $ gets $ M.lookup name . snd - case t of - Nothing -> error $ "BinderT.lookupType: unknown variable " ++ pretty name - Just t' -> return $ typeOf t' - askScope = BinderT $ gets snd - -instance - (ASTRep rep, Monad m) => - LocalScope rep (BinderT rep m) - where - localScope types (BinderT m) = BinderT $ do - modify $ second (M.union types) - x <- m - modify $ second (`M.difference` types) - return x - -instance - (ASTRep rep, MonadFreshNames m, BinderOps rep) => - MonadBinder (BinderT rep m) - where - type Rep (BinderT rep m) = rep - mkExpDecM = mkExpDecB - mkBodyM = mkBodyB - mkLetNamesM = mkLetNamesB - - addStms stms = - BinderT $ - modify $ \(cur_stms, scope) -> - (cur_stms <> stms, scope `M.union` scopeOf stms) - - collectStms m = do - (old_stms, old_scope) <- BinderT get - BinderT $ put (mempty, old_scope) - x <- m - (new_stms, _) <- BinderT get - BinderT $ put (old_stms, old_scope) - return (x, new_stms) - --- | Run a binder action given an initial scope, returning a value and --- the statements added ('addStm') during the action. -runBinderT :: - MonadFreshNames m => - BinderT rep m a -> - Scope rep -> - m (a, Stms rep) -runBinderT (BinderT m) scope = do - (x, (stms, _)) <- runStateT m (mempty, scope) - return (x, stms) - --- | Like 'runBinderT', but return only the statements. -runBinderT_ :: - MonadFreshNames m => - BinderT rep m () -> - Scope rep -> - m (Stms rep) -runBinderT_ m = fmap snd . runBinderT m - --- | Like 'runBinderT', but get the initial scope from the current --- monad. -runBinderT' :: - (MonadFreshNames m, HasScope somerep m, SameScope somerep rep) => - BinderT rep m a -> - m (a, Stms rep) -runBinderT' m = do - scope <- askScope - runBinderT m $ castScope scope - --- | Like 'runBinderT_', but get the initial scope from the current --- monad. -runBinderT'_ :: - (MonadFreshNames m, HasScope somerep m, SameScope somerep rep) => - BinderT rep m a -> - m (Stms rep) -runBinderT'_ = fmap snd . runBinderT' - --- | Run a binder action, returning a value and the statements added --- ('addStm') during the action. Assumes that the current monad --- provides initial scope and name source. -runBinder :: - ( MonadFreshNames m, - HasScope somerep m, - SameScope somerep rep - ) => - Binder rep a -> - m (a, Stms rep) -runBinder m = do - types <- askScope - modifyNameSource $ runState $ runBinderT m $ castScope types - --- | Like 'runBinder', but throw away the result and just return the --- added statements. -runBinder_ :: - ( MonadFreshNames m, - HasScope somerep m, - SameScope somerep rep - ) => - Binder rep a -> - m (Stms rep) -runBinder_ = fmap snd . runBinder - --- | Run a binder that produces a t'Body', and prefix that t'Body' by --- the statements produced during execution of the action. -runBodyBinder :: - ( Bindable rep, - MonadFreshNames m, - HasScope somerep m, - SameScope somerep rep - ) => - Binder rep (Body rep) -> - m (Body rep) -runBodyBinder = fmap (uncurry $ flip insertStms) . runBinder - --- Utility instance defintions for MTL classes. These require --- UndecidableInstances, but save on typing elsewhere. - -mapInner :: - Monad m => - ( m (a, (Stms rep, Scope rep)) -> - m (b, (Stms rep, Scope rep)) - ) -> - BinderT rep m a -> - BinderT rep m b -mapInner f (BinderT m) = BinderT $ do - s <- get - (x, s') <- lift $ f $ runStateT m s - put s' - return x - -instance MonadReader r m => MonadReader r (BinderT rep m) where - ask = BinderT $ lift ask - local f = mapInner $ local f - -instance MonadState s m => MonadState s (BinderT rep m) where - get = BinderT $ lift get - put = BinderT . lift . put - -instance MonadWriter w m => MonadWriter w (BinderT rep m) where - tell = BinderT . lift . tell - pass = mapInner $ \m -> pass $ do - ((x, f), s) <- m - return ((x, s), f) - listen = mapInner $ \m -> do - ((x, s), y) <- listen m - return ((x, y), s) - -instance MonadError e m => MonadError e (BinderT rep m) where - throwError = lift . throwError - catchError (BinderT m) f = - BinderT $ catchError m $ unBinder . f - where - unBinder (BinderT m') = m' diff --git a/src/Futhark/Binder/Class.hs b/src/Futhark/Binder/Class.hs deleted file mode 100644 --- a/src/Futhark/Binder/Class.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - --- | This module defines a convenience typeclass for creating --- normalised programs. --- --- See "Futhark.Construct" for a high-level description. -module Futhark.Binder.Class - ( Bindable (..), - mkLet, - mkLet', - MonadBinder (..), - insertStms, - insertStm, - letBind, - letBindNames, - collectStms_, - bodyBind, - attributing, - auxing, - module Futhark.MonadFreshNames, - ) -where - -import qualified Data.Kind -import Futhark.IR -import Futhark.MonadFreshNames - --- | The class of representations that can be constructed solely from --- an expression, within some monad. Very important: the methods --- should not have any significant side effects! They may be called --- more often than you think, and the results thrown away. If used --- exclusively within a 'MonadBinder' instance, it is acceptable for --- them to create new bindings, however. -class - ( ASTRep rep, - FParamInfo rep ~ DeclType, - LParamInfo rep ~ Type, - RetType rep ~ DeclExtType, - BranchType rep ~ ExtType, - SetType (LetDec rep) - ) => - Bindable rep - where - mkExpPat :: [Ident] -> [Ident] -> Exp rep -> Pattern rep - mkExpDec :: Pattern rep -> Exp rep -> ExpDec rep - mkBody :: Stms rep -> Result -> Body rep - mkLetNames :: - (MonadFreshNames m, HasScope rep m) => - [VName] -> - Exp rep -> - m (Stm rep) - --- | A monad that supports the creation of bindings from expressions --- and bodies from bindings, with a specific rep. This is the main --- typeclass that a monad must implement in order for it to be useful --- for generating or modifying Futhark code. Most importantly --- maintains a current state of 'Stms' (as well as a 'Scope') that --- have been added with 'addStm'. --- --- Very important: the methods should not have any significant side --- effects! They may be called more often than you think, and the --- results thrown away. It is acceptable for them to create new --- bindings, however. -class - ( ASTRep (Rep m), - MonadFreshNames m, - Applicative m, - Monad m, - LocalScope (Rep m) m - ) => - MonadBinder m - where - type Rep m :: Data.Kind.Type - mkExpDecM :: Pattern (Rep m) -> Exp (Rep m) -> m (ExpDec (Rep m)) - mkBodyM :: Stms (Rep m) -> Result -> m (Body (Rep m)) - mkLetNamesM :: [VName] -> Exp (Rep m) -> m (Stm (Rep m)) - - -- | Add a statement to the 'Stms' under construction. - addStm :: Stm (Rep m) -> m () - addStm = addStms . oneStm - - -- | Add multiple statements to the 'Stms' under construction. - addStms :: Stms (Rep m) -> m () - - -- | Obtain the statements constructed during a monadic action, - -- instead of adding them to the state. - collectStms :: m a -> m (a, Stms (Rep m)) - - -- | Add the provided certificates to any statements added during - -- execution of the action. - certifying :: Certificates -> m a -> m a - certifying = censorStms . fmap . certify - --- | Apply a function to the statements added by this action. -censorStms :: - MonadBinder m => - (Stms (Rep m) -> Stms (Rep m)) -> - m a -> - m a -censorStms f m = do - (x, stms) <- collectStms m - addStms $ f stms - return x - --- | Add the given attributes to any statements added by this action. -attributing :: MonadBinder m => Attrs -> m a -> m a -attributing attrs = censorStms $ fmap onStm - where - onStm (Let pat aux e) = - Let pat aux {stmAuxAttrs = attrs <> stmAuxAttrs aux} e - --- | Add the certificates and attributes to any statements added by --- this action. -auxing :: MonadBinder m => StmAux anyrep -> m a -> m a -auxing (StmAux cs attrs _) = censorStms $ fmap onStm - where - onStm (Let pat aux e) = - Let pat aux' e - where - aux' = - aux - { stmAuxAttrs = attrs <> stmAuxAttrs aux, - stmAuxCerts = cs <> stmAuxCerts aux - } - --- | Add a statement with the given pattern and expression. -letBind :: - MonadBinder m => - Pattern (Rep m) -> - Exp (Rep m) -> - m () -letBind pat e = - addStm =<< Let pat <$> (defAux <$> mkExpDecM pat e) <*> pure e - --- | Construct a 'Stm' from identifiers for the context- and value --- part of the pattern, as well as the expression. -mkLet :: Bindable rep => [Ident] -> [Ident] -> Exp rep -> Stm rep -mkLet ctx val e = - let pat = mkExpPat ctx val e - dec = mkExpDec pat e - in Let pat (defAux dec) e - --- | Like mkLet, but also take attributes and certificates from the --- given 'StmAux'. -mkLet' :: Bindable rep => [Ident] -> [Ident] -> StmAux a -> Exp rep -> Stm rep -mkLet' ctx val (StmAux cs attrs _) e = - let pat = mkExpPat ctx val e - dec = mkExpDec pat e - in Let pat (StmAux cs attrs dec) e - --- | Add a statement with the given pattern element names and --- expression. -letBindNames :: MonadBinder m => [VName] -> Exp (Rep m) -> m () -letBindNames names e = addStm =<< mkLetNamesM names e - --- | As 'collectStms', but throw away the ordinary result. -collectStms_ :: MonadBinder m => m a -> m (Stms (Rep m)) -collectStms_ = fmap snd . collectStms - --- | Add the statements of the body, then return the body result. -bodyBind :: MonadBinder m => Body (Rep m) -> m [SubExp] -bodyBind (Body _ stms es) = do - addStms stms - return es - --- | Add several bindings at the outermost level of a t'Body'. -insertStms :: Bindable 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 :: Bindable rep => Stm rep -> Body rep -> Body rep -insertStm = insertStms . oneStm diff --git a/src/Futhark/Builder.hs b/src/Futhark/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Builder.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module defines a convenience monad/typeclass for building +-- ASTs. The fundamental building block is 'BuilderT' and its +-- execution functions, but it is usually easier to use 'Builder'. +-- +-- See "Futhark.Construct" for a high-level description. +module Futhark.Builder + ( -- * A concrete @MonadBuilder@ monad. + BuilderT, + runBuilderT, + runBuilderT_, + runBuilderT', + runBuilderT'_, + BuilderOps (..), + Builder, + runBuilder, + runBuilder_, + runBodyBuilder, + + -- * The 'MonadBuilder' typeclass + module Futhark.Builder.Class, + ) +where + +import Control.Arrow (second) +import Control.Monad.Error.Class +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Writer +import qualified Data.Map.Strict as M +import Futhark.Builder.Class +import Futhark.IR + +-- | 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 + mkExpDecB :: + (MonadBuilder m, Rep m ~ rep) => + Pat rep -> + Exp rep -> + m (ExpDec rep) + mkBodyB :: + (MonadBuilder m, Rep m ~ rep) => + Stms rep -> + Result -> + m (Body rep) + mkLetNamesB :: + (MonadBuilder m, Rep m ~ rep) => + [VName] -> + Exp rep -> + m (Stm rep) + + default mkExpDecB :: + (MonadBuilder m, Buildable rep) => + Pat rep -> + Exp rep -> + m (ExpDec rep) + mkExpDecB pat e = return $ mkExpDec pat e + + default mkBodyB :: + (MonadBuilder m, Buildable rep) => + Stms rep -> + Result -> + m (Body rep) + mkBodyB stms res = return $ mkBody stms res + + default mkLetNamesB :: + (MonadBuilder m, Rep m ~ rep, Buildable rep) => + [VName] -> + Exp rep -> + m (Stm rep) + mkLetNamesB = mkLetNames + +-- | A monad transformer that tracks statements and provides a +-- 'MonadBuilder' instance, assuming that the underlying monad provides +-- a name source. In almost all cases, this is what you will use for +-- constructing statements (possibly as part of a larger monad stack). +-- If you find yourself needing to implement 'MonadBuilder' from +-- scratch, then it is likely that you are making a mistake. +newtype BuilderT rep m a = BuilderT (StateT (Stms rep, Scope rep) m a) + deriving (Functor, Monad, Applicative) + +instance MonadTrans (BuilderT rep) where + lift = BuilderT . lift + +-- | The most commonly used binder monad. +type Builder rep = BuilderT rep (State VNameSource) + +instance MonadFreshNames m => MonadFreshNames (BuilderT rep m) where + getNameSource = lift getNameSource + putNameSource = lift . putNameSource + +instance (ASTRep rep, Monad m) => HasScope rep (BuilderT rep m) where + lookupType name = do + t <- BuilderT $ gets $ M.lookup name . snd + case t of + Nothing -> error $ "BuilderT.lookupType: unknown variable " ++ pretty name + Just t' -> return $ typeOf t' + askScope = BuilderT $ gets snd + +instance (ASTRep rep, Monad m) => LocalScope rep (BuilderT rep m) where + localScope types (BuilderT m) = BuilderT $ do + modify $ second (M.union types) + x <- m + modify $ second (`M.difference` types) + return x + +instance + (ASTRep rep, MonadFreshNames m, BuilderOps rep) => + MonadBuilder (BuilderT rep m) + where + type Rep (BuilderT rep m) = rep + mkExpDecM = mkExpDecB + mkBodyM = mkBodyB + mkLetNamesM = mkLetNamesB + + addStms stms = + BuilderT $ + modify $ \(cur_stms, scope) -> + (cur_stms <> stms, scope `M.union` scopeOf stms) + + collectStms m = do + (old_stms, old_scope) <- BuilderT get + BuilderT $ put (mempty, old_scope) + x <- m + (new_stms, _) <- BuilderT get + BuilderT $ put (old_stms, old_scope) + return (x, new_stms) + +-- | Run a binder action given an initial scope, returning a value and +-- the statements added ('addStm') during the action. +runBuilderT :: + MonadFreshNames m => + BuilderT rep m a -> + Scope rep -> + m (a, Stms rep) +runBuilderT (BuilderT m) scope = do + (x, (stms, _)) <- runStateT m (mempty, scope) + return (x, stms) + +-- | Like 'runBuilderT', but return only the statements. +runBuilderT_ :: + MonadFreshNames m => + BuilderT rep m () -> + Scope rep -> + m (Stms rep) +runBuilderT_ m = fmap snd . runBuilderT m + +-- | Like 'runBuilderT', but get the initial scope from the current +-- monad. +runBuilderT' :: + (MonadFreshNames m, HasScope somerep m, SameScope somerep rep) => + BuilderT rep m a -> + m (a, Stms rep) +runBuilderT' m = do + scope <- askScope + runBuilderT m $ castScope scope + +-- | Like 'runBuilderT_', but get the initial scope from the current +-- monad. +runBuilderT'_ :: + (MonadFreshNames m, HasScope somerep m, SameScope somerep rep) => + BuilderT rep m a -> + m (Stms rep) +runBuilderT'_ = fmap snd . runBuilderT' + +-- | Run a binder action, returning a value and the statements added +-- ('addStm') during the action. Assumes that the current monad +-- provides initial scope and name source. +runBuilder :: + (MonadFreshNames m, HasScope somerep m, SameScope somerep rep) => + Builder rep a -> + m (a, Stms rep) +runBuilder m = do + types <- askScope + modifyNameSource $ runState $ runBuilderT m $ castScope types + +-- | Like 'runBuilder', but throw away the result and just return the +-- added statements. +runBuilder_ :: + (MonadFreshNames m, HasScope somerep m, SameScope somerep rep) => + Builder rep a -> + m (Stms rep) +runBuilder_ = fmap snd . runBuilder + +-- | Run a binder that produces a t'Body', and prefix that t'Body' by +-- the statements produced during execution of the action. +runBodyBuilder :: + ( Buildable rep, + MonadFreshNames m, + HasScope somerep m, + SameScope somerep rep + ) => + Builder rep (Body rep) -> + m (Body rep) +runBodyBuilder = fmap (uncurry $ flip insertStms) . runBuilder + +-- Utility instance defintions for MTL classes. These require +-- UndecidableInstances, but save on typing elsewhere. + +mapInner :: + Monad m => + ( m (a, (Stms rep, Scope rep)) -> + m (b, (Stms rep, Scope rep)) + ) -> + BuilderT rep m a -> + BuilderT rep m b +mapInner f (BuilderT m) = BuilderT $ do + s <- get + (x, s') <- lift $ f $ runStateT m s + put s' + return x + +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 + get = BuilderT $ lift get + put = BuilderT . lift . put + +instance MonadWriter w m => MonadWriter w (BuilderT rep m) where + tell = BuilderT . lift . tell + pass = mapInner $ \m -> pass $ do + ((x, f), s) <- m + return ((x, s), f) + listen = mapInner $ \m -> do + ((x, s), y) <- listen m + return ((x, y), s) + +instance MonadError e m => MonadError e (BuilderT rep m) where + throwError = lift . throwError + catchError (BuilderT m) f = + BuilderT $ catchError m $ unBuilder . f + where + unBuilder (BuilderT m') = m' diff --git a/src/Futhark/Builder/Class.hs b/src/Futhark/Builder/Class.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Builder/Class.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module defines a convenience typeclass for creating +-- normalised programs. +-- +-- See "Futhark.Construct" for a high-level description. +module Futhark.Builder.Class + ( Buildable (..), + mkLet, + mkLet', + MonadBuilder (..), + insertStms, + insertStm, + letBind, + letBindNames, + collectStms_, + bodyBind, + attributing, + auxing, + module Futhark.MonadFreshNames, + ) +where + +import qualified Data.Kind +import Futhark.IR +import Futhark.MonadFreshNames + +-- | The class of representations that can be constructed solely from +-- an expression, within some monad. Very important: the methods +-- should not have any significant side effects! They may be called +-- more often than you think, and the results thrown away. If used +-- exclusively within a 'MonadBuilder' instance, it is acceptable for +-- them to create new bindings, however. +class + ( ASTRep rep, + FParamInfo rep ~ DeclType, + LParamInfo rep ~ Type, + RetType rep ~ DeclExtType, + BranchType rep ~ ExtType, + SetType (LetDec rep) + ) => + Buildable rep + where + mkExpPat :: [Ident] -> Exp rep -> Pat rep + mkExpDec :: Pat rep -> Exp rep -> ExpDec rep + mkBody :: Stms rep -> Result -> Body rep + mkLetNames :: + (MonadFreshNames m, HasScope rep m) => + [VName] -> + Exp rep -> + m (Stm rep) + +-- | A monad that supports the creation of bindings from expressions +-- and bodies from bindings, with a specific rep. This is the main +-- typeclass that a monad must implement in order for it to be useful +-- for generating or modifying Futhark code. Most importantly +-- maintains a current state of 'Stms' (as well as a 'Scope') that +-- have been added with 'addStm'. +-- +-- Very important: the methods should not have any significant side +-- effects! They may be called more often than you think, and the +-- results thrown away. It is acceptable for them to create new +-- bindings, however. +class + ( ASTRep (Rep m), + MonadFreshNames m, + Applicative m, + Monad m, + LocalScope (Rep m) m + ) => + MonadBuilder m + where + type Rep m :: Data.Kind.Type + mkExpDecM :: Pat (Rep m) -> Exp (Rep m) -> m (ExpDec (Rep m)) + mkBodyM :: Stms (Rep m) -> Result -> m (Body (Rep m)) + mkLetNamesM :: [VName] -> Exp (Rep m) -> m (Stm (Rep m)) + + -- | Add a statement to the 'Stms' under construction. + addStm :: Stm (Rep m) -> m () + addStm = addStms . oneStm + + -- | Add multiple statements to the 'Stms' under construction. + addStms :: Stms (Rep m) -> m () + + -- | Obtain the statements constructed during a monadic action, + -- instead of adding them to the state. + collectStms :: m a -> m (a, Stms (Rep m)) + + -- | Add the provided certificates to any statements added during + -- execution of the action. + certifying :: Certs -> m a -> m a + certifying = censorStms . fmap . certify + +-- | Apply a function to the statements added by this action. +censorStms :: + MonadBuilder m => + (Stms (Rep m) -> Stms (Rep m)) -> + m a -> + m a +censorStms f m = do + (x, stms) <- collectStms m + addStms $ f stms + return x + +-- | Add the given attributes to any statements added by this action. +attributing :: MonadBuilder m => Attrs -> m a -> m a +attributing attrs = censorStms $ fmap onStm + where + onStm (Let pat aux e) = + Let pat aux {stmAuxAttrs = attrs <> stmAuxAttrs aux} e + +-- | Add the certificates and attributes to any statements added by +-- this action. +auxing :: MonadBuilder m => StmAux anyrep -> m a -> m a +auxing (StmAux cs attrs _) = censorStms $ fmap onStm + where + onStm (Let pat aux e) = + Let pat aux' e + where + aux' = + aux + { stmAuxAttrs = attrs <> stmAuxAttrs aux, + stmAuxCerts = cs <> stmAuxCerts aux + } + +-- | Add a statement with the given pattern and expression. +letBind :: + MonadBuilder m => + Pat (Rep m) -> + Exp (Rep m) -> + m () +letBind pat e = + addStm =<< Let pat <$> (defAux <$> mkExpDecM pat e) <*> pure e + +-- | 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 ids e = + let pat = mkExpPat ids e + dec = mkExpDec pat e + in Let pat (defAux dec) e + +-- | Like mkLet, but also take attributes and certificates from the +-- given 'StmAux'. +mkLet' :: Buildable rep => [Ident] -> StmAux a -> Exp rep -> Stm rep +mkLet' ids (StmAux cs attrs _) e = + let pat = mkExpPat ids e + dec = mkExpDec pat e + in Let pat (StmAux cs attrs dec) e + +-- | Add a statement with the given pattern element names and +-- expression. +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_ = fmap snd . collectStms + +-- | Add the statements of the body, then return the body 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 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 = insertStms . oneStm diff --git a/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs --- a/src/Futhark/CLI/Bench.hs +++ b/src/Futhark/CLI/Bench.hs @@ -230,12 +230,7 @@ cell i | i' * step_size <= cur' = char 9 | otherwise = - char - ( floor - ( ((cur' - (i' -1) * step_size) * num_chars) - / step_size - ) - ) + char (floor (((cur' - (i' -1) * step_size) * num_chars) / step_size)) where i' = fromIntegral i 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 @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | @futhark dataset@ module Futhark.CLI.Dataset (main) where @@ -16,6 +17,7 @@ import Data.Word import qualified Futhark.Data as V import Futhark.Data.Reader (readValues) +import Futhark.Util (convFloat) import Futhark.Util.Options import Language.Futhark.Parser import Language.Futhark.Pretty () @@ -29,7 +31,7 @@ ) import System.Exit import System.IO -import System.Random.PCG (Variate, initialize, uniformR) +import System.Random.PCG (Variate (..), initialize) -- | Run @futhark dataset@. main :: String -> [String] -> IO () @@ -134,6 +136,7 @@ setRangeOption "u16" setu16Range, setRangeOption "u32" setu32Range, setRangeOption "u64" setu64Range, + setRangeOption "f16" setf16Range, setRangeOption "f32" setf32Range, setRangeOption "f64" setf64Range ] @@ -217,6 +220,7 @@ u16Range :: Range Word16, u32Range :: Range Word32, u64Range :: Range Word64, + f16Range :: Range Half, f32Range :: Range Float, f64Range :: Range Double } @@ -247,6 +251,9 @@ setu64Range :: Range Word64 -> RandomConfiguration -> RandomConfiguration setu64Range bounds config = config {u64Range = bounds} +setf16Range :: Range Half -> RandomConfiguration -> RandomConfiguration +setf16Range bounds config = config {f16Range = bounds} + setf32Range :: Range Float -> RandomConfiguration -> RandomConfiguration setf32Range bounds config = config {f32Range = bounds} @@ -266,6 +273,7 @@ (minBound, maxBound) (0.0, 1.0) (0.0, 1.0) + (0.0, 1.0) randomValue :: RandomConfiguration -> V.ValueType -> Word64 -> V.Value randomValue conf (V.ValueType ds t) seed = @@ -278,6 +286,7 @@ V.U16 -> gen u16Range V.U16Value V.U32 -> gen u32Range V.U32Value V.U64 -> gen u64Range V.U64Value + V.F16 -> gen f16Range V.F16Value V.F32 -> gen f32Range V.F32Value V.F64 -> gen f64Range V.F64Value V.Bool -> gen (const (False, True)) V.BoolValue @@ -307,3 +316,12 @@ fill 0 where n = product ds + +-- XXX: The following instance is an orphan. Maybe it could be +-- avoided with some newtype trickery or refactoring, but it's so +-- convenient this way. +instance Variate Half where + uniformR (a, b) g = do + (convFloat :: Float -> Half) <$> uniformR (convFloat a, convFloat b) g + uniform = uniformR (0, 1) + uniformB b = uniformR (0, b) 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 @@ -14,7 +14,7 @@ import Futhark.Actions import qualified Futhark.Analysis.Alias as Alias import Futhark.Analysis.Metrics (OpMetrics) -import Futhark.Compiler.CLI +import Futhark.Compiler.CLI hiding (compilerMain) import Futhark.IR (ASTRep, Op, Prog, pretty) import qualified Futhark.IR.GPU as GPU import qualified Futhark.IR.GPUMem as GPUMem @@ -81,6 +81,7 @@ -- | Nothing is distinct from a empty pipeline - -- it means we don't even run the internaliser. futharkPipeline :: FutharkPipeline, + futharkCompilerMode :: CompilerMode, futharkAction :: UntypedAction, -- | If true, prints programs as raw ASTs instead -- of their prettyprinted form. @@ -138,12 +139,14 @@ FutharkM UntypedPassState ) +type BackendAction rep = FutharkConfig -> CompilerMode -> FilePath -> Action rep + data UntypedAction = SOACSAction (Action SOACS.SOACS) | GPUAction (Action GPU.GPU) - | GPUMemAction (FilePath -> Action GPUMem.GPUMem) - | MCMemAction (FilePath -> Action MCMem.MCMem) - | SeqMemAction (FilePath -> Action SeqMem.SeqMem) + | GPUMemAction (BackendAction GPUMem.GPUMem) + | MCMemAction (BackendAction MCMem.MCMem) + | SeqMemAction (BackendAction SeqMem.SeqMem) | PolyAction ( forall rep. ( ASTRep rep, @@ -153,14 +156,6 @@ Action rep ) -untypedActionName :: UntypedAction -> String -untypedActionName (SOACSAction a) = actionName a -untypedActionName (GPUAction a) = actionName a -untypedActionName (SeqMemAction a) = actionName $ a "" -untypedActionName (GPUMemAction a) = actionName $ a "" -untypedActionName (MCMemAction a) = actionName $ a "" -untypedActionName (PolyAction a) = actionName (a :: Action SOACS.SOACS) - instance Representation UntypedAction where representation (SOACSAction _) = "SOACS" representation (GPUAction _) = "GPU" @@ -170,7 +165,7 @@ representation PolyAction {} = "" newConfig :: Config -newConfig = Config newFutharkConfig (Pipeline []) action False +newConfig = Config newFutharkConfig (Pipeline []) ToExecutable action False where action = PolyAction printAction @@ -404,10 +399,31 @@ "Parse and pretty-print the AST of the given program.", Option [] + ["backend"] + ( ReqArg + ( \arg -> do + action <- case arg of + "c" -> Right $ SeqMemAction compileCAction + "multicore" -> Right $ MCMemAction compileMulticoreAction + "opencl" -> Right $ GPUMemAction compileOpenCLAction + "cuda" -> Right $ GPUMemAction compileCUDAAction + "wasm" -> Right $ SeqMemAction compileCtoWASMAction + "wasm-multicore" -> Right $ MCMemAction compileMulticoreToWASMAction + "python" -> Right $ SeqMemAction compilePythonAction + "pyopencl" -> Right $ GPUMemAction compilePyOpenCLAction + _ -> Left $ error $ "Invalid backend: " <> arg + + Right $ \opts -> opts {futharkAction = action} + ) + "c|multicore|opencl|cuda|python|pyopencl" + ) + "Run this compiler backend on pipeline result.", + Option + [] ["compile-imperative"] ( NoArg $ Right $ \opts -> - opts {futharkAction = SeqMemAction $ const impCodeGenAction} + opts {futharkAction = SeqMemAction $ \_ _ _ -> impCodeGenAction} ) "Translate program into the imperative IL and write it on standard output.", Option @@ -415,7 +431,7 @@ ["compile-imperative-kernels"] ( NoArg $ Right $ \opts -> - opts {futharkAction = GPUMemAction $ const kernelImpCodeGenAction} + opts {futharkAction = GPUMemAction $ \_ _ _ -> kernelImpCodeGenAction} ) "Translate program into the imperative IL with kernels and write it on standard output.", Option @@ -423,26 +439,10 @@ ["compile-imperative-multicore"] ( NoArg $ Right $ \opts -> - opts {futharkAction = MCMemAction $ const multicoreImpCodeGenAction} + opts {futharkAction = MCMemAction $ \_ _ _ -> multicoreImpCodeGenAction} ) "Translate program into the imperative IL with kernels and write it on standard output.", Option - [] - ["compile-opencl"] - ( NoArg $ - Right $ \opts -> - opts {futharkAction = GPUMemAction $ compileOpenCLAction newFutharkConfig ToExecutable} - ) - "Compile the program using the OpenCL backend.", - Option - [] - ["compile-c"] - ( NoArg $ - Right $ \opts -> - opts {futharkAction = SeqMemAction $ compileCAction newFutharkConfig ToExecutable} - ) - "Compile the program using the C backend.", - Option "p" ["print"] (NoArg $ Right $ \opts -> opts {futharkAction = PolyAction printAction}) @@ -453,6 +453,11 @@ (NoArg $ Right $ \opts -> opts {futharkAction = PolyAction printAliasesAction}) "Print the resulting IR with aliases.", Option + [] + ["call-graph"] + (NoArg $ Right $ \opts -> opts {futharkAction = SOACSAction callGraphAction}) + "Print the resulting call graph.", + Option "m" ["metrics"] (NoArg $ Right $ \opts -> opts {futharkAction = PolyAction metricsAction}) @@ -500,9 +505,26 @@ "NAME" ) "Treat this function as an additional entry point.", + Option + [] + ["library"] + (NoArg $ Right $ \opts -> opts {futharkCompilerMode = ToLibrary}) + "Generate a library instead of an executable.", + Option + [] + ["executable"] + (NoArg $ Right $ \opts -> opts {futharkCompilerMode = ToExecutable}) + "Generate an executable instead of a library (set by default).", + Option + [] + ["server"] + (NoArg $ Right $ \opts -> opts {futharkCompilerMode = ToServer}) + "Generate a server executable.", typedPassOption soacsProg Seq firstOrderTransform "f", soacsPassOption fuseSOACs "o", - soacsPassOption inlineFunctions [], + soacsPassOption inlineAggressively [], + soacsPassOption inlineConservatively [], + soacsPassOption removeDeadFunctions [], kernelsPassOption babysitKernels [], kernelsPassOption tileLoops [], kernelsPassOption unstreamGPU [], @@ -528,7 +550,7 @@ "Run the default optimised kernels pipeline" kernelsPipeline [] - ["kernels"], + ["gpu"], pipelineOption getSOACSProg "GPUMem" @@ -536,15 +558,15 @@ "Run the full GPU compilation pipeline" gpuPipeline [] - ["gpu"], + ["gpu-mem"], pipelineOption getSOACSProg - "GPUMem" + "SeqMem" SeqMem "Run the sequential CPU compilation pipeline" sequentialCpuPipeline [] - ["cpu"], + ["seq-mem"], pipelineOption getSOACSProg "MCMem" @@ -552,7 +574,7 @@ "Run the multicore compilation pipeline" multicorePipeline [] - ["multicore"] + ["mc-mem"] ] incVerbosity :: Maybe FilePath -> FutharkConfig -> FutharkConfig @@ -654,8 +676,8 @@ (".fut_soacs", readCore parseSOACS SOACS), (".fut_seq", readCore parseSeq Seq), (".fut_seq_mem", readCore parseSeqMem SeqMem), - (".fut_kernels", readCore parseGPU GPU), - (".fut_kernels_mem", readCore parseGPUMem GPUMem), + (".fut_gpu", readCore parseGPU GPU), + (".fut_gpu_mem", readCore parseGPUMem GPUMem), (".fut_mc", readCore parseMC MC), (".fut_mc_mem", readCore parseMCMem MCMem) ] @@ -677,43 +699,48 @@ (runPolyPass pipeline_config) initial_prog (getFutharkPipeline config) - logMsg $ "Running action " ++ untypedActionName (futharkAction config) case (end_prog, futharkAction config) of (SOACS prog, SOACSAction action) -> - actionProcedure action prog + otherAction action prog (GPU prog, GPUAction action) -> - actionProcedure action prog + otherAction action prog (SeqMem prog, SeqMemAction action) -> - actionProcedure (action base) prog + backendAction prog action (GPUMem prog, GPUMemAction action) -> - actionProcedure (action base) prog + backendAction prog action (MCMem prog, MCMemAction action) -> - actionProcedure (action base) prog + backendAction prog action (SOACS soacs_prog, PolyAction acs) -> - actionProcedure acs soacs_prog + otherAction acs soacs_prog (GPU kernels_prog, PolyAction acs) -> - actionProcedure acs kernels_prog + otherAction acs kernels_prog (MC mc_prog, PolyAction acs) -> - actionProcedure acs mc_prog + otherAction acs mc_prog (Seq seq_prog, PolyAction acs) -> - actionProcedure acs seq_prog + otherAction acs seq_prog (GPUMem mem_prog, PolyAction acs) -> - actionProcedure acs mem_prog + otherAction acs mem_prog (SeqMem mem_prog, PolyAction acs) -> - actionProcedure acs mem_prog + otherAction acs mem_prog (MCMem mem_prog, PolyAction acs) -> - actionProcedure acs mem_prog + otherAction acs mem_prog (_, action) -> externalErrorS $ - "Action " - <> untypedActionName action - <> " expects " + "Action expects " ++ representation action ++ " representation, but got " ++ representation end_prog ++ "." logMsg ("Done." :: String) where + backendAction prog actionf = do + let action = actionf (futharkConfig config) (futharkCompilerMode config) base + otherAction action prog + + otherAction action prog = do + logMsg $ "Running action " ++ actionName action + actionProcedure action prog + pipeline_config = PipelineConfig { pipelineVerbose = fst (futharkVerbose $ futharkConfig config) > NotVerbose, diff --git a/src/Futhark/CLI/Literate.hs b/src/Futhark/CLI/Literate.hs --- a/src/Futhark/CLI/Literate.hs +++ b/src/Futhark/CLI/Literate.hs @@ -14,7 +14,6 @@ import qualified Data.ByteString.Lazy as LBS import Data.Char import Data.Functor -import Data.Hashable (hash) import Data.Int (Int64) import Data.List (foldl', transpose) import qualified Data.Map as M @@ -34,7 +33,7 @@ import Futhark.Test.Values import Futhark.Util ( directoryContents, - hashIntText, + hashText, nubOrd, runProgramWithExitCode, ) @@ -504,36 +503,51 @@ data Env = Env { envImgDir :: FilePath, + -- | Image dir relative to program. + envRelImgDir :: FilePath, envOpts :: Options, envServer :: ScriptServer, - envHash :: Int + envHash :: T.Text } -newFile :: Env -> FilePath -> (FilePath -> ScriptM ()) -> ScriptM FilePath -newFile env template m = do - let fname = - envImgDir env - T.unpack (hashIntText (envHash env)) <> "-" <> template +newFileWorker :: Env -> FilePath -> (FilePath -> ScriptM ()) -> ScriptM (FilePath, FilePath) +newFileWorker env template m = do + let fname_base = T.unpack (envHash env) <> "-" <> template + fname = envImgDir env fname_base + fname_rel = envRelImgDir env fname_base exists <- liftIO $ doesFileExist fname liftIO $ createDirectoryIfMissing True $ envImgDir env when (exists && scriptVerbose (envOpts env) > 0) $ liftIO $ T.hPutStrLn stderr $ "Using existing file: " <> T.pack fname - unless exists $ m fname + unless exists $ do + when (scriptVerbose (envOpts env) > 0) $ + liftIO $ T.hPutStrLn stderr $ "Generating new file: " <> T.pack fname + m fname modify $ \s -> s {stateFiles = S.insert fname $ stateFiles s} - pure fname + pure (fname, fname_rel) +newFile :: Env -> FilePath -> (FilePath -> ScriptM ()) -> ScriptM FilePath +newFile env template m = snd <$> newFileWorker env template m + +newFileContents :: Env -> FilePath -> (FilePath -> ScriptM ()) -> ScriptM T.Text +newFileContents env template m = + liftIO . T.readFile . fst =<< newFileWorker env template m + processDirective :: Env -> Directive -> ScriptM T.Text processDirective env (DirectiveBrief d) = processDirective env d processDirective env (DirectiveCovert d) = processDirective env d processDirective env (DirectiveRes e) = do - v <- either nope pure =<< evalExpToGround literateBuiltin (envServer env) e + result <- + newFileContents env "eval.txt" $ \resultf -> do + v <- either nope pure =<< evalExpToGround literateBuiltin (envServer env) e + liftIO $ T.writeFile resultf $ prettyText v pure $ T.unlines [ "", "```", - prettyText v, + result, "```", "" ] @@ -542,40 +556,38 @@ throwError $ "Cannot show value of type " <> prettyText t -- processDirective env (DirectiveImg e) = do - maybe_v <- evalExpToGround literateBuiltin (envServer env) e - case maybe_v of - Right (ValueAtom v) - | Just bmp <- valueToBMP v -> do - pngfile <- withTempDir $ \dir -> do - let bmpfile = dir "img.bmp" - liftIO $ LBS.writeFile bmpfile bmp - newFile env "img.png" $ \pngfile -> + fmap imgBlock . newFile env "img.png" $ \pngfile -> do + maybe_v <- evalExpToGround literateBuiltin (envServer env) e + case maybe_v of + Right (ValueAtom v) + | Just bmp <- valueToBMP v -> do + withTempDir $ \dir -> do + let bmpfile = dir "img.bmp" + liftIO $ LBS.writeFile bmpfile bmp void $ system "convert" [bmpfile, pngfile] mempty - pure $ imgBlock pngfile - Right v -> - nope $ fmap valueType v - Left t -> - nope t + Right v -> + nope $ fmap valueType v + Left t -> + nope t where nope t = throwError $ "Cannot create image from value of type " <> prettyText t -- processDirective env (DirectivePlot e size) = do - maybe_v <- evalExpToGround literateBuiltin (envServer env) e - case maybe_v of - Right v - | Just vs <- plottable2d v -> do - pngfile <- newFile env "plot.png" $ plotWith [(Nothing, vs)] - pure $ imgBlock pngfile - Right (ValueRecord m) - | Just m' <- traverse plottable2d m -> do - pngfile <- newFile env "plot.png" $ plotWith $ map (first Just) $ M.toList m' - pure $ imgBlock pngfile - Right v -> - throwError $ "Cannot plot value of type " <> prettyText (fmap valueType v) - Left t -> - throwError $ "Cannot plot opaque value of type " <> prettyText t + fmap imgBlock . newFile env "plot.png" $ \pngfile -> do + maybe_v <- evalExpToGround literateBuiltin (envServer env) e + case maybe_v of + Right v + | Just vs <- plottable2d v -> + plotWith [(Nothing, vs)] pngfile + Right (ValueRecord m) + | Just m' <- traverse plottable2d m -> do + plotWith (map (first Just) $ M.toList m') pngfile + Right v -> + throwError $ "Cannot plot value of type " <> prettyText (fmap valueType v) + Left t -> + throwError $ "Cannot plot opaque value of type " <> prettyText t where plottable2d v = do [x, y] <- plottable v @@ -607,16 +619,16 @@ void $ system "gnuplot" [] script -- processDirective env (DirectiveGnuplot e script) = do - maybe_v <- evalExpToGround literateBuiltin (envServer env) e - case maybe_v of - Right (ValueRecord m) - | Just m' <- traverse plottable m -> do - pngfile <- newFile env "plot.png" $ plotWith $ M.toList m' - pure $ imgBlock pngfile - Right v -> - throwError $ "Cannot plot value of type " <> prettyText (fmap valueType v) - Left t -> - throwError $ "Cannot plot opaque value of type " <> prettyText t + fmap imgBlock . newFile env "plot.png" $ \pngfile -> do + maybe_v <- evalExpToGround literateBuiltin (envServer env) e + case maybe_v of + Right (ValueRecord m) + | Just m' <- traverse plottable m -> + plotWith (M.toList m') pngfile + Right v -> + throwError $ "Cannot plot value of type " <> prettyText (fmap valueType v) + Left t -> + throwError $ "Cannot plot opaque value of type " <> prettyText t where plotWith xys pngfile = withGnuplotData [] xys $ \_ sets -> do let script' = @@ -632,12 +644,11 @@ when (format `notElem` ["webm", "gif"]) $ throwError $ "Unknown video format: " <> format - v <- evalExp literateBuiltin (envServer env) e - let nope = - throwError $ - "Cannot produce video from value of type " <> prettyText (fmap scriptValueType v) - - videofile <- newFile env ("video" <.> T.unpack format) $ \videofile -> + fmap (videoBlock params) . newFile env ("video" <.> T.unpack format) $ \videofile -> do + v <- evalExp literateBuiltin (envServer env) e + let nope = + throwError $ + "Cannot produce video from value of type " <> prettyText (fmap scriptValueType v) case v of ValueAtom SValue {} -> do ValueAtom arr <- getExpValue (envServer env) v @@ -659,8 +670,6 @@ onWebM videofile =<< bmpsToVideo dir _ -> nope - - pure $ videoBlock params videofile where framerate = fromMaybe 30 $ videoFPS params format = fromMaybe "webm" $ videoFormat params @@ -742,7 +751,7 @@ "```\n" <> prettyText (pprDirective False directive) <> "\n```\n" _ -> "```\n" <> prettyText (pprDirective True directive) <> "\n```\n" - env' = env {envHash = hash (envHash env, prettyText directive)} + env' = env {envHash = hashText (envHash env <> prettyText directive)} (r, files) <- runScriptM $ processDirective env' directive case r of Left err -> failed prompt err files @@ -873,11 +882,12 @@ T.hPutStrLn stderr err exitFailure proghash <- - either onError (pure . hash) <=< runExceptT $ + either onError pure <=< runExceptT $ system futhark ["hash", prog] mempty let mdfile = fromMaybe (prog `replaceExtension` "md") $ scriptOutput opts - imgdir = dropExtension mdfile <> "-img" + imgdir_rel = dropExtension (takeFileName mdfile) <> "-img" + imgdir = takeDirectory mdfile imgdir_rel run_options = scriptExtraOptions opts cfg = futharkServerCfg ("." dropExtension prog) run_options @@ -887,7 +897,8 @@ { envServer = server, envOpts = opts, envHash = proghash, - envImgDir = imgdir + envImgDir = imgdir, + envRelImgDir = imgdir_rel } (failure, md) <- processScript env script T.writeFile mdfile md diff --git a/src/Futhark/CLI/Misc.hs b/src/Futhark/CLI/Misc.hs --- a/src/Futhark/CLI/Misc.hs +++ b/src/Futhark/CLI/Misc.hs @@ -11,12 +11,11 @@ import Control.Monad.State import qualified Data.ByteString.Lazy as BS import Data.Function (on) -import Data.Hashable (hash) import Data.List (isInfixOf, isPrefixOf, nubBy) import qualified Data.Text.IO as T import Futhark.Compiler import Futhark.Test -import Futhark.Util (hashIntText) +import Futhark.Util (hashText) import Futhark.Util.Options import Futhark.Util.Pretty (prettyText) import System.Environment (getExecutablePath) @@ -43,7 +42,9 @@ case args of [file] -> Just $ do prog <- filter (not . isBuiltin . fst) <$> readUntypedProgramOrDie file - liftIO $ T.putStrLn $ hashIntText $ hash $ prettyText prog + -- The 'map snd' is an attempt to get rid of the file names so + -- they won't affect the hashing. + liftIO $ T.putStrLn $ hashText $ prettyText $ map snd prog _ -> Nothing -- | @futhark dataget@ diff --git a/src/Futhark/CLI/MulticoreWASM.hs b/src/Futhark/CLI/MulticoreWASM.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/MulticoreWASM.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | @futhark wasm-multicore@ +module Futhark.CLI.MulticoreWASM (main) where + +import Futhark.Actions (compileMulticoreToWASMAction) +import Futhark.Compiler.CLI +import Futhark.Passes (multicorePipeline) + +-- | Run @futhark c@ +main :: String -> [String] -> IO () +main = compilerMain + () + [] + "Compile to multicore WASM" + "Generate multicore WASM with the multicore C backend code from optimised Futhark program." + multicorePipeline + $ \fcfg () mode outpath prog -> + actionProcedure (compileMulticoreToWASMAction fcfg mode outpath) prog 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 @@ -47,7 +47,7 @@ -- | Run @futhark repl@. main :: String -> [String] -> IO () -main = mainWithOptions interpreterConfig options "options... [program.fut]" run +main = mainWithOptions () [] "options... [program.fut]" run where run [] _ = Just $ repl Nothing run [prog] _ = Just $ repl $ Just prog @@ -111,25 +111,6 @@ Just 'n' -> return False _ -> confirmQuit -newtype InterpreterConfig = InterpreterConfig {interpreterEntryPoint :: Name} - -interpreterConfig :: InterpreterConfig -interpreterConfig = InterpreterConfig defaultEntryPoint - -options :: [FunOptDescr InterpreterConfig] -options = - [ Option - "e" - ["entry-point"] - ( ReqArg - ( \entry -> Right $ \config -> - config {interpreterEntryPoint = nameFromString entry} - ) - "NAME" - ) - "The entry point to execute." - ] - -- | Representation of breaking at a breakpoint, to allow for -- navigating through the stack frames and such. data Breaking = Breaking @@ -346,9 +327,9 @@ intOp (I.ExtOpError err) = return $ Left err intOp (I.ExtOpTrace w v c) = do - liftIO $ putStrLn $ "Trace at " ++ locStr (srclocOf w) ++ ": " ++ v + liftIO $ putStrLn $ w ++ ": " ++ v c - intOp (I.ExtOpBreak why callstack c) = do + intOp (I.ExtOpBreak w why callstack c) = do s <- get let why' = case why of @@ -361,7 +342,7 @@ -- Are we supposed to respect this breakpoint? when (breakForReason s top why) $ do - liftIO $ putStrLn $ why' <> " at " ++ locStr top + liftIO $ putStrLn $ why' <> " at " ++ locStr w liftIO $ putStrLn $ prettyBreaking breaking liftIO $ putStrLn " to continue." @@ -398,9 +379,9 @@ where intOp (I.ExtOpError err) = return $ Left err intOp (I.ExtOpTrace w v c) = do - liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v + liftIO $ putStrLn $ w ++ ": " ++ v c - intOp (I.ExtOpBreak _ _ c) = c + intOp (I.ExtOpBreak _ _ _ c) = c type Command = T.Text -> FutharkiM () 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 @@ -154,6 +154,6 @@ where intOp (I.ExtOpError err) = return $ Left err intOp (I.ExtOpTrace w v c) = do - liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v + liftIO $ hPutStrLn stderr $ w ++ ": " ++ v c - intOp (I.ExtOpBreak _ _ c) = c + intOp (I.ExtOpBreak _ _ _ c) = c 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 @@ -74,11 +74,12 @@ deriving (Eq, Show) pureTestResults :: IO [TestResult] -> TestM () -pureTestResults m = - mapM_ check =<< liftIO m +pureTestResults m = do + errs <- foldr collectErrors mempty <$> liftIO m + unless (null errs) $ E.throwError $ concat errs where - check Success = pure () - check (Failure err) = E.throwError err + collectErrors Success errs = errs + collectErrors (Failure err) errs = err : errs withProgramServer :: FilePath -> FilePath -> [String] -> (Server -> IO [TestResult]) -> TestM () withProgramServer program runner extra_options f = do @@ -125,11 +126,11 @@ SOACSPipeline -> check ["-s"] KernelsPipeline -> - check ["--kernels"] + check ["--gpu"] SequentialCpuPipeline -> - check ["--cpu"] + check ["--seq-mem"] GpuPipeline -> - check ["--gpu"] + check ["--gpu-mem"] NoPipeline -> check [] where diff --git a/src/Futhark/CLI/WASM.hs b/src/Futhark/CLI/WASM.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/WASM.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | @futhark wasm@ +module Futhark.CLI.WASM (main) where + +import Futhark.Actions (compileCtoWASMAction) +import Futhark.Compiler.CLI +import Futhark.Passes (sequentialCpuPipeline) + +-- | Run @futhark c@ +main :: String -> [String] -> IO () +main = compilerMain + () + [] + "Compile to WASM" + "Generate WASM with the sequential C backend code from optimised Futhark program." + sequentialCpuPipeline + $ \fcfg () mode outpath prog -> + actionProcedure (compileCtoWASMAction fcfg mode outpath) prog 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} @@ -12,7 +13,6 @@ where import Control.Monad -import Data.List (intercalate) import Data.Maybe (catMaybes) import Futhark.CodeGen.Backends.CCUDA.Boilerplate import Futhark.CodeGen.Backends.COpenCL.Boilerplate (commonOptions, sizeLoggingCode) @@ -27,6 +27,7 @@ ) import Futhark.MonadFreshNames import qualified Language.C.Quote.OpenCL as C +import NeatInterpolation (untrimming) -- | Compile the program to C with calls to CUDA. compileProg :: MonadFreshNames m => Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) @@ -76,11 +77,11 @@ ) } cuda_includes = - unlines - [ "#include ", - "#include ", - "#include " - ] + [untrimming| + #include + #include + #include + |] cliOptions :: [Option] cliOptions = @@ -173,7 +174,7 @@ allocateCUDABuffer :: GC.Allocate OpenCL () allocateCUDABuffer mem size tag "device" = - GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_alloc(&ctx->cuda, $exp:size, $exp:tag, &$exp:mem));|] + GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_alloc(&ctx->cuda, (size_t)$exp:size, $exp:tag, &$exp:mem));|] allocateCUDABuffer _ _ _ space = error $ "Cannot allocate in '" ++ space ++ "' memory space." @@ -198,7 +199,7 @@ } |] where - memcpyFun DefaultSpace (Space "device") = ("cuMemcpyDtoH", copyDevToHost) + memcpyFun DefaultSpace (Space "device") = ("cuMemcpyDtoH" :: String, copyDevToHost) memcpyFun (Space "device") DefaultSpace = ("cuMemcpyHtoD", copyHostToDev) memcpyFun (Space "device") (Space "device") = ("cuMemcpy", copyDevToDev) memcpyFun _ _ = @@ -214,7 +215,7 @@ name_realtype <- newVName $ baseString name ++ "_realtype" num_elems <- case vs of ArrayValues vs' -> do - let vs'' = [[C.cinit|$exp:v|] | v <- map GC.compilePrimValue vs'] + let vs'' = [[C.cinit|$exp:v|] | v <- vs'] GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs'')] = {$inits:vs''};|] return $ length vs'' ArrayZeros n -> do @@ -322,11 +323,11 @@ void *$id:args_arr[] = { $inits:args'' }; typename int64_t $id:time_start = 0, $id:time_end = 0; if (ctx->debugging) { - fprintf(ctx->log, "Launching %s with grid size (", $string:(pretty kernel_name)); - $stms:(printSizes [grid_x, grid_y, grid_z]) - fprintf(ctx->log, ") and block size ("); - $stms:(printSizes [block_x, block_y, block_z]) - fprintf(ctx->log, ").\n"); + fprintf(ctx->log, "Launching %s with grid size [%ld, %ld, %ld] and block size [%ld, %ld, %ld]; shared memory: %d bytes.\n", + $string:(pretty kernel_name), + (long int)$exp:grid_x, (long int)$exp:grid_y, (long int)$exp:grid_z, + (long int)$exp:block_x, (long int)$exp:block_y, (long int)$exp:block_z, + (int)$exp:shared_tot); $id:time_start = get_wall_time(); } $items:bef @@ -371,8 +372,3 @@ offset <- newVName "shared_offset" GC.decl [C.cdecl|unsigned int $id:size = $exp:num_bytes;|] return (offset, Just (size, offset)) - - printSizes = - intercalate [[C.cstm|fprintf(ctx->log, ", ");|]] . map printSize - printSize e = - [[C.cstm|fprintf(ctx->log, "%ld", (long int)$exp:e);|]] diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -9,9 +9,9 @@ ) where -import Data.FileEmbed (embedStringFile) import qualified Data.Map as M import Data.Maybe +import qualified Data.Text as T import Futhark.CodeGen.Backends.COpenCL.Boilerplate ( copyDevToDev, copyDevToHost, @@ -25,6 +25,7 @@ ) import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.ImpCode.OpenCL +import Futhark.CodeGen.RTS.C (cudaH, freeListH) import Futhark.Util (chunk, zEncodeString) import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C @@ -54,8 +55,8 @@ -- | Called after most code has been generated to generate the bulk of -- the boilerplate. generateBoilerplate :: - String -> - String -> + T.Text -> + T.Text -> [Name] -> M.Map KernelName KernelSafety -> M.Map Name SizeClass -> @@ -68,8 +69,8 @@ $esc:("#include ") $esc:("#include ") $esc:("typedef CUdeviceptr fl_mem_t;") - $esc:free_list_h - $esc:cuda_h + $esc:(T.unpack freeListH) + $esc:(T.unpack cudaH) const char *cuda_program[] = {$inits:fragments, NULL}; |] @@ -80,11 +81,10 @@ GC.profileReport [C.citem|CUDA_SUCCEED_FATAL(cuda_tally_profiling_records(&ctx->cuda));|] mapM_ GC.profileReport $ costCentreReport $ cost_centres ++ M.keys kernels where - cuda_h = $(embedStringFile "rts/c/cuda.h") - free_list_h = $(embedStringFile "rts/c/free_list.h") fragments = - map (\s -> [C.cinit|$string:s|]) $ - chunk 2000 (cuda_prelude ++ cuda_program) + [ [C.cinit|$string:s|] + | s <- chunk 2000 $ T.unpack $ cuda_prelude <> cuda_program + ] generateSizeFuns :: M.Map Name SizeClass -> GC.CompilerM OpenCL () () generateSizeFuns sizes = do 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 @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} @@ -27,6 +28,7 @@ import Futhark.MonadFreshNames import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C +import NeatInterpolation (untrimming) -- | Compile the program to C with calls to OpenCL. compileProg :: MonadFreshNames m => Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) @@ -81,16 +83,16 @@ GC.opsFatMemory = True } include_opencl_h = - unlines - [ "#define CL_TARGET_OPENCL_VERSION 120", - "#define CL_USE_DEPRECATED_OPENCL_1_2_APIS", - "#ifdef __APPLE__", - "#define CL_SILENCE_DEPRECATION", - "#include ", - "#else", - "#include ", - "#endif" - ] + [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 + |] cliOptions :: [Option] cliOptions = @@ -208,7 +210,7 @@ allocateOpenCLBuffer :: GC.Allocate OpenCL () allocateOpenCLBuffer mem size tag "device" = - GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_alloc(&ctx->opencl, $exp:size, $exp:tag, &$exp:mem));|] + GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_alloc(&ctx->opencl, (size_t)$exp:size, $exp:tag, &$exp:mem));|] allocateOpenCLBuffer _ _ _ space = error $ "Cannot allocate in '" ++ space ++ "' space." @@ -229,7 +231,7 @@ OPENCL_SUCCEED_OR_RETURN( clEnqueueReadBuffer(ctx->opencl.queue, $exp:srcmem, ctx->failure_is_an_option ? CL_FALSE : CL_TRUE, - $exp:srcidx, $exp:nbytes, + (size_t)$exp:srcidx, (size_t)$exp:nbytes, $exp:destmem + $exp:destidx, 0, NULL, $exp:(profilingEvent copyHostToDev))); if (ctx->failure_is_an_option && @@ -242,7 +244,7 @@ if ($exp:nbytes > 0) { OPENCL_SUCCEED_OR_RETURN( clEnqueueWriteBuffer(ctx->opencl.queue, $exp:destmem, CL_TRUE, - $exp:destidx, $exp:nbytes, + (size_t)$exp:destidx, (size_t)$exp:nbytes, $exp:srcmem + $exp:srcidx, 0, NULL, $exp:(profilingEvent copyDevToHost))); } @@ -256,8 +258,8 @@ OPENCL_SUCCEED_OR_RETURN( clEnqueueCopyBuffer(ctx->opencl.queue, $exp:srcmem, $exp:destmem, - $exp:srcidx, $exp:destidx, - $exp:nbytes, + (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->opencl.queue)); @@ -280,7 +282,7 @@ name_realtype <- newVName $ baseString name ++ "_realtype" num_elems <- case vs of ArrayValues vs' -> do - let vs'' = [[C.cinit|$exp:v|] | v <- map GC.compilePrimValue vs'] + let vs'' = [[C.cinit|$exp:v|] | v <- vs'] GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs'')] = {$inits:vs''};|] return $ length vs'' ArrayZeros n -> do @@ -358,7 +360,7 @@ num_bytes' <- GC.compileExp $ unCount num_bytes GC.stm [C.cstm| - OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->$id:name, $int:i, $exp:num_bytes', NULL)); + OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->$id:name, $int:i, (size_t)$exp:num_bytes', NULL)); |] localBytes cur (SharedMemoryKArg num_bytes) = do @@ -380,6 +382,8 @@ time_diff <- newVName "time_diff" local_work_size <- newVName "local_work_size" + let (debug_str, debug_args) = debugPrint global_work_size local_work_size + GC.stm [C.cstm| if ($exp:total_elements != 0) { @@ -387,11 +391,7 @@ const size_t $id:local_work_size[$int:kernel_rank] = {$inits:workgroup_dims'}; typename int64_t $id:time_start = 0, $id:time_end = 0; if (ctx->debugging) { - fprintf(ctx->log, "Launching %s with global work size [", $string:(pretty kernel_name)); - $stms:(printKernelSize global_work_size) - fprintf(ctx->log, "] and local work size ["); - $stms:(printKernelSize local_work_size) - fprintf(ctx->log, "]; local memory parameters sum to %d bytes.\n", (int)$exp:local_bytes); + fprintf(ctx->log, $string:debug_str, $args:debug_args); $id:time_start = get_wall_time(); } OPENCL_SUCCEED_OR_RETURN( @@ -410,16 +410,25 @@ kernel_rank = length kernel_dims kernel_dims = zipWith multExp (map toSize num_workgroups) (map toSize workgroup_dims) kernel_dims' = map toInit kernel_dims - workgroup_dims' = map toInit workgroup_dims + workgroup_dims' = map (toInit . toSize) workgroup_dims total_elements = foldl multExp [C.cexp|1|] kernel_dims toInit e = [C.cinit|$exp:e|] multExp x y = [C.cexp|$exp:x * $exp:y|] toSize e = [C.cexp|(size_t)$exp:e|] - printKernelSize :: VName -> [C.Stm] - printKernelSize work_size = - intercalate [[C.cstm|fprintf(ctx->log, ", ");|]] $ - map (printKernelDim work_size) [0 .. kernel_rank -1] - printKernelDim global_work_size i = - [[C.cstm|fprintf(ctx->log, "%zu", $id:global_work_size[$int:i]);|]] + debugPrint :: VName -> VName -> (String, [C.Exp]) + debugPrint global_work_size local_work_size = + ( "Launching %s with global work size " + ++ dims + ++ " and local work size " + ++ dims + ++ "]; local memory: %d bytes.\n", + [C.cexp|$string:(pretty kernel_name)|] : + map (kernelDim global_work_size) [0 .. kernel_rank -1] + ++ map (kernelDim local_work_size) [0 .. kernel_rank -1] + ++ [[C.cexp|(int)$exp:local_bytes|]] + ) + where + dims = "[" ++ intercalate ", " (replicate kernel_rank "%zu") ++ "]" + kernelDim arr i = [C.cexp|$id:arr[$int:i]|] diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -21,13 +21,14 @@ where import Control.Monad.State -import Data.FileEmbed import qualified Data.Map as M import Data.Maybe +import qualified Data.Text as T import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.ImpCode.OpenCL import Futhark.CodeGen.OpenCL.Heuristics +import Futhark.CodeGen.RTS.C (freeListH, openclH) import Futhark.Util (chunk, zEncodeString) import Futhark.Util.Pretty (prettyOneLine) import qualified Language.C.Quote.OpenCL as C @@ -43,8 +44,8 @@ escapeChar c = [c] in concatMap escapeChar onPart (ErrorString s) = printfEscape s - onPart ErrorInt32 {} = "%lld" - onPart ErrorInt64 {} = "%lld" + -- 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]] @@ -70,8 +71,8 @@ -- | Called after most code has been generated to generate the bulk of -- the boilerplate. generateBoilerplate :: - String -> - String -> + T.Text -> + T.Text -> [Name] -> M.Map KernelName KernelSafety -> [PrimType] -> @@ -82,7 +83,7 @@ final_inits <- GC.contextFinalInits let (ctx_opencl_fields, ctx_opencl_inits, top_decls, later_top_decls) = - openClDecls cost_centres kernels opencl_code opencl_prelude + openClDecls cost_centres kernels (opencl_prelude <> opencl_code) mapM_ GC.earlyDecl top_decls @@ -505,17 +506,18 @@ openClDecls :: [Name] -> M.Map KernelName KernelSafety -> - String -> - String -> + T.Text -> ([C.FieldGroup], [C.Stm], [C.Definition], [C.Definition]) -openClDecls cost_centres kernels opencl_program opencl_prelude = +openClDecls cost_centres kernels opencl_program = (ctx_fields, ctx_inits, openCL_boilerplate, openCL_load) where 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 (opencl_prelude ++ opencl_program)] + [ [C.cinit|$string:s|] + | s <- chunk 2000 $ T.unpack opencl_program + ] ctx_fields = [ [C.csdecl|int total_runs;|], @@ -549,15 +551,12 @@ }|] ] - free_list_h = $(embedStringFile "rts/c/free_list.h") - openCL_h = $(embedStringFile "rts/c/opencl.h") - program_fragments = opencl_program_fragments ++ [[C.cinit|NULL|]] openCL_boilerplate = [C.cunit| $esc:("typedef cl_mem fl_mem_t;") - $esc:free_list_h - $esc:openCL_h + $esc:(T.unpack freeListH) + $esc:(T.unpack openclH) static const char *opencl_program[] = {$inits:program_fragments};|] loadKernel :: (KernelName, KernelSafety) -> C.Stm 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 @@ -46,7 +46,6 @@ compileCode, compileExp, compilePrimExp, - compilePrimValue, compileExpToName, rawMem, item, @@ -85,19 +84,22 @@ import Control.Monad.State import Data.Bifunctor (first) import qualified Data.DList as DL -import Data.FileEmbed import Data.Loc import qualified Data.Map.Strict as M import Data.Maybe +import qualified Data.Text as T import Futhark.CodeGen.Backends.GenericC.CLI (cliDefs) import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.GenericC.Server (serverDefs) import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode +import Futhark.CodeGen.RTS.C (halfH, lockH, timingH, utilH) import Futhark.IR.Prop (isBuiltInFunction) import Futhark.MonadFreshNames +import Futhark.Util.Pretty (prettyText) import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C +import NeatInterpolation (untrimming) -- How public an array type definition sould be. Public types show up -- in the generated API, while private types are used only to @@ -223,16 +225,31 @@ opsCritical :: ([C.BlockItem], [C.BlockItem]) } +errorMsgString :: ErrorMsg Exp -> CompilerM op s (String, [C.Exp]) +errorMsgString (ErrorMsg parts) = do + let boolStr e = [C.cexp|($exp:e) ? "true" : "false"|] + asLongLong e = [C.cexp|(long long int)$exp:e|] + asDouble e = [C.cexp|(double)$exp:e|] + onPart (ErrorString s) = return ("%s", [C.cexp|$string:s|]) + onPart (ErrorVal Bool x) = ("%s",) . boolStr <$> compileExp x + onPart (ErrorVal Unit _) = pure ("%s", [C.cexp|"()"|]) + onPart (ErrorVal (IntType Int8) x) = ("%hhd",) <$> compileExp x + onPart (ErrorVal (IntType Int16) x) = ("%hd",) <$> compileExp x + onPart (ErrorVal (IntType Int32) x) = ("%d",) <$> compileExp x + onPart (ErrorVal (IntType Int64) x) = ("%lld",) . asLongLong <$> compileExp x + onPart (ErrorVal (FloatType Float16) x) = ("%f",) . asDouble <$> compileExp x + onPart (ErrorVal (FloatType Float32) x) = ("%f",) . asDouble <$> compileExp x + onPart (ErrorVal (FloatType Float64) x) = ("%f",) <$> compileExp x + (formatstrs, formatargs) <- unzip <$> mapM onPart parts + pure (mconcat formatstrs, formatargs) + defError :: ErrorCompiler op s -defError (ErrorMsg parts) stacktrace = do +defError msg stacktrace = do free_all_mem <- collect $ mapM_ (uncurry unRefMem) =<< gets compDeclaredMem - let onPart (ErrorString s) = return ("%s", [C.cexp|$string:s|]) - onPart (ErrorInt32 x) = ("%d",) <$> compileExp x - onPart (ErrorInt64 x) = ("%lld",) <$> compileExp x - (formatstrs, formatargs) <- unzip <$> mapM onPart parts - let formatstr = "Error: " ++ concat formatstrs ++ "\n\nBacktrace:\n%s" + (formatstr, formatargs) <- errorMsgString msg + let formatstr' = "Error: " <> formatstr <> "\n\nBacktrace:\n%s" items - [C.citems|ctx->error = msgprintf($string:formatstr, $args:formatargs, $string:stacktrace); + [C.citems|ctx->error = msgprintf($string:formatstr', $args:formatargs, $string:stacktrace); $items:free_all_mem return 1;|] @@ -326,18 +343,27 @@ envFatMemory :: CompilerEnv op s -> Bool envFatMemory = opsFatMemory . envOperations -initDecls, arrayDecls, opaqueDecls, entryDecls, miscDecls :: CompilerState s -> [C.Definition] -initDecls = concatMap (DL.toList . snd) . filter ((== InitDecl) . fst) . M.toList . compHeaderDecls -arrayDecls = concatMap (DL.toList . snd) . filter (isArrayDecl . fst) . M.toList . compHeaderDecls +declsCode :: (HeaderSection -> Bool) -> CompilerState s -> T.Text +declsCode p = + T.unlines + . map prettyText + . concatMap (DL.toList . snd) + . filter (p . fst) + . M.toList + . compHeaderDecls + +initDecls, arrayDecls, opaqueDecls, entryDecls, miscDecls :: CompilerState s -> T.Text +initDecls = declsCode (== InitDecl) +arrayDecls = declsCode isArrayDecl where isArrayDecl ArrayDecl {} = True isArrayDecl _ = False -opaqueDecls = concatMap (DL.toList . snd) . filter (isOpaqueDecl . fst) . M.toList . compHeaderDecls +opaqueDecls = declsCode isOpaqueDecl where isOpaqueDecl OpaqueDecl {} = True isOpaqueDecl _ = False -entryDecls = concatMap (DL.toList . snd) . filter ((== EntryDecl) . fst) . M.toList . compHeaderDecls -miscDecls = concatMap (DL.toList . snd) . filter ((== MiscDecl) . fst) . M.toList . compHeaderDecls +entryDecls = declsCode (== EntryDecl) +miscDecls = declsCode (== MiscDecl) contextContents :: CompilerM op s ([C.FieldGroup], [C.Stm]) contextContents = do @@ -567,7 +593,7 @@ <*> pure [C.cexp|$exp:desc|] <*> pure sid _ -> - stm [C.cstm|$exp:dest = (char*) malloc($exp:size);|] + stm [C.cstm|$exp:dest = (unsigned char*) malloc((size_t)$exp:size);|] freeRawMem :: (C.ToExp a, C.ToExp b) => @@ -783,9 +809,11 @@ CompilerM op s () copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes = stm - [C.cstm|memmove($exp:destmem + $exp:destidx, + [C.cstm|if ($exp:nbytes > 0) { + memmove($exp:destmem + $exp:destidx, $exp:srcmem + $exp:srcidx, - $exp:nbytes);|] + $exp:nbytes); + }|] --- Entry points. @@ -806,7 +834,7 @@ Int -> CompilerM op s [C.Definition] arrayLibraryFunctions pub space pt signed rank = do - let pt' = signedPrimTypeToCType signed pt + let pt' = primAPIType signed pt name = arrayName pt signed rank arr_name = "futhark_" ++ name array_type = [C.cty|struct $id:arr_name|] @@ -830,7 +858,7 @@ resetMem [C.cexp|arr->mem|] space allocMem [C.cexp|arr->mem|] - [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|] + [C.cexp|$exp:arr_size * $int:(primByteSize pt::Int)|] space [C.cstm|return NULL;|] forM_ [0 .. rank -1] $ \i -> @@ -884,7 +912,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, int offset, $params:shape_params);|] + [C.cedecl|$ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, const $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 @@ -906,7 +934,7 @@ return arr; } - $ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, const $ty:memty data, int offset, + $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* bad = NULL; $ty:array_type *arr = ($ty:array_type*) malloc(sizeof($ty:array_type)); @@ -1082,7 +1110,7 @@ valueDescToCType :: Publicness -> ValueDesc -> CompilerM op s C.Type valueDescToCType _ (ScalarValue pt signed _) = - return $ signedPrimTypeToCType signed pt + return $ primAPIType signed pt valueDescToCType pub (ArrayValue _ space pt signed shape) = do let rank = length shape name <- publicName $ arrayName pt signed rank @@ -1130,7 +1158,7 @@ prepareEntryInputs :: [ExternalValue] -> - CompilerM op s ([(C.Param, C.Exp)], [C.BlockItem]) + CompilerM op s ([(C.Param, Maybe C.Exp)], [C.BlockItem]) prepareEntryInputs args = collect' $ zipWithM prepare [(0 :: Int) ..] args where arg_names = namesFromList $ concatMap evNames args @@ -1144,7 +1172,7 @@ (ty, check) <- prepareValue Public [C.cexp|$id:pname|] vd return ( [C.cparam|const $ty:ty $id:pname|], - allTrue check + if null check then Nothing else Just $ allTrue check ) prepare pno (OpaqueValue _ desc vds) = do ty <- opaqueToCType desc vds @@ -1154,12 +1182,15 @@ checks <- map snd <$> zipWithM (prepareValue Private) (zipWith field [0 ..] vds) vds return ( [C.cparam|const $ty:ty *$id:pname|], - allTrue $ concat checks + if null $ concat checks + then Nothing + else Just $ allTrue $ concat checks ) prepareValue _ src (ScalarValue pt signed name) = do - let pt' = signedPrimTypeToCType signed pt - stm [C.cstm|$id:name = $exp:src;|] + let pt' = primAPIType signed pt + src' = fromStorage pt $ C.toExp src mempty + stm [C.cstm|$id:name = $exp:src';|] return (pt', []) prepareValue pub src vd@(ArrayValue mem _ _ _ shape) = do ty <- valueDescToCType pub vd @@ -1214,8 +1245,9 @@ return [C.cparam|$ty:ty **$id:pname|] - prepareValue dest (ScalarValue _ _ name) = - stm [C.cstm|$exp:dest = $id:name;|] + prepareValue dest (ScalarValue t _ name) = + let name' = toStorage t $ C.toExp name mempty + in stm [C.cstm|$exp:dest = $exp:name';|] prepareValue dest (ArrayValue mem _ _ _ shape) = do stm [C.cstm|$exp:dest->mem = $id:mem;|] @@ -1256,18 +1288,25 @@ $params:entry_point_output_params, $params:entry_point_input_params);|] - let critical = - [C.citems| - $items:unpack_entry_inputs - - if (!($exp:(allTrue entry_point_input_checks))) { + let checks = catMaybes entry_point_input_checks + check_input = + if null checks + then [] + else + [C.citems| + if (!($exp:(allTrue (catMaybes entry_point_input_checks)))) { ret = 1; if (!ctx->error) { ctx->error = msgprintf("Error: entry point arguments have invalid sizes.\n"); } - } else { - ret = $id:(funName fname)(ctx, $args:out_args, $args:in_args); + }|] + critical = + [C.citems| + $items:unpack_entry_inputs + $items:check_input + if (ret == 0) { + ret = $id:(funName fname)(ctx, $args:out_args, $args:in_args); if (ret == 0) { $items:get_consts @@ -1305,26 +1344,25 @@ -- all of them, which yields a CLI program. Another is to compile the -- library part by itself, and use the header file to call into it. data CParts = CParts - { cHeader :: String, + { cHeader :: T.Text, -- | Utility definitions that must be visible -- to both CLI and library parts. - cUtils :: String, - cCLI :: String, - cServer :: String, - cLib :: String + cUtils :: T.Text, + cCLI :: T.Text, + cServer :: T.Text, + cLib :: T.Text } -gnuSource :: String +gnuSource :: T.Text gnuSource = - pretty - [C.cunit| + [untrimming| // We need to define _GNU_SOURCE before // _any_ headers files are imported to get // the usage statistics of a thread (i.e. have RUSAGE_THREAD) on GNU/Linux // https://manpages.courier-mta.org/htmlman2/getrusage.2.html -$esc:("#ifndef _GNU_SOURCE") // Avoid possible double-definition warning. -$esc:("#define _GNU_SOURCE") -$esc:("#endif") +#ifndef _GNU_SOURCE // Avoid possible double-definition warning. +#define _GNU_SOURCE +#endif |] -- We may generate variables that are never used (e.g. for @@ -1332,39 +1370,37 @@ -- intrinsics), and generated code may have other cosmetic issues that -- compilers warn about. We disable these warnings to not clutter the -- compilation logs. -disableWarnings :: String +disableWarnings :: T.Text disableWarnings = - pretty - [C.cunit| -$esc:("#ifdef __clang__") -$esc:("#pragma clang diagnostic ignored \"-Wunused-function\"") -$esc:("#pragma clang diagnostic ignored \"-Wunused-variable\"") -$esc:("#pragma clang diagnostic ignored \"-Wparentheses\"") -$esc:("#pragma clang diagnostic ignored \"-Wunused-label\"") -$esc:("#elif __GNUC__") -$esc:("#pragma GCC diagnostic ignored \"-Wunused-function\"") -$esc:("#pragma GCC diagnostic ignored \"-Wunused-variable\"") -$esc:("#pragma GCC diagnostic ignored \"-Wparentheses\"") -$esc:("#pragma GCC diagnostic ignored \"-Wunused-label\"") -$esc:("#pragma GCC diagnostic ignored \"-Wunused-but-set-variable\"") -$esc:("#endif") - + [untrimming| +#ifdef __clang__ +#pragma clang diagnostic ignored "-Wunused-function" +#pragma clang diagnostic ignored "-Wunused-variable" +#pragma clang diagnostic ignored "-Wparentheses" +#pragma clang diagnostic ignored "-Wunused-label" +#elif __GNUC__ +#pragma GCC diagnostic ignored "-Wunused-function" +#pragma GCC diagnostic ignored "-Wunused-variable" +#pragma GCC diagnostic ignored "-Wparentheses" +#pragma GCC diagnostic ignored "-Wunused-label" +#pragma GCC diagnostic ignored "-Wunused-but-set-variable" +#endif |] -- | Produce header and implementation files. -asLibrary :: CParts -> (String, String) +asLibrary :: CParts -> (T.Text, T.Text) asLibrary parts = ( "#pragma once\n\n" <> cHeader parts, gnuSource <> disableWarnings <> cHeader parts <> cUtils parts <> cLib parts ) -- | As executable with command-line interface. -asExecutable :: CParts -> String +asExecutable :: CParts -> T.Text asExecutable parts = gnuSource <> disableWarnings <> cHeader parts <> cUtils parts <> cCLI parts <> cLib parts -- | As server executable. -asServer :: CParts -> String +asServer :: CParts -> T.Text asServer parts = gnuSource <> disableWarnings <> cHeader parts <> cUtils parts <> cServer parts <> cLib parts @@ -1372,10 +1408,10 @@ -- function named "main" as entry point, so make sure it is defined. compileProg :: MonadFreshNames m => - String -> + T.Text -> Operations op () -> CompilerM op () () -> - String -> + T.Text -> [Space] -> [Option] -> Definitions op -> @@ -1384,98 +1420,105 @@ src <- getNameSource let ((prototypes, definitions, entry_point_decls), endstate) = runCompilerM ops src () compileProg' + initdecls = initDecls endstate + entrydecls = entryDecls endstate + arraydecls = arrayDecls endstate + opaquedecls = opaqueDecls endstate + miscdecls = miscDecls endstate let headerdefs = - [C.cunit| -$esc:("// Headers\n") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") -$esc:(header_extra) - -$esc:("#ifdef __cplusplus") -$esc:("extern \"C\" {") -$esc:("#endif") + [untrimming| +// Headers\n") +#include +#include +#include +#include +#include +$header_extra +#ifdef __cplusplus +extern "C" { +#endif -$esc:("\n// Initialisation\n") -$edecls:(initDecls endstate) +// Initialisation +$initdecls -$esc:("\n// Arrays\n") -$edecls:(arrayDecls endstate) +// Arrays +$arraydecls -$esc:("\n// Opaque values\n") -$edecls:(opaqueDecls endstate) +// Opaque values +$opaquedecls -$esc:("\n// Entry points\n") -$edecls:(entryDecls endstate) +// Entry points +$entrydecls -$esc:("\n// Miscellaneous\n") -$edecls:(miscDecls endstate) -$esc:("#define FUTHARK_BACKEND_"++backend) +// Miscellaneous +$miscdecls +#define FUTHARK_BACKEND_$backend -$esc:("#ifdef __cplusplus") -$esc:("}") -$esc:("#endif") - |] +#ifdef __cplusplus +} +#endif +|] let utildefs = - [C.cunit| -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") + [untrimming| +#include +#include +#include +#include +#include // If NDEBUG is set, the assert() macro will do nothing. Since Futhark // (unfortunately) makes use of assert() for error detection (and even some // side effects), we want to avoid that. -$esc:("#undef NDEBUG") -$esc:("#include ") -$esc:("#include ") - -$esc:util_h - -$esc:timing_h +#undef NDEBUG +#include +#include +$utilH +$halfH +$timingH |] - let early_decls = DL.toList $ compEarlyDecls endstate - let lib_decls = DL.toList $ compLibDecls endstate - let clidefs = cliDefs options $ Functions entry_funs - let serverdefs = serverDefs options $ Functions entry_funs - let libdefs = - [C.cunit| -$esc:("#ifdef _MSC_VER\n#define inline __inline\n#endif") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") -$esc:("#include ") + let early_decls = T.unlines $ map prettyText $ DL.toList $ compEarlyDecls endstate + lib_decls = T.unlines $ map prettyText $ DL.toList $ compLibDecls endstate + clidefs = cliDefs options $ Functions entry_funs + serverdefs = serverDefs options $ Functions entry_funs + libdefs = + [untrimming| +#ifdef _MSC_VER +#define inline __inline +#endif +#include +#include +#include +#include +#include -$esc:header_extra +$header_extra -$esc:lock_h +$lockH -$edecls:builtin +#define FUTHARK_F64_ENABLED -$edecls:early_decls +$cScalarDefs -$edecls:prototypes +$early_decls -$edecls:lib_decls +$prototypes -$edecls:definitions +$lib_decls -$edecls:entry_point_decls +$definitions + +$entry_point_decls |] - return $ + return CParts - { cHeader = pretty headerdefs, - cUtils = pretty utildefs, - cCLI = pretty clidefs, - cServer = pretty serverdefs, - cLib = pretty libdefs + { cHeader = headerdefs, + cUtils = utildefs, + cCLI = clidefs, + cServer = serverdefs, + cLib = libdefs } where Definitions consts (Functions funs) = prog @@ -1501,7 +1544,11 @@ commonLibFuns memreport - return (prototypes, map funcToDef functions, entry_points) + return + ( T.unlines $ map prettyText prototypes, + T.unlines $ map (prettyText . funcToDef) functions, + T.unlines $ map prettyText entry_points + ) funcToDef func = C.FuncDef func loc where @@ -1509,15 +1556,6 @@ C.OldFunc _ _ _ _ _ _ l -> l C.Func _ _ _ _ _ l -> l - builtin = - cIntOps ++ cFloat32Ops ++ cFloat64Ops ++ cFloatConvOps - ++ cFloat32Funs - ++ cFloat64Funs - - util_h = $(embedStringFile "rts/c/util.h") - timing_h = $(embedStringFile "rts/c/timing.h") - lock_h = $(embedStringFile "rts/c/lock.h") - commonLibFuns :: [C.BlockItem] -> CompilerM op s () commonLibFuns memreport = do generateAPITypes @@ -1748,33 +1786,6 @@ p_name <- newVName $ baseString name ++ "_p" return ([C.cparam|$ty:ty *$id:p_name|], [C.cexp|$id:p_name|]) -compilePrimValue :: PrimValue -> C.Exp -compilePrimValue (IntValue (Int8Value k)) = [C.cexp|(typename int8_t)$int:k|] -compilePrimValue (IntValue (Int16Value k)) = [C.cexp|(typename int16_t)$int:k|] -compilePrimValue (IntValue (Int32Value k)) = [C.cexp|$int:k|] -compilePrimValue (IntValue (Int64Value k)) = [C.cexp|(typename int64_t)$int:k|] -compilePrimValue (FloatValue (Float64Value x)) - | isInfinite x = - if x > 0 then [C.cexp|INFINITY|] else [C.cexp|-INFINITY|] - | isNaN x = - [C.cexp|NAN|] - | otherwise = - [C.cexp|$double:x|] -compilePrimValue (FloatValue (Float32Value x)) - | isInfinite x = - if x > 0 then [C.cexp|INFINITY|] else [C.cexp|-INFINITY|] - | isNaN x = - [C.cexp|NAN|] - | otherwise = - [C.cexp|$float:x|] -compilePrimValue (BoolValue b) = - [C.cexp|$int:b'|] - where - b' :: Int - b' = if b then 1 else 0 -compilePrimValue UnitValue = - [C.cexp|0|] - derefPointer :: C.Exp -> C.Exp -> C.Type -> C.Exp derefPointer ptr i res_t = [C.cexp|(($ty:res_t)$exp:ptr)[$exp:i]|] @@ -1815,18 +1826,19 @@ compileLeaf (ScalarVar src) = return [C.cexp|$id:src|] compileLeaf (Index _ _ Unit __ _) = - return $ compilePrimValue UnitValue + pure $ C.toExp UnitValue mempty compileLeaf (Index src (Count iexp) restype DefaultSpace vol) = do src' <- rawMem src - derefPointer src' - <$> compileExp (untyped iexp) - <*> pure [C.cty|$tyquals:(volQuals vol) $ty:(primTypeToCType restype)*|] + fmap (fromStorage restype) $ + derefPointer src' + <$> compileExp (untyped iexp) + <*> pure [C.cty|$tyquals:(volQuals vol) $ty:(primStorageType restype)*|] compileLeaf (Index src (Count iexp) restype (Space space) vol) = - join $ + fmap (fromStorage restype) . join $ asks envReadScalar <*> rawMem src <*> compileExp (untyped iexp) - <*> pure (primTypeToCType restype) + <*> pure (primStorageType restype) <*> pure space <*> pure vol compileLeaf (Index src (Count iexp) _ ScalarSpace {} _) = do @@ -1836,7 +1848,7 @@ -- | 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 _ (ValueExp val) = - return $ compilePrimValue val + pure $ C.toExp val mempty compilePrimExp f (LeafExp v _) = f v compilePrimExp f (UnOpExp Complement {} x) = do @@ -1845,9 +1857,6 @@ compilePrimExp f (UnOpExp Not {} x) = do x' <- compilePrimExp f x return [C.cexp|!$exp:x'|] -compilePrimExp f (UnOpExp Abs {} x) = do - x' <- compilePrimExp f x - return [C.cexp|abs($exp:x')|] compilePrimExp f (UnOpExp (FAbs Float32) x) = do x' <- compilePrimExp f x return [C.cexp|(float)fabs($exp:x')|] @@ -1860,12 +1869,9 @@ compilePrimExp f (UnOpExp USignum {} x) = do x' <- compilePrimExp f x return [C.cexp|($exp:x' > 0) - ($exp:x' < 0) != 0|] -compilePrimExp f (UnOpExp (FSignum Float32) x) = do - x' <- compilePrimExp f x - return [C.cexp|fsignum32($exp:x')|] -compilePrimExp f (UnOpExp (FSignum Float64) x) = do +compilePrimExp f (UnOpExp op x) = do x' <- compilePrimExp f x - return [C.cexp|fsignum32($exp:x')|] + return [C.cexp|$id:(pretty op)($exp:x')|] compilePrimExp f (CmpOpExp cmp x y) = do x' <- compilePrimExp f x y' <- compilePrimExp f y @@ -1898,7 +1904,6 @@ Xor {} -> [C.cexp|$exp:x' ^ $exp:y'|] And {} -> [C.cexp|$exp:x' & $exp:y'|] Or {} -> [C.cexp|$exp:x' | $exp:y'|] - Shl {} -> [C.cexp|$exp:x' << $exp:y'|] LogAnd {} -> [C.cexp|$exp:x' && $exp:y'|] LogOr {} -> [C.cexp|$exp:x' || $exp:y'|] _ -> [C.cexp|$id:(pretty bop)($exp:x', $exp:y')|] @@ -1924,6 +1929,9 @@ [C.cstm|$comment:comment { $items:xs } |] +compileCode (TracePrint msg) = do + (formatstr, formatargs) <- errorMsgString msg + stm [C.cstm|fprintf(ctx->log, $string:formatstr, $args:formatargs);|] compileCode (DebugPrint s (Just e)) = do e' <- compileExp e stm @@ -1956,9 +1964,8 @@ compileCode (Assert e msg (loc, locs)) = do e' <- compileExp e err <- - collect $ - join $ - asks (opsError . envOperations) <*> pure msg <*> pure stacktrace + collect . join $ + asks (opsError . envOperations) <*> pure msg <*> pure stacktrace stm [C.cstm|if (!$exp:e') { $items:err }|] where stacktrace = prettyStacktrace 0 $ map locStr $ loc : locs @@ -2033,8 +2040,8 @@ deref <- derefPointer dest' <$> compileExp (untyped idx) - <*> pure [C.cty|$tyquals:(volQuals vol) $ty:(primTypeToCType elemtype)*|] - elemexp' <- compileExp elemexp + <*> 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 idx' <- compileExp (untyped idx) @@ -2045,10 +2052,10 @@ asks envWriteScalar <*> rawMem dest <*> compileExp (untyped idx) - <*> pure (primTypeToCType elemtype) + <*> pure (primStorageType elemtype) <*> pure space <*> pure vol - <*> compileExp elemexp + <*> (toStorage elemtype <$> compileExp elemexp) compileCode (DeclareMem name space) = declMem name space compileCode (DeclareScalar name vol t) = do @@ -2061,7 +2068,7 @@ let ct = primTypeToCType t case vs of ArrayValues vs' -> do - let vs'' = [[C.cinit|$exp:(compilePrimValue v)|] | v <- vs'] + let vs'' = [[C.cinit|$exp:v|] | v <- vs'] earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs')] = {$inits:vs''};|] ArrayZeros n -> earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] diff --git a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs --- a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs @@ -12,12 +12,14 @@ ) where -import Data.FileEmbed import Data.List (unzip5) import Data.Maybe +import qualified Data.Text as T import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode +import Futhark.CodeGen.RTS.C (tuningH, valuesH) +import Futhark.Util.Pretty (prettyText) import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C @@ -105,7 +107,7 @@ int value = atoi(value_str); if (equals != NULL) { *equals = 0; - if (futhark_context_config_set_size(cfg, name, value) != 0) { + if (futhark_context_config_set_size(cfg, name, (size_t)value) != 0) { futhark_panic(1, "Unknown size: %s\n", name); } } else { @@ -145,7 +147,7 @@ valueDescToCType :: ValueDesc -> C.Type valueDescToCType (ScalarValue pt signed _) = - signedPrimTypeToCType signed pt + primAPIType signed pt valueDescToCType (ArrayValue _ _ pt signed shape) = let name = "futhark_" ++ arrayName pt signed (length shape) in [C.cty|struct $id:name|] @@ -169,6 +171,7 @@ (Int16, _) -> [C.cexp|i16_info|] (Int32, _) -> [C.cexp|i32_info|] (Int64, _) -> [C.cexp|i64_info|] +primTypeInfo (FloatType Float16) _ = [C.cexp|f16_info|] primTypeInfo (FloatType Float32) _ = [C.cexp|f32_info|] primTypeInfo (FloatType Float64) _ = [C.cexp|f64_info|] primTypeInfo Bool _ = [C.cexp|bool_info|] @@ -193,12 +196,12 @@ ) readInput i (TransparentValue _ (ScalarValue t ept _)) = let dest = "read_value_" ++ show i - in ( [C.citems|$ty:(primTypeToCType t) $id:dest; + in ( [C.citems|$ty:(primStorageType t) $id:dest; $stm:(readPrimStm dest i t ept);|], [C.cstm|;|], [C.cstm|;|], [C.cstm|;|], - [C.cexp|$id:dest|] + fromStorage t [C.cexp|$id:dest|] ) readInput i (TransparentValue _ (ArrayValue _ _ t ept dims)) = let dest = "read_value_" ++ show i @@ -211,7 +214,7 @@ rank = length dims dims_exps = [[C.cexp|$id:shape[$int:j]|] | j <- [0 .. rank -1]] dims_s = concat $ replicate rank "[]" - t' = signedPrimTypeToCType ept t + t' = primAPIType ept t new_array = "futhark_new_" ++ name free_array = "futhark_free_" ++ name @@ -295,7 +298,7 @@ }|] where rank = length shape - bt' = primTypeToCType bt + bt' = primStorageType bt name = arrayName bt ept rank printResult :: [(ExternalValue, C.Exp)] -> [C.Stm] @@ -304,10 +307,8 @@ f (v, e) = [printStm v e, [C.cstm|printf("\n");|]] cliEntryPoint :: - Name -> - FunctionT a -> - Maybe (C.Definition, C.Initializer) -cliEntryPoint fname fun@(Function _ _ _ _ results args) = do + FunctionT a -> Maybe (C.Definition, C.Initializer) +cliEntryPoint fun@(Function _ _ _ _ results args) = do entry_point_name <- nameToString <$> functionEntry fun let (input_items, pack_input, free_input, free_parsed, input_args) = unzip5 $ readInputs args @@ -376,7 +377,7 @@ $items:(mconcat input_items) if (end_of_input(stdin) != 0) { - futhark_panic(1, "Expected EOF on stdin after reading input for %s.\n", $string:(quote (pretty fname))); + futhark_panic(1, "Expected EOF on stdin after reading input for \"%s\".\n", $string:(pretty entry_point_name)); } $items:output_decls @@ -415,21 +416,19 @@ {-# NOINLINE cliDefs #-} -- | Generate Futhark standalone executable code. -cliDefs :: [Option] -> Functions a -> [C.Definition] +cliDefs :: [Option] -> Functions a -> T.Text cliDefs options (Functions funs) = - let values_h = $(embedStringFile "rts/c/values.h") - tuning_h = $(embedStringFile "rts/c/tuning.h") - - option_parser = + let option_parser = generateOptionParser "parse_options" $ genericOptions ++ options (cli_entry_point_decls, entry_point_inits) = - unzip $ mapMaybe (uncurry cliEntryPoint) funs - in [C.cunit| + unzip $ mapMaybe (cliEntryPoint . snd) funs + in prettyText + [C.cunit| $esc:("#include ") $esc:("#include ") $esc:("#include ") -$esc:values_h +$esc:(T.unpack valuesH) static int binary_output = 0; static typename FILE *runtime_file; @@ -438,7 +437,7 @@ // If the entry point is NULL, the program will terminate after doing initialisation and such. static const char *entry_point = "main"; -$esc:tuning_h +$esc:(T.unpack tuningH) $func:option_parser diff --git a/src/Futhark/CodeGen/Backends/GenericC/Server.hs b/src/Futhark/CodeGen/Backends/GenericC/Server.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Server.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Server.hs @@ -13,12 +13,14 @@ where import Data.Bifunctor (first, second) -import Data.FileEmbed import qualified Data.Map as M import Data.Maybe +import qualified Data.Text as T import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode +import Futhark.CodeGen.RTS.C (serverH, tuningH, valuesH) +import Futhark.Util.Pretty (prettyText) import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C @@ -275,16 +277,14 @@ {-# NOINLINE serverDefs #-} -- | Generate Futhark server executable code. -serverDefs :: [Option] -> Functions a -> [C.Definition] +serverDefs :: [Option] -> Functions a -> T.Text serverDefs options funs = - let server_h = $(embedStringFile "rts/c/server.h") - values_h = $(embedStringFile "rts/c/values.h") - tuning_h = $(embedStringFile "rts/c/tuning.h") - option_parser = + let option_parser = generateOptionParser "parse_options" $ genericOptions ++ options (boilerplate_defs, type_inits, entry_point_inits) = mkBoilerplate funs - in [C.cunit| + in prettyText + [C.cunit| $esc:("#include ") $esc:("#include ") $esc:("#include ") @@ -292,9 +292,9 @@ // If the entry point is NULL, the program will terminate after doing initialisation and such. It is not used for anything else in server mode. static const char *entry_point = "main"; -$esc:values_h -$esc:server_h -$esc:tuning_h +$esc:(T.unpack valuesH) +$esc:(T.unpack serverH) +$esc:(T.unpack tuningH) $edecls:boilerplate_defs 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 @@ -22,6 +22,8 @@ compilePrimTypeExt, compilePrimToNp, compilePrimToExtNp, + fromStorage, + toStorage, Operations (..), defaultOperations, unpackDim, @@ -49,17 +51,18 @@ import Control.Monad.RWS import qualified Data.Map as M import Data.Maybe +import qualified Data.Text as T import Futhark.CodeGen.Backends.GenericPython.AST -import Futhark.CodeGen.Backends.GenericPython.Definitions import Futhark.CodeGen.Backends.GenericPython.Options import qualified Futhark.CodeGen.ImpCode as Imp +import Futhark.CodeGen.RTS.Python import Futhark.Compiler.CLI (CompilerMode (..)) import Futhark.IR.Primitive hiding (Bool) import Futhark.IR.Prop (isBuiltInFunction, subExpVars) import Futhark.IR.Syntax (Space (..)) import Futhark.MonadFreshNames import Futhark.Util (zEncodeString) -import Futhark.Util.Pretty (pretty) +import Futhark.Util.Pretty (pretty, prettyText) -- | A substitute expression compiler, tried before the main -- compilation function. @@ -362,27 +365,24 @@ [PyStmt] -> [Option] -> Imp.Definitions op -> - m String + m T.Text compileProg mode class_name constructor imports defines ops userstate sync options prog = do src <- getNameSource let prog' = runCompilerM ops src userstate compileProg' - return $ - pretty - ( PyProg $ - imports - ++ [ Import "argparse" Nothing, - Assign (Var "sizes") $ Dict [] - ] - ++ defines - ++ [ Escape pyValues, - Escape pyFunctions, - Escape pyPanic, - Escape pyTuning, - Escape pyUtility, - Escape pyServer - ] - ++ prog' - ) + pure . prettyText . PyProg $ + imports + ++ [ Import "argparse" Nothing, + Assign (Var "sizes") $ Dict [] + ] + ++ defines + ++ [ Escape valuesPy, + Escape memoryPy, + Escape panicPy, + Escape tuningPy, + Escape scalarPy, + Escape serverPy + ] + ++ prog' where Imp.Definitions consts (Imp.Functions funs) = prog compileProg' = withConstantSubsts consts $ do @@ -551,10 +551,9 @@ pack_output <- asks envEntryOutput pack_output mem sid bt ept dims entryPointOutput (Imp.TransparentValue _ (Imp.ArrayValue mem _ bt ept dims)) = do - mem' <- compileVar mem - let cast = Cast mem' (compilePrimTypeExt bt ept) + mem' <- Cast <$> compileVar mem <*> pure (compilePrimTypeExt bt ept) dims' <- mapM compileDim dims - return $ simpleCall "createArray" [cast, Tuple dims'] + return $ simpleCall "createArray" [mem', Tuple dims', Var $ compilePrimToExtNp bt ept] badInput :: Int -> PyExp -> String -> PyStmt badInput i e t = @@ -641,9 +640,14 @@ -- we first go through the corresponding ctypes type, which does -- not have this problem. ctobject = compilePrimType bt - ctcall = simpleCall ctobject [e] npobject = compilePrimToNp bt - npcall = simpleCall npobject [ctcall] + npcall = + simpleCall + npobject + [ case bt of + IntType Int64 -> simpleCall ctobject [e] + _ -> e + ] stm $ Try [Assign vname' npcall] @@ -726,6 +730,7 @@ readTypeEnum (IntType Int16) Imp.TypeDirect = "i16" readTypeEnum (IntType Int32) Imp.TypeDirect = "i32" readTypeEnum (IntType Int64) Imp.TypeDirect = "i64" +readTypeEnum (FloatType Float16) _ = "f16" readTypeEnum (FloatType Float32) _ = "f32" readTypeEnum (FloatType Float64) _ = "f64" readTypeEnum Imp.Bool _ = "bool" @@ -1026,6 +1031,7 @@ IntType Int16 -> "ct.c_int16" IntType Int32 -> "ct.c_int32" IntType Int64 -> "ct.c_int64" + FloatType Float16 -> "ct.c_uint16" FloatType Float32 -> "ct.c_float" FloatType Float64 -> "ct.c_double" Imp.Bool -> "ct.c_bool" @@ -1043,6 +1049,7 @@ (IntType Int16, _) -> "ct.c_int16" (IntType Int32, _) -> "ct.c_int32" (IntType Int64, _) -> "ct.c_int64" + (FloatType Float16, _) -> "ct.c_uint16" (FloatType Float32, _) -> "ct.c_float" (FloatType Float64, _) -> "ct.c_double" (Imp.Bool, _) -> "ct.c_bool" @@ -1056,6 +1063,7 @@ IntType Int16 -> "np.int16" IntType Int32 -> "np.int32" IntType Int64 -> "np.int64" + FloatType Float16 -> "np.float16" FloatType Float32 -> "np.float32" FloatType Float64 -> "np.float64" Imp.Bool -> "np.byte" @@ -1073,11 +1081,24 @@ (IntType Int16, _) -> "np.int16" (IntType Int32, _) -> "np.int32" (IntType Int64, _) -> "np.int64" + (FloatType Float16, _) -> "np.float16" (FloatType Float32, _) -> "np.float32" (FloatType Float64, _) -> "np.float64" (Imp.Bool, _) -> "np.bool_" (Unit, _) -> "np.byte" +-- | Convert from scalar to storage representation for the given type. +toStorage :: PrimType -> PyExp -> PyExp +toStorage (FloatType Float16) e = + simpleCall "ct.c_int16" [simpleCall "futhark_to_bits16" [e]] +toStorage t e = simpleCall (compilePrimType t) [e] + +-- | Convert from storage to scalar representation for the given type. +fromStorage :: PrimType -> PyExp -> PyExp +fromStorage (FloatType Float16) e = + simpleCall "futhark_from_bits16" [simpleCall "np.int16" [e]] +fromStorage t e = simpleCall (compilePrimToNp t) [e] + compilePrimValue :: Imp.PrimValue -> PyExp compilePrimValue (IntValue (Int8Value v)) = simpleCall "np.int8" [Integer $ toInteger v] @@ -1087,6 +1108,12 @@ simpleCall "np.int32" [Integer $ toInteger v] compilePrimValue (IntValue (Int64Value v)) = simpleCall "np.int64" [Integer $ toInteger v] +compilePrimValue (FloatValue (Float16Value v)) + | isInfinite v = + if v > 0 then Var "np.inf" else Var "-np.inf" + | isNaN v = + Var "np.nan" + | otherwise = simpleCall "np.float16" [Float $ fromRational $ toRational v] compilePrimValue (FloatValue (Float32Value v)) | isInfinite v = if v > 0 then Var "np.inf" else Var "-np.inf" @@ -1162,13 +1189,24 @@ compileLeaf (Imp.Index src (Imp.Count iexp) bt _ _) = do iexp' <- compileExp $ Imp.untyped iexp let bt' = compilePrimType bt - nptype = compilePrimToNp bt src' <- compileVar src - return $ simpleCall "indexArray" [src', iexp', Var bt', Var nptype] + return $ fromStorage bt $ simpleCall "indexArray" [src', iexp', Var bt'] +errorMsgString :: Imp.ErrorMsg Imp.Exp -> CompilerM op s (String, [PyExp]) +errorMsgString (Imp.ErrorMsg parts) = do + let onPart (Imp.ErrorString s) = return ("%s", String s) + onPart (Imp.ErrorVal IntType {} x) = ("%d",) <$> compileExp x + onPart (Imp.ErrorVal FloatType {} x) = ("%f",) <$> compileExp x + onPart (Imp.ErrorVal Imp.Bool x) = ("%r",) <$> compileExp x + onPart (Imp.ErrorVal Unit {} x) = ("%r",) <$> compileExp x + (formatstrs, formatargs) <- unzip <$> mapM onPart parts + pure (mconcat formatstrs, formatargs) + compileCode :: Imp.Code op -> CompilerM op s () compileCode Imp.DebugPrint {} = return () +compileCode Imp.TracePrint {} = + return () compileCode (Imp.Op op) = join $ asks envOpCompiler <*> pure op compileCode (Imp.If cond tb fb) = do @@ -1236,18 +1274,15 @@ compileCode (Imp.Comment s code) = do code' <- collect $ compileCode code stm $ Comment s code' -compileCode (Imp.Assert e (Imp.ErrorMsg parts) (loc, locs)) = do +compileCode (Imp.Assert e msg (loc, locs)) = do e' <- compileExp e - let onPart (Imp.ErrorString s) = return ("%s", String s) - onPart (Imp.ErrorInt32 x) = ("%d",) <$> compileExp x - onPart (Imp.ErrorInt64 x) = ("%d",) <$> compileExp x - (formatstrs, formatargs) <- unzip <$> mapM onPart parts + (formatstr, formatargs) <- errorMsgString msg stm $ Assert e' ( BinOp "%" - (String $ "Error: " ++ concat formatstrs ++ "\n\nBacktrace:\n" ++ stacktrace) + (String $ "Error: " ++ formatstr ++ "\n\nBacktrace:\n" ++ stacktrace) (Tuple formatargs) ) where @@ -1314,9 +1349,7 @@ <*> compileExp elemexp compileCode (Imp.Write dest (Imp.Count idx) elemtype _ _ elemexp) = do idx' <- compileExp $ Imp.untyped idx - elemexp' <- compileExp elemexp + elemexp' <- toStorage elemtype <$> compileExp elemexp dest' <- compileVar dest - let elemtype' = compilePrimType elemtype - ctype = simpleCall elemtype' [elemexp'] - stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', ctype] + stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', elemexp'] compileCode Imp.Skip = return () 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 @@ -11,6 +11,7 @@ ) where +import qualified Data.Text as T import Futhark.Util.Pretty import Language.Futhark.Core @@ -30,7 +31,7 @@ | Bool Bool | Float Double | String String - | RawStringLiteral String + | RawStringLiteral T.Text | Var String | BinOp String PyExp PyExp | UnOp String PyExp @@ -75,7 +76,7 @@ | FunDef PyFunDef | ClassDef PyClassDef | -- Some arbitrary string of Python code. - Escape String + Escape T.Text deriving (Eq, Show) data PyExcept = Catch PyExp [PyStmt] @@ -105,7 +106,7 @@ | isInfinite x = text $ if x > 0 then "float('inf')" else "float('-inf')" | otherwise = ppr x ppr (String x) = text $ show x - ppr (RawStringLiteral s) = text "\"\"\"" <> text s <> text "\"\"\"" + ppr (RawStringLiteral s) = text "\"\"\"" <> strictText s <> text "\"\"\"" ppr (Var n) = text $ map (\x -> if x == '\'' then 'm' else x) n ppr (Field e s) = ppr e <> text "." <> text s ppr (BinOp s e1 e2) = parens (ppr e1 <+> text s <+> ppr e2) @@ -172,7 +173,7 @@ text "import" <+> text from ppr (FunDef d) = ppr d ppr (ClassDef d) = ppr d - ppr (Escape s) = stack $ map text $ lines s + ppr (Escape s) = stack $ map strictText $ T.lines s instance Pretty PyFunDef where ppr (Def fname params body) = diff --git a/src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs b/src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Futhark.CodeGen.Backends.GenericPython.Definitions - ( pyFunctions, - pyUtility, - pyValues, - pyPanic, - pyTuning, - pyServer, - ) -where - -import Data.FileEmbed - -pyFunctions :: String -pyFunctions = $(embedStringFile "rts/python/memory.py") - -pyUtility :: String -pyUtility = $(embedStringFile "rts/python/scalar.py") - -pyValues :: String -pyValues = $(embedStringFile "rts/python/values.py") - -pyPanic :: String -pyPanic = $(embedStringFile "rts/python/panic.py") - -pyTuning :: String -pyTuning = $(embedStringFile "rts/python/tuning.py") - -pyServer :: String -pyServer = $(embedStringFile "rts/python/server.py") diff --git a/src/Futhark/CodeGen/Backends/GenericWASM.hs b/src/Futhark/CodeGen/Backends/GenericWASM.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/GenericWASM.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Futhark.CodeGen.Backends.GenericWASM + ( GC.CParts (..), + GC.asLibrary, + GC.asExecutable, + GC.asServer, + JSEntryPoint (..), + emccExportNames, + javascriptWrapper, + extToString, + runServer, + libraryExports, + ) +where + +import Data.List (intercalate, nub) +import qualified Data.Text as T +import qualified Futhark.CodeGen.Backends.GenericC as GC +import Futhark.CodeGen.Backends.SimpleRep (opaqueName) +import qualified Futhark.CodeGen.ImpCode.Sequential as Imp +import Futhark.CodeGen.RTS.JavaScript +import Futhark.IR.Primitive +import NeatInterpolation (text) + +extToString :: Imp.ExternalValue -> String +extToString (Imp.TransparentValue u (Imp.ArrayValue vn _ pt s dimSize)) = + concat (replicate (length dimSize) "[]") ++ extToString (Imp.TransparentValue u (Imp.ScalarValue pt s vn)) +extToString (Imp.TransparentValue _ (Imp.ScalarValue (FloatType Float16) _ _)) = "f16" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (FloatType Float32) _ _)) = "f32" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (FloatType Float64) _ _)) = "f64" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (IntType Int8) Imp.TypeDirect _)) = "i8" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (IntType Int16) Imp.TypeDirect _)) = "i16" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (IntType Int32) Imp.TypeDirect _)) = "i32" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (IntType Int64) Imp.TypeDirect _)) = "i64" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (IntType Int8) Imp.TypeUnsigned _)) = "u8" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (IntType Int16) Imp.TypeUnsigned _)) = "u16" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (IntType Int32) Imp.TypeUnsigned _)) = "u32" +extToString (Imp.TransparentValue _ (Imp.ScalarValue (IntType Int64) Imp.TypeUnsigned _)) = "u64" +extToString (Imp.TransparentValue _ (Imp.ScalarValue Bool _ _)) = "bool" +extToString (Imp.TransparentValue _ (Imp.ScalarValue Unit _ _)) = error "extToString: Unit" +extToString (Imp.OpaqueValue _ oname vds) = opaqueName oname vds + +type EntryPointType = String + +data JSEntryPoint = JSEntryPoint + { name :: String, + parameters :: [EntryPointType], + ret :: [EntryPointType] + } + +emccExportNames :: [JSEntryPoint] -> [String] +emccExportNames jses = + map (\jse -> "'_futhark_entry_" ++ name jse ++ "'") jses + ++ map (\arg -> "'" ++ gfn "new" arg ++ "'") arrays + ++ map (\arg -> "'" ++ gfn "free" arg ++ "'") arrays + ++ map (\arg -> "'" ++ gfn "shape" arg ++ "'") arrays + ++ map (\arg -> "'" ++ gfn "values_raw" arg ++ "'") arrays + ++ map (\arg -> "'" ++ gfn "values" arg ++ "'") arrays + ++ map (\arg -> "'" ++ "_futhark_free_" ++ arg ++ "'") opaques + ++ [ "_futhark_context_config_new", + "_futhark_context_config_free", + "_futhark_context_new", + "_futhark_context_free", + "_futhark_context_get_error" + ] + where + arrays = filter isArray typs + opaques = filter isOpaque typs + typs = nub $ concatMap (\jse -> parameters jse ++ ret jse) jses + gfn typ str = "_futhark_" ++ typ ++ "_" ++ baseType str ++ "_" ++ show (dim str) ++ "d" + +javascriptWrapper :: [JSEntryPoint] -> T.Text +javascriptWrapper entryPoints = + T.unlines + [ serverJs, + valuesJs, + wrapperclassesJs, + classFutharkContext entryPoints + ] + +classFutharkContext :: [JSEntryPoint] -> T.Text +classFutharkContext entryPoints = + T.unlines + [ "class FutharkContext {", + constructor entryPoints, + getFreeFun, + getEntryPointsFun, + getErrorFun, + T.unlines $ map toFutharkArray arrays, + T.unlines $ map jsWrapEntryPoint entryPoints, + "}", + [text| + async function newFutharkContext() { + var wasm = await loadWASM(); + return new FutharkContext(wasm); + } + |] + ] + where + arrays = filter isArray typs + typs = nub $ concatMap (\jse -> parameters jse ++ ret jse) entryPoints + +constructor :: [JSEntryPoint] -> T.Text +constructor jses = + [text| + constructor(wasm, num_threads) { + this.wasm = wasm; + this.cfg = this.wasm._futhark_context_config_new(); + if (num_threads) this.wasm._futhark_context_config_set_num_threads(this.cfg, num_threads); + this.ctx = this.wasm._futhark_context_new(this.cfg); + this.entry_points = { + ${entries} + }; + } + |] + where + entries = T.intercalate "," $ map dicEntry jses + +getFreeFun :: T.Text +getFreeFun = + [text| + free() { + this.wasm._futhark_context_free(this.ctx); + this.wasm._futhark_context_config_free(this.cfg); + } + |] + +getEntryPointsFun :: T.Text +getEntryPointsFun = + [text| + get_entry_points() { + return this.entry_points; + } + |] + +getErrorFun :: T.Text +getErrorFun = + [text| + get_error() { + var ptr = this.wasm._futhark_context_get_error(this.ctx); + var len = HEAP8.subarray(ptr).indexOf(0); + var str = String.fromCharCode(...HEAP8.subarray(ptr, ptr + len)); + this.wasm._free(ptr); + return str; + } + |] + +dicEntry :: JSEntryPoint -> T.Text +dicEntry jse = + [text| + '${ename}' : [${params}, ${rets}] + |] + where + ename = T.pack $ name jse + params = T.pack $ show $ parameters jse + rets = T.pack $ show $ ret jse + +jsWrapEntryPoint :: JSEntryPoint -> T.Text +jsWrapEntryPoint jse = + [text| + ${func_name}(${inparams}) { + var out = [${outparams}].map(n => this.wasm._malloc(n)); + var to_free = []; + var do_free = () => { out.forEach(this.wasm._free); to_free.forEach(f => f.free()); }; + ${paramsToPtr} + if (this.wasm._futhark_entry_${func_name}(this.ctx, ...out, ${ins}) > 0) { + do_free(); + throw this.get_error(); + } + ${results} + do_free(); + return ${res}; + } + |] + where + func_name = T.pack $ name jse + + alp = [0 .. length (parameters jse) - 1] + inparams = T.pack $ intercalate ", " ["in" ++ show i | i <- alp] + ins = T.pack $ intercalate ", " [maybeDerefence ("in" ++ show i) $ parameters jse !! i | i <- alp] + paramsToPtr = T.pack $ unlines $ filter ("" /=) [arrayPointer ("in" ++ show i) $ parameters jse !! i | i <- alp] + + alr = [0 .. length (ret jse) - 1] + outparams = T.pack $ intercalate ", " [show $ typeSize $ ret jse !! i | i <- alr] + results = T.pack $ unlines [makeResult i $ ret jse !! i | i <- alr] + res_array = intercalate ", " ["result" ++ show i | i <- alr] + res = T.pack $ if length (ret jse) == 1 then "result0" else "[" ++ res_array ++ "]" + +maybeDerefence :: String -> String -> String +maybeDerefence arg typ = + if isScalar typ then arg else arg ++ ".ptr" + +arrayPointer :: String -> String -> String +arrayPointer arg typ = + if isArray typ + then " if (" ++ arg ++ " instanceof Array) { " ++ reassign ++ "; to_free.push(" ++ arg ++ "); }" + else "" + where + reassign = arg ++ " = this.new_" ++ signature ++ "_from_jsarray(" ++ arg ++ ")" + signature = baseType typ ++ "_" ++ show (dim typ) ++ "d" + +makeResult :: Int -> String -> String +makeResult i typ = + " var result" ++ show i ++ " = " + ++ if isArray typ + then "this.new_" ++ signature ++ "_from_ptr(" ++ readout ++ ");" + else + if isOpaque typ + then "new FutharkOpaque(this, " ++ readout ++ ", this.wasm._futhark_free_" ++ typ ++ ");" + else readout ++ if typ == "bool" then "!==0;" else ";" + where + res = "out[" ++ show i ++ "]" + readout = typeHeap typ ++ "[" ++ res ++ " >> " ++ show (typeShift typ) ++ "]" + signature = baseType typ ++ "_" ++ show (dim typ) ++ "d" + +baseType :: String -> String +baseType ('[' : ']' : end) = baseType end +baseType typ = typ + +dim :: String -> Int +dim ('[' : ']' : end) = dim end + 1 +dim _ = 0 + +isArray :: String -> Bool +isArray typ = take 2 typ == "[]" + +isOpaque :: String -> Bool +isOpaque typ = take 6 typ == "opaque" + +isScalar :: String -> Bool +isScalar typ = not (isArray typ || isOpaque typ) + +typeSize :: String -> Integer +typeSize typ = + case typ of + "i8" -> 1 + "i16" -> 2 + "i32" -> 4 + "i64" -> 8 + "u8" -> 1 + "u16" -> 2 + "u32" -> 4 + "u64" -> 8 + "f16" -> 2 + "f32" -> 4 + "f64" -> 8 + "bool" -> 1 + _ -> 4 + +typeShift :: String -> Integer +typeShift typ = + case typ of + "i8" -> 0 + "i16" -> 1 + "i32" -> 2 + "i64" -> 3 + "u8" -> 0 + "u16" -> 1 + "u32" -> 2 + "u64" -> 3 + "f16" -> 1 + "f32" -> 2 + "f64" -> 3 + "bool" -> 0 + _ -> 2 + +typeHeap :: String -> String +typeHeap typ = + case typ of + "i8" -> "this.wasm.HEAP8" + "i16" -> "this.wasm.HEAP16" + "i32" -> "this.wasm.HEAP32" + "i64" -> "this.wasm.HEAP64" + "u8" -> "this.wasm.HEAPU8" + "u16" -> "this.wasm.HEAPU16" + "u32" -> "this.wasm.HEAPU32" + "u64" -> "(new BigUint64Array(this.wasm.HEAP64.buffer))" + "f16" -> "this.wasm.HEAPU16" + "f32" -> "this.wasm.HEAPF32" + "f64" -> "this.wasm.HEAPF64" + "bool" -> "this.wasm.HEAP8" + _ -> "this.wasm.HEAP32" + +toFutharkArray :: String -> T.Text +toFutharkArray typ = + [text| + ${new}_from_jsarray(${arraynd_p}) { + return this.${new}(${arraynd_flat_p}, ${arraynd_dims_p}); + } + ${new}(array, ${dims}) { + console.assert(array.length === ${dims_multiplied}, 'len=%s,dims=%s', array.length, [${dims}].toString()); + var copy = this.wasm._malloc(array.length << ${shift}); + ${heapType}.set(array, copy >> ${shift}); + var ptr = ${fnew}(this.ctx, copy, ${bigint_dims}); + this.wasm._free(copy); + return this.${new}_from_ptr(ptr); + } + + ${new}_from_ptr(ptr) { + return new FutharkArray(this, ptr, ${args}); + } + |] + where + d = dim typ + ftype = baseType typ + heap = typeHeap ftype + signature = ftype ++ "_" ++ show d ++ "d" + new = T.pack $ "new_" ++ signature + fnew = T.pack $ "this.wasm._futhark_new_" ++ signature + fshape = "this.wasm._futhark_shape_" ++ signature + fvalues = "this.wasm._futhark_values_raw_" ++ signature + ffree = "this.wasm._futhark_free_" ++ signature + arraynd = "array" ++ show d ++ "d" + shift = T.pack $ show (typeShift ftype) + heapType = T.pack heap + arraynd_flat = if d > 1 then arraynd ++ ".flat()" else arraynd + arraynd_dims = intercalate ", " [arraynd ++ mult i "[0]" ++ ".length" | i <- [0 .. d -1]] + dims = T.pack $ intercalate ", " ["d" ++ show i | i <- [0 .. d -1]] + dims_multiplied = T.pack $ intercalate "*" ["Number(d" ++ show i ++ ")" | i <- [0 .. d -1]] + bigint_dims = T.pack $ intercalate ", " ["BigInt(d" ++ show i ++ ")" | i <- [0 .. d -1]] + mult i s = concat $ replicate i s + (arraynd_p, arraynd_flat_p, arraynd_dims_p) = (T.pack arraynd, T.pack arraynd_flat, T.pack arraynd_dims) + args = T.pack $ intercalate ", " ["'" ++ ftype ++ "'", show d, heap, fshape, fvalues, ffree] + +runServer :: T.Text +runServer = + [text| + Module.onRuntimeInitialized = () => { + var context = new FutharkContext(Module); + var server = new Server(context); + server.run(); + }|] + +libraryExports :: T.Text +libraryExports = "export {newFutharkContext, FutharkContext, FutharkArray, FutharkOpaque};" 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 @@ -6,22 +6,26 @@ -- program to an equivalent C program. module Futhark.CodeGen.Backends.MulticoreC ( compileProg, + generateContext, GC.CParts (..), GC.asLibrary, GC.asExecutable, GC.asServer, + operations, + cliOptions, ) where import Control.Monad -import Data.FileEmbed import qualified Data.Map as M import Data.Maybe +import qualified Data.Text as T import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode.Multicore import qualified Futhark.CodeGen.ImpGen.Multicore as ImpGen +import Futhark.CodeGen.RTS.C (schedulerH) import Futhark.IR.MCMem (MCMem, Prog) import Futhark.MonadFreshNames import qualified Language.C.Quote.OpenCL as C @@ -43,165 +47,165 @@ cliOptions ) <=< ImpGen.compileProg - where - generateContext = do - let scheduler_h = $(embedStringFile "rts/c/scheduler.h") - mapM_ GC.earlyDecl [C.cunit|$esc:scheduler_h|] - cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { int debugging; - int profiling; - int num_threads; - };|] - ) +generateContext :: GC.CompilerM op () () +generateContext = do + mapM_ GC.earlyDecl [C.cunit|$esc:(T.unpack schedulerH)|] - GC.publicDef_ "context_config_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:cfg* $id:s(void);|], - [C.cedecl|struct $id:cfg* $id:s(void) { - struct $id:cfg *cfg = (struct $id:cfg*) malloc(sizeof(struct $id:cfg)); - if (cfg == NULL) { - return NULL; - } - cfg->debugging = 0; - cfg->profiling = 0; - cfg->num_threads = 0; - return cfg; - }|] - ) + cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> + ( [C.cedecl|struct $id:s;|], + [C.cedecl|struct $id:s { int debugging; + int profiling; + int num_threads; + };|] + ) - GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg) { - free(cfg); - }|] - ) + GC.publicDef_ "context_config_new" GC.InitDecl $ \s -> + ( [C.cedecl|struct $id:cfg* $id:s(void);|], + [C.cedecl|struct $id:cfg* $id:s(void) { + struct $id:cfg *cfg = (struct $id:cfg*) malloc(sizeof(struct $id:cfg)); + if (cfg == NULL) { + return NULL; + } + cfg->debugging = 0; + cfg->profiling = 0; + cfg->num_threads = 0; + return cfg; + }|] + ) - GC.publicDef_ "context_config_set_debugging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { - cfg->debugging = detail; - }|] - ) + GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> + ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg) { + free(cfg); + }|] + ) - GC.publicDef_ "context_config_set_profiling" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - cfg->profiling = flag; - }|] - ) + GC.publicDef_ "context_config_set_debugging" GC.InitDecl $ \s -> + ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { + cfg->debugging = detail; + }|] + ) - GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { - /* Does nothing for this backend. */ - (void)cfg; (void)detail; - }|] - ) + GC.publicDef_ "context_config_set_profiling" GC.InitDecl $ \s -> + ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { + cfg->profiling = flag; + }|] + ) - GC.publicDef_ "context_config_set_num_threads" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg *cfg, int n);|], - [C.cedecl|void $id:s(struct $id:cfg *cfg, int n) { - cfg->num_threads = n; - }|] - ) + GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> + ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { + // Does nothing for this backend. + (void)cfg; (void)detail; + }|] + ) - (fields, init_fields) <- GC.contextContents + GC.publicDef_ "context_config_set_num_threads" GC.InitDecl $ \s -> + ( [C.cedecl|void $id:s(struct $id:cfg *cfg, int n);|], + [C.cedecl|void $id:s(struct $id:cfg *cfg, int n) { + cfg->num_threads = n; + }|] + ) - ctx <- GC.publicDef "context" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { - struct scheduler scheduler; - int detail_memory; - int debugging; - int profiling; - int profiling_paused; - int logging; - typename lock_t lock; - char *error; - typename FILE *log; - int total_runs; - long int total_runtime; - $sdecls:fields + (fields, init_fields) <- GC.contextContents - // Tuning parameters - typename int64_t tuning_timing; - typename int64_t tuning_iter; - };|] - ) + ctx <- GC.publicDef "context" GC.InitDecl $ \s -> + ( [C.cedecl|struct $id:s;|], + [C.cedecl|struct $id:s { + struct scheduler scheduler; + int detail_memory; + int debugging; + int profiling; + int profiling_paused; + int logging; + typename lock_t lock; + char *error; + typename FILE *log; + int total_runs; + long int total_runtime; + $sdecls:fields - GC.publicDef_ "context_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], - [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) { - struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); - if (ctx == NULL) { - return NULL; - } + // Tuning parameters + typename int64_t tuning_timing; + typename int64_t tuning_iter; + };|] + ) - // Initialize rand() - fast_srand(time(0)); - ctx->detail_memory = cfg->debugging; - ctx->debugging = cfg->debugging; - ctx->profiling = cfg->profiling; - ctx->profiling_paused = 0; - ctx->logging = 0; - ctx->error = NULL; - ctx->log = stderr; - create_lock(&ctx->lock); + GC.publicDef_ "context_new" GC.InitDecl $ \s -> + ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], + [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) { + struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); + if (ctx == NULL) { + return NULL; + } - int tune_kappa = 0; - double kappa = 5.1f * 1000; + // Initialize rand() + fast_srand(time(0)); + ctx->detail_memory = cfg->debugging; + ctx->debugging = cfg->debugging; + ctx->profiling = cfg->profiling; + ctx->profiling_paused = 0; + ctx->logging = 0; + ctx->error = NULL; + ctx->log = stderr; + create_lock(&ctx->lock); - if (tune_kappa) { - if (determine_kappa(&kappa) != 0) { - return NULL; - } - } + int tune_kappa = 0; + double kappa = 5.1f * 1000; - if (scheduler_init(&ctx->scheduler, - cfg->num_threads > 0 ? - cfg->num_threads : num_processors(), - kappa) != 0) { - return NULL; - } + if (tune_kappa) { + if (determine_kappa(&kappa) != 0) { + return NULL; + } + } - $stms:init_fields + if (scheduler_init(&ctx->scheduler, + cfg->num_threads > 0 ? + cfg->num_threads : num_processors(), + kappa) != 0) { + return NULL; + } - init_constants(ctx); + $stms:init_fields - return ctx; - }|] - ) + init_constants(ctx); - GC.publicDef_ "context_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|], - [C.cedecl|void $id:s(struct $id:ctx* ctx) { - free_constants(ctx); - (void)scheduler_destroy(&ctx->scheduler); - free_lock(&ctx->lock); - free(ctx); - }|] - ) + return ctx; + }|] + ) - GC.publicDef_ "context_sync" GC.InitDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|], - [C.cedecl|int $id:s(struct $id:ctx* ctx) { - (void)ctx; - return 0; - }|] - ) + GC.publicDef_ "context_free" GC.InitDecl $ \s -> + ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|], + [C.cedecl|void $id:s(struct $id:ctx* ctx) { + free_constants(ctx); + (void)scheduler_destroy(&ctx->scheduler); + free_lock(&ctx->lock); + free(ctx); + }|] + ) - GC.earlyDecl [C.cedecl|static const char *size_names[0];|] - GC.earlyDecl [C.cedecl|static const char *size_vars[0];|] - GC.earlyDecl [C.cedecl|static const char *size_classes[0];|] + GC.publicDef_ "context_sync" GC.InitDecl $ \s -> + ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|], + [C.cedecl|int $id:s(struct $id:ctx* ctx) { + (void)ctx; + return 0; + }|] + ) - GC.publicDef_ "context_config_set_size" GC.InitDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *size_name, size_t size_value);|], - [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *size_name, size_t size_value) { - (void)cfg; (void)size_name; (void)size_value; - return 1; - }|] - ) + GC.earlyDecl [C.cedecl|static const char *size_names[0];|] + GC.earlyDecl [C.cedecl|static const char *size_vars[0];|] + GC.earlyDecl [C.cedecl|static const char *size_classes[0];|] + + GC.publicDef_ "context_config_set_size" GC.InitDecl $ \s -> + ( [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *size_name, size_t size_value);|], + [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *size_name, size_t size_value) { + (void)cfg; (void)size_name; (void)size_value; + return 1; + }|] + ) cliOptions :: [Option] cliOptions = diff --git a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | C code generator. This module can convert a correct ImpCode +-- program to an equivalent C program. This C program is expected to +-- be converted to WebAssembly, so we also produce the intended +-- JavaScript wrapper. +module Futhark.CodeGen.Backends.MulticoreWASM + ( compileProg, + runServer, + libraryExports, + GC.CParts (..), + GC.asLibrary, + GC.asExecutable, + GC.asServer, + ) +where + +import Data.Maybe +import qualified Data.Text as T +import qualified Futhark.CodeGen.Backends.GenericC as GC +import Futhark.CodeGen.Backends.GenericWASM +import qualified Futhark.CodeGen.Backends.MulticoreC as MC +import qualified Futhark.CodeGen.ImpCode.Multicore as Imp +import qualified Futhark.CodeGen.ImpGen.Multicore as ImpGen +import Futhark.IR.MCMem +import Futhark.MonadFreshNames + +compileProg :: MonadFreshNames m => Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String])) +compileProg prog = do + (ws, prog') <- ImpGen.compileProg prog + + prog'' <- + GC.compileProg + "wasm_multicore" + MC.operations + MC.generateContext + "" + [DefaultSpace] + MC.cliOptions + prog' + + pure + ( ws, + ( prog'', + javascriptWrapper (fRepMyRep prog'), + "_futhark_context_config_set_num_threads" : emccExportNames (fRepMyRep prog') + ) + ) + +fRepMyRep :: Imp.Definitions Imp.Multicore -> [JSEntryPoint] +fRepMyRep prog = + let Imp.Functions fs = Imp.defFuns prog + function (Imp.Function entry _ _ _ res args) = do + n <- entry + Just $ + JSEntryPoint + { name = nameToString n, + parameters = map extToString args, + ret = map extToString res + } + in mapMaybe (function . snd) fs 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 @@ -9,12 +9,14 @@ import Control.Monad import qualified Data.Map as M +import qualified Data.Text as T import qualified Futhark.CodeGen.Backends.GenericPython as Py import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.CodeGen.Backends.GenericPython.Options import Futhark.CodeGen.Backends.PyOpenCL.Boilerplate import qualified Futhark.CodeGen.ImpCode.OpenCL as Imp import qualified Futhark.CodeGen.ImpGen.OpenCL as ImpGen +import Futhark.CodeGen.RTS.Python (openclPy) import Futhark.IR.GPUMem (GPUMem, Prog) import Futhark.MonadFreshNames import Futhark.Util (zEncodeString) @@ -26,7 +28,7 @@ Py.CompilerMode -> String -> Prog GPUMem -> - m (ImpGen.Warnings, String) + m (ImpGen.Warnings, T.Text) compileProg mode class_name prog = do ( ws, Imp.Program @@ -60,14 +62,14 @@ Assign (Var "default_num_groups") None, Assign (Var "default_tile_size") None, Assign (Var "default_reg_tile_size") None, - Assign (Var "fut_opencl_src") $ RawStringLiteral $ opencl_prelude ++ opencl_code + Assign (Var "fut_opencl_src") $ RawStringLiteral $ opencl_prelude <> opencl_code ] let imports = [ Import "sys" Nothing, Import "numpy" $ Just "np", Import "ctypes" $ Just "ct", - Escape openClPrelude, + Escape openclPy, Import "pyopencl.array" Nothing, Import "time" Nothing ] @@ -424,7 +426,7 @@ (Var "cl.array.Array") [ Arg $ Var "self.queue", Arg $ Tuple dims', - Arg $ Var $ Py.compilePrimTypeExt bt ept, + Arg $ Var $ Py.compilePrimToExtNp bt ept, ArgKeyword "data" mem' ] packArrayOutput _ sid _ _ _ = diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs @@ -5,12 +5,10 @@ -- | Various boilerplate definitions for the PyOpenCL backend. module Futhark.CodeGen.Backends.PyOpenCL.Boilerplate ( openClInit, - openClPrelude, ) where import Control.Monad.Identity -import Data.FileEmbed import qualified Data.Map as M import qualified Data.Text as T import qualified Futhark.CodeGen.Backends.GenericPython as Py @@ -32,17 +30,12 @@ errorMsgNumArgs :: ErrorMsg a -> Int errorMsgNumArgs = length . errorMsgArgTypes --- | @rts/python/opencl.py@ embedded as a string. -openClPrelude :: String -openClPrelude = $(embedStringFile "rts/python/opencl.py") - -- | Python code (as a string) that calls the -- @initiatialize_opencl_object@ procedure. Should be put in the -- class constructor. -openClInit :: [PrimType] -> String -> M.Map Name SizeClass -> [FailureMsg] -> String +openClInit :: [PrimType] -> String -> M.Map Name SizeClass -> [FailureMsg] -> T.Text openClInit types assign sizes failures = - T.unpack - [text| + [text| size_heuristics=$size_heuristics self.global_failure_args_max = $max_num_args self.failure_msgs=$failure_msgs @@ -82,8 +75,7 @@ in concatMap escapeChar onPart (ErrorString s) = formatEscape s - onPart ErrorInt32 {} = "{}" - onPart ErrorInt64 {} = "{}" + onPart ErrorVal {} = "{}" sizeClassesToPython :: M.Map Name SizeClass -> PyExp sizeClassesToPython = Dict . map f . M.toList 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | C code generator. This module can convert a correct ImpCode -- program to an equivalent C program. The C code is strictly -- sequential, but can handle the full Futhark language. @@ -22,7 +24,7 @@ compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, GC.CParts) compileProg = traverse - (GC.compileProg "c" operations generateBoilerplate "" [DefaultSpace] []) + (GC.compileProg "c" operations generateBoilerplate mempty [DefaultSpace] []) <=< ImpGen.compileProg where operations :: GC.Operations Imp.Sequential () diff --git a/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs b/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs @@ -41,7 +41,7 @@ GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { - /* Does nothing for this backend. */ + // Does nothing for this backend. (void)cfg; (void)detail; }|] ) 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 @@ -5,6 +5,7 @@ where import Control.Monad +import qualified Data.Text as T import qualified Futhark.CodeGen.Backends.GenericPython as GenericPython import Futhark.CodeGen.Backends.GenericPython.AST import qualified Futhark.CodeGen.ImpCode.Sequential as Imp @@ -18,7 +19,7 @@ GenericPython.CompilerMode -> String -> Prog SeqMem -> - m (ImpGen.Warnings, String) + m (ImpGen.Warnings, T.Text) compileProg mode class_name = ImpGen.compileProg >=> traverse diff --git a/src/Futhark/CodeGen/Backends/SequentialWASM.hs b/src/Futhark/CodeGen/Backends/SequentialWASM.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/SequentialWASM.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | C code generator. This module can convert a correct ImpCode +-- program to an equivalent C program. This C program is expected to +-- be converted to WebAssembly, so we also produce the intended +-- JavaScript wrapper. +module Futhark.CodeGen.Backends.SequentialWASM + ( compileProg, + runServer, + libraryExports, + GC.CParts (..), + GC.asLibrary, + GC.asExecutable, + GC.asServer, + ) +where + +import Data.Maybe +import qualified Data.Text as T +import qualified Futhark.CodeGen.Backends.GenericC as GC +import Futhark.CodeGen.Backends.GenericWASM +import Futhark.CodeGen.Backends.SequentialC.Boilerplate +import qualified Futhark.CodeGen.ImpCode.Sequential as Imp +import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen +import Futhark.IR.SeqMem +import Futhark.MonadFreshNames + +-- | Compile the program to sequential C with a JavaScript wrapper. +compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String])) +compileProg prog = do + (ws, prog') <- ImpGen.compileProg prog + + prog'' <- + GC.compileProg + "wasm" + operations + generateBoilerplate + "" + [DefaultSpace] + [] + prog' + pure (ws, (prog'', javascriptWrapper (fRepMyRep prog'), emccExportNames (fRepMyRep prog'))) + where + operations :: GC.Operations Imp.Sequential () + operations = + GC.defaultOperations + { GC.opsCompiler = const $ return () + } + +fRepMyRep :: Imp.Program -> [JSEntryPoint] +fRepMyRep prog = + let Imp.Functions fs = Imp.defFuns prog + function (Imp.Function entry _ _ _ res args) = do + n <- entry + Just $ + JSEntryPoint + { name = nameToString n, + parameters = map extToString args, + ret = map extToString res + } + in mapMaybe (function . snd) fs diff --git a/src/Futhark/CodeGen/Backends/SimpleRep.hs b/src/Futhark/CodeGen/Backends/SimpleRep.hs --- a/src/Futhark/CodeGen/Backends/SimpleRep.hs +++ b/src/Futhark/CodeGen/Backends/SimpleRep.hs @@ -1,28 +1,33 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Simple C runtime representation. +-- +-- Most types use the same memory and scalar variable representation. +-- For those that do not (as of this writing, only `Float16`), we use +-- 'primStorageType' for the array element representation, and +-- 'primTypeToCType' for their scalar representation. Use 'toStorage' +-- and 'fromStorage' to convert back and forth. module Futhark.CodeGen.Backends.SimpleRep ( tupleField, funName, defaultMemBlockType, intTypeToCType, primTypeToCType, - signedPrimTypeToCType, + primStorageType, + primAPIType, arrayName, opaqueName, externalValueType, + toStorage, + fromStorage, cproduct, csum, -- * Primitive value operations - cIntOps, - cFloat32Ops, - cFloat32Funs, - cFloat64Ops, - cFloat64Funs, - cFloatConvOps, + cScalarDefs, -- * Storing/restoring values in byte sequences storageSize, @@ -33,9 +38,10 @@ import Data.Bits (shiftR, xor) import Data.Char (isAlphaNum, isDigit, ord) +import qualified Data.Text as T import Futhark.CodeGen.ImpCode +import Futhark.CodeGen.RTS.C (scalarF16H, scalarH) import Futhark.Util (zEncodeString) -import Futhark.Util.Pretty (prettyOneLine) import qualified Language.C.Quote.C as C import qualified Language.C.Syntax as C import Text.Printf @@ -54,26 +60,38 @@ uintTypeToCType Int32 = [C.cty|typename uint32_t|] uintTypeToCType Int64 = [C.cty|typename uint64_t|] --- | The C type corresponding to a float type. -floatTypeToCType :: FloatType -> C.Type -floatTypeToCType Float32 = [C.cty|float|] -floatTypeToCType Float64 = [C.cty|double|] - -- | The C type corresponding to a primitive type. Integers are -- assumed to be unsigned. primTypeToCType :: PrimType -> C.Type primTypeToCType (IntType t) = intTypeToCType t -primTypeToCType (FloatType t) = floatTypeToCType t +primTypeToCType (FloatType Float16) = [C.cty|typename f16|] +primTypeToCType (FloatType Float32) = [C.cty|float|] +primTypeToCType (FloatType Float64) = [C.cty|double|] primTypeToCType Bool = [C.cty|typename bool|] primTypeToCType Unit = [C.cty|typename bool|] --- | The C type corresponding to a primitive type. Integers are +-- | The C storage type for arrays of this primitive type. +primStorageType :: PrimType -> C.Type +primStorageType (FloatType Float16) = [C.cty|typename uint16_t|] +primStorageType t = primTypeToCType t + +-- | The C API corresponding to a primitive type. Integers are -- assumed to have the specified sign. -signedPrimTypeToCType :: Signedness -> PrimType -> C.Type -signedPrimTypeToCType TypeUnsigned (IntType t) = uintTypeToCType t -signedPrimTypeToCType TypeDirect (IntType t) = intTypeToCType t -signedPrimTypeToCType _ t = primTypeToCType t +primAPIType :: Signedness -> PrimType -> C.Type +primAPIType TypeUnsigned (IntType t) = uintTypeToCType t +primAPIType TypeDirect (IntType t) = intTypeToCType t +primAPIType _ t = primStorageType t +-- | Convert from scalar to storage representation for the given type. +toStorage :: PrimType -> C.Exp -> C.Exp +toStorage (FloatType Float16) e = [C.cexp|futrts_to_bits16($exp:e)|] +toStorage _ e = e + +-- | Convert from storage to scalar representation for the given type. +fromStorage :: PrimType -> C.Exp -> C.Exp +fromStorage (FloatType Float16) e = [C.cexp|futrts_from_bits16($exp:e)|] +fromStorage _ e = e + -- | @tupleField i@ is the name of field number @i@ in a tuple. tupleField :: Int -> String tupleField i = "v" ++ show i @@ -83,12 +101,9 @@ funName :: Name -> String funName = ("futrts_" ++) . zEncodeString . nameToString -funName' :: String -> String -funName' = funName . nameFromString - -- | The type of memory blocks in the default memory space. defaultMemBlockType :: C.Type -defaultMemBlockType = [C.cty|char*|] +defaultMemBlockType = [C.cty|unsigned char*|] -- | The name of exposed array type structs. arrayName :: PrimType -> Signedness -> Int -> String @@ -132,7 +147,7 @@ externalValueType (TransparentValue _ (ArrayValue _ _ pt signed shape)) = [C.cty|struct $id:("futhark_" ++ arrayName pt signed (length shape))*|] externalValueType (TransparentValue _ (ScalarValue pt signed _)) = - signedPrimTypeToCType signed pt + primAPIType signed pt -- | Return an expression multiplying together the given expressions. -- If an empty list is given, the expression @1@ is returned. @@ -160,923 +175,48 @@ toExp v _ = [C.cexp|$id:v|] instance C.ToExp IntValue where - toExp (Int8Value v) = C.toExp v - toExp (Int16Value v) = C.toExp v - toExp (Int32Value v) = C.toExp v - toExp (Int64Value v) = C.toExp v + toExp (Int8Value k) _ = [C.cexp|(typename int8_t)$int:k|] + toExp (Int16Value k) _ = [C.cexp|(typename int16_t)$int:k|] + toExp (Int32Value k) _ = [C.cexp|$int:k|] + toExp (Int64Value k) _ = [C.cexp|(typename int64_t)$int:k|] instance C.ToExp FloatValue where - toExp (Float32Value v) = C.toExp v - toExp (Float64Value v) = C.toExp v + toExp (Float16Value x) _ + | isInfinite x = + if x > 0 then [C.cexp|INFINITY|] else [C.cexp|-INFINITY|] + | isNaN x = + [C.cexp|NAN|] + | otherwise = + [C.cexp|$float:(fromRational (toRational x))|] + toExp (Float32Value x) _ + | isInfinite x = + if x > 0 then [C.cexp|INFINITY|] else [C.cexp|-INFINITY|] + | isNaN x = + [C.cexp|NAN|] + | otherwise = + [C.cexp|$float:x|] + toExp (Float64Value x) _ + | isInfinite x = + if x > 0 then [C.cexp|INFINITY|] else [C.cexp|-INFINITY|] + | isNaN x = + [C.cexp|NAN|] + | otherwise = + [C.cexp|$double:x|] instance C.ToExp PrimValue where toExp (IntValue v) = C.toExp v toExp (FloatValue v) = C.toExp v toExp (BoolValue True) = C.toExp (1 :: Int8) toExp (BoolValue False) = C.toExp (0 :: Int8) - toExp UnitValue = C.toExp (1 :: Int8) + toExp UnitValue = C.toExp (0 :: Int8) instance C.ToExp SubExp where toExp (Var v) = C.toExp v toExp (Constant c) = C.toExp c -cIntOps :: [C.Definition] -cIntOps = - concatMap (`map` [minBound .. maxBound]) ops - ++ cIntPrimFuns - where - ops = - [ mkAdd, - mkSub, - mkMul, - mkUDiv, - mkUDivUp, - mkUMod, - mkUDivSafe, - mkUDivUpSafe, - mkUModSafe, - mkSDiv, - mkSDivUp, - mkSMod, - mkSDivSafe, - mkSDivUpSafe, - mkSModSafe, - mkSQuot, - mkSRem, - mkSQuotSafe, - mkSRemSafe, - mkSMin, - mkUMin, - mkSMax, - mkUMax, - mkShl, - mkLShr, - mkAShr, - mkAnd, - mkOr, - mkXor, - mkUlt, - mkUle, - mkSlt, - mkSle, - mkPow, - mkIToB, - mkBToI - ] - ++ map mkSExt [minBound .. maxBound] - ++ map mkZExt [minBound .. maxBound] - - taggedI s Int8 = s ++ "8" - taggedI s Int16 = s ++ "16" - taggedI s Int32 = s ++ "32" - taggedI s Int64 = s ++ "64" - - -- Use unsigned types for add/sub/mul so we can do - -- well-defined overflow. - mkAdd = simpleUintOp "add" [C.cexp|x + y|] - mkSub = simpleUintOp "sub" [C.cexp|x - y|] - mkMul = simpleUintOp "mul" [C.cexp|x * y|] - mkUDiv = simpleUintOp "udiv" [C.cexp|x / y|] - mkUDivUp = simpleUintOp "udiv_up" [C.cexp|(x+y-1) / y|] - mkUMod = simpleUintOp "umod" [C.cexp|x % y|] - mkUDivSafe = simpleUintOp "udiv_safe" [C.cexp|y == 0 ? 0 : x / y|] - mkUDivUpSafe = simpleUintOp "udiv_up_safe" [C.cexp|y == 0 ? 0 : (x+y-1) / y|] - mkUModSafe = simpleUintOp "umod_safe" [C.cexp|y == 0 ? 0 : x % y|] - mkUMax = simpleUintOp "umax" [C.cexp|x < y ? y : x|] - mkUMin = simpleUintOp "umin" [C.cexp|x < y ? x : y|] - - mkSDiv t = - let ct = intTypeToCType t - in [C.cedecl|static inline $ty:ct $id:(taggedI "sdiv" t)($ty:ct x, $ty:ct y) { - $ty:ct q = x / y; - $ty:ct r = x % y; - return q - - (((r != 0) && ((r < 0) != (y < 0))) ? 1 : 0); - }|] - mkSDivUp t = - simpleIntOp "sdiv_up" [C.cexp|$id:(taggedI "sdiv" t)(x+y-1,y)|] t - mkSMod t = - let ct = intTypeToCType t - in [C.cedecl|static inline $ty:ct $id:(taggedI "smod" t)($ty:ct x, $ty:ct y) { - $ty:ct r = x % y; - return r + - ((r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0)) ? 0 : y); - }|] - mkSDivSafe t = - simpleIntOp "sdiv_safe" [C.cexp|y == 0 ? 0 : $id:(taggedI "sdiv" t)(x,y)|] t - mkSDivUpSafe t = - simpleIntOp "sdiv_up_safe" [C.cexp|$id:(taggedI "sdiv_safe" t)(x+y-1,y)|] t - mkSModSafe t = - simpleIntOp "smod_safe" [C.cexp|y == 0 ? 0 : $id:(taggedI "smod" t)(x,y)|] t - - mkSQuot = simpleIntOp "squot" [C.cexp|x / y|] - mkSRem = simpleIntOp "srem" [C.cexp|x % y|] - mkSQuotSafe = simpleIntOp "squot_safe" [C.cexp|y == 0 ? 0 : x / y|] - mkSRemSafe = simpleIntOp "srem_safe" [C.cexp|y == 0 ? 0 : x % y|] - mkSMax = simpleIntOp "smax" [C.cexp|x < y ? y : x|] - mkSMin = simpleIntOp "smin" [C.cexp|x < y ? x : y|] - mkShl = simpleUintOp "shl" [C.cexp|x << y|] - mkLShr = simpleUintOp "lshr" [C.cexp|x >> y|] - mkAShr = simpleIntOp "ashr" [C.cexp|x >> y|] - mkAnd = simpleUintOp "and" [C.cexp|x & y|] - mkOr = simpleUintOp "or" [C.cexp|x | y|] - mkXor = simpleUintOp "xor" [C.cexp|x ^ y|] - mkUlt = uintCmpOp "ult" [C.cexp|x < y|] - mkUle = uintCmpOp "ule" [C.cexp|x <= y|] - mkSlt = intCmpOp "slt" [C.cexp|x < y|] - mkSle = intCmpOp "sle" [C.cexp|x <= y|] - - -- We define some operations as macros rather than functions, - -- because this allows us to use them as constant expressions - -- in things like array sizes and static initialisers. - macro name rhs = - [C.cedecl|$esc:("#define " ++ name ++ "(x) (" ++ prettyOneLine rhs ++ ")")|] - - mkPow t = - let ct = intTypeToCType t - in [C.cedecl|static inline $ty:ct $id:(taggedI "pow" t)($ty:ct x, $ty:ct y) { - $ty:ct res = 1, rem = y; - while (rem != 0) { - if (rem & 1) { - res *= x; - } - rem >>= 1; - x *= x; - } - return res; - }|] - - mkSExt from_t to_t = macro name [C.cexp|($ty:to_ct)(($ty:from_ct)x)|] - where - name = "sext_" ++ pretty from_t ++ "_" ++ pretty to_t - from_ct = intTypeToCType from_t - to_ct = intTypeToCType to_t - - mkZExt from_t to_t = macro name [C.cexp|($ty:to_ct)(($ty:from_ct)x)|] - where - name = "zext_" ++ pretty from_t ++ "_" ++ pretty to_t - from_ct = uintTypeToCType from_t - to_ct = intTypeToCType to_t - - mkBToI to_t = - [C.cedecl|static inline $ty:to_ct - $id:name($ty:from_ct x) { return x; } |] - where - name = "btoi_bool_" ++ pretty to_t - from_ct = primTypeToCType Bool - to_ct = intTypeToCType to_t - - mkIToB from_t = - [C.cedecl|static inline $ty:to_ct - $id:name($ty:from_ct x) { return x; } |] - where - name = "itob_" ++ pretty from_t ++ "_bool" - to_ct = primTypeToCType Bool - from_ct = intTypeToCType from_t - - simpleUintOp s e t = - [C.cedecl|static inline $ty:ct $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where - ct = uintTypeToCType t - simpleIntOp s e t = - [C.cedecl|static inline $ty:ct $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where - ct = intTypeToCType t - intCmpOp s e t = - [C.cedecl|static inline typename bool $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where - ct = intTypeToCType t - uintCmpOp s e t = - [C.cedecl|static inline typename bool $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where - ct = uintTypeToCType t - -cIntPrimFuns :: [C.Definition] -cIntPrimFuns = - [C.cunit| -$esc:("#if defined(__OPENCL_VERSION__)") - static typename int32_t $id:(funName' "popc8") (typename int8_t x) { - return popcount(x); - } - static typename int32_t $id:(funName' "popc16") (typename int16_t x) { - return popcount(x); - } - static typename int32_t $id:(funName' "popc32") (typename int32_t x) { - return popcount(x); - } - static typename int32_t $id:(funName' "popc64") (typename int64_t x) { - return popcount(x); - } -$esc:("#elif defined(__CUDA_ARCH__)") - static typename int32_t $id:(funName' "popc8") (typename int8_t x) { - return __popc(zext_i8_i32(x)); - } - static typename int32_t $id:(funName' "popc16") (typename int16_t x) { - return __popc(zext_i16_i32(x)); - } - static typename int32_t $id:(funName' "popc32") (typename int32_t x) { - return __popc(x); - } - static typename int32_t $id:(funName' "popc64") (typename int64_t x) { - return __popcll(x); - } -$esc:("#else") - static typename int32_t $id:(funName' "popc8") (typename int8_t x) { - int c = 0; - for (; x; ++c) { - x &= x - 1; - } - return c; - } - static typename int32_t $id:(funName' "popc16") (typename int16_t x) { - int c = 0; - for (; x; ++c) { - x &= x - 1; - } - return c; - } - static typename int32_t $id:(funName' "popc32") (typename int32_t x) { - int c = 0; - for (; x; ++c) { - x &= x - 1; - } - return c; - } - static typename int32_t $id:(funName' "popc64") (typename int64_t x) { - int c = 0; - for (; x; ++c) { - x &= x - 1; - } - return c; - } -$esc:("#endif") - -$esc:("#if defined(__OPENCL_VERSION__)") - static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { - return mul_hi(a, b); - } - static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { - return mul_hi(a, b); - } - static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { - return mul_hi(a, b); - } - static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { - return mul_hi(a, b); - } -$esc:("#elif defined(__CUDA_ARCH__)") - static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { - typename uint16_t aa = a; - typename uint16_t bb = b; - return (aa * bb) >> 8; - } - static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { - typename uint32_t aa = a; - typename uint32_t bb = b; - return (aa * bb) >> 16; - } - static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { - return mulhi(a, b); - } - static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { - return mul64hi(a, b); - } -$esc:("#else") - static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { - typename uint16_t aa = a; - typename uint16_t bb = b; - return (aa * bb) >> 8; - } - static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { - typename uint32_t aa = a; - typename uint32_t bb = b; - return (aa * bb) >> 16; - } - static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { - typename uint64_t aa = a; - typename uint64_t bb = b; - return (aa * bb) >> 32; - } - static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { - typename __uint128_t aa = a; - typename __uint128_t bb = b; - return (aa * bb) >> 64; - } -$esc:("#endif") - -$esc:("#if defined(__OPENCL_VERSION__)") - static typename uint8_t $id:(funName' "mad_hi8") (typename uint8_t a, typename uint8_t b, typename uint8_t c) { - return mad_hi(a, b, c); - } - static typename uint16_t $id:(funName' "mad_hi16") (typename uint16_t a, typename uint16_t b, typename uint16_t c) { - return mad_hi(a, b, c); - } - static typename uint32_t $id:(funName' "mad_hi32") (typename uint32_t a, typename uint32_t b, typename uint32_t c) { - return mad_hi(a, b, c); - } - static typename uint64_t $id:(funName' "mad_hi64") (typename uint64_t a, typename uint64_t b, typename uint64_t c) { - return mad_hi(a, b, c); - } -$esc:("#else") - static typename uint8_t $id:(funName' "mad_hi8") (typename uint8_t a, typename uint8_t b, typename uint8_t c) { - return futrts_mul_hi8(a, b) + c; - } - static typename uint16_t $id:(funName' "mad_hi16") (typename uint16_t a, typename uint16_t b, typename uint16_t c) { - return futrts_mul_hi16(a, b) + c; - } - static typename uint32_t $id:(funName' "mad_hi32") (typename uint32_t a, typename uint32_t b, typename uint32_t c) { - return futrts_mul_hi32(a, b) + c; - } - static typename uint64_t $id:(funName' "mad_hi64") (typename uint64_t a, typename uint64_t b, typename uint64_t c) { - return futrts_mul_hi64(a, b) + c; - } -$esc:("#endif") - - -$esc:("#if defined(__OPENCL_VERSION__)") - static typename int32_t $id:(funName' "clz8") (typename int8_t x) { - return clz(x); - } - static typename int32_t $id:(funName' "clz16") (typename int16_t x) { - return clz(x); - } - static typename int32_t $id:(funName' "clz32") (typename int32_t x) { - return clz(x); - } - static typename int32_t $id:(funName' "clz64") (typename int64_t x) { - return clz(x); - } -$esc:("#elif defined(__CUDA_ARCH__)") - static typename int32_t $id:(funName' "clz8") (typename int8_t x) { - return __clz(zext_i8_i32(x))-24; - } - static typename int32_t $id:(funName' "clz16") (typename int16_t x) { - return __clz(zext_i16_i32(x))-16; - } - static typename int32_t $id:(funName' "clz32") (typename int32_t x) { - return __clz(x); - } - static typename int32_t $id:(funName' "clz64") (typename int64_t x) { - return __clzll(x); - } -$esc:("#else") - static typename int32_t $id:(funName' "clz8") (typename int8_t x) { - int n = 0; - int bits = sizeof(x) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; - } - static typename int32_t $id:(funName' "clz16") (typename int16_t x) { - int n = 0; - int bits = sizeof(x) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; - } - static typename int32_t $id:(funName' "clz32") (typename int32_t x) { - int n = 0; - int bits = sizeof(x) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; - } - static typename int32_t $id:(funName' "clz64") (typename int64_t x) { - int n = 0; - int bits = sizeof(x) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; - } -$esc:("#endif") - -$esc:("#if defined(__OPENCL_VERSION__)") - // OpenCL has ctz, but only from version 2.0, which we cannot assume we are using. - static typename int32_t $id:(funName' "ctz8") (typename int8_t x) { - int i = 0; - for (; i < 8 && (x&1)==0; i++, x>>=1); - return i; - } - static typename int32_t $id:(funName' "ctz16") (typename int16_t x) { - int i = 0; - for (; i < 16 && (x&1)==0; i++, x>>=1); - return i; - } - static typename int32_t $id:(funName' "ctz32") (typename int32_t x) { - int i = 0; - for (; i < 32 && (x&1)==0; i++, x>>=1); - return i; - } - static typename int32_t $id:(funName' "ctz64") (typename int64_t x) { - int i = 0; - for (; i < 64 && (x&1)==0; i++, x>>=1); - return i; - } -$esc:("#elif defined(__CUDA_ARCH__)") - static typename int32_t $id:(funName' "ctz8") (typename int8_t x) { - int y = __ffs(x); - return y == 0 ? 8 : y-1; - } - static typename int32_t $id:(funName' "ctz16") (typename int16_t x) { - int y = __ffs(x); - return y == 0 ? 16 : y-1; - } - static typename int32_t $id:(funName' "ctz32") (typename int32_t x) { - int y = __ffs(x); - return y == 0 ? 32 : y-1; - } - static typename int32_t $id:(funName' "ctz64") (typename int64_t x) { - int y = __ffsll(x); - return y == 0 ? 64 : y-1; - } -$esc:("#else") -// FIXME: assumes GCC or clang. - static typename int32_t $id:(funName' "ctz8") (typename int8_t x) { - return x == 0 ? 8 : __builtin_ctz((typename uint32_t)x); - } - static typename int32_t $id:(funName' "ctz16") (typename int16_t x) { - return x == 0 ? 16 : __builtin_ctz((typename uint32_t)x); - } - static typename int32_t $id:(funName' "ctz32") (typename int32_t x) { - return x == 0 ? 32 : __builtin_ctz(x); - } - static typename int32_t $id:(funName' "ctz64") (typename int64_t x) { - return x == 0 ? 64 : __builtin_ctzll(x); - } -$esc:("#endif") - |] - -cFloat32Ops :: [C.Definition] -cFloat64Ops :: [C.Definition] -cFloatConvOps :: [C.Definition] -(cFloat32Ops, cFloat64Ops, cFloatConvOps) = - ( map ($ Float32) mkOps, - map ($ Float64) mkOps, - [ mkFPConvFF "fpconv" from to - | from <- [minBound .. maxBound], - to <- [minBound .. maxBound] - ] - ) - where - taggedF s Float32 = s ++ "32" - taggedF s Float64 = s ++ "64" - convOp s from to = s ++ "_" ++ pretty from ++ "_" ++ pretty to - - mkOps = - [mkFDiv, mkFAdd, mkFSub, mkFMul, mkFMin, mkFMax, mkPow, mkCmpLt, mkCmpLe] - ++ map (mkFPConvIF "sitofp") [minBound .. maxBound] - ++ map (mkFPConvUF "uitofp") [minBound .. maxBound] - ++ map (flip $ mkFPConvFI "fptosi") [minBound .. maxBound] - ++ map (flip $ mkFPConvFU "fptoui") [minBound .. maxBound] - - mkFDiv = simpleFloatOp "fdiv" [C.cexp|x / y|] - mkFAdd = simpleFloatOp "fadd" [C.cexp|x + y|] - mkFSub = simpleFloatOp "fsub" [C.cexp|x - y|] - mkFMul = simpleFloatOp "fmul" [C.cexp|x * y|] - mkFMin = simpleFloatOp "fmin" [C.cexp|fmin(x, y)|] - mkFMax = simpleFloatOp "fmax" [C.cexp|fmax(x, y)|] - mkCmpLt = floatCmpOp "cmplt" [C.cexp|x < y|] - mkCmpLe = floatCmpOp "cmple" [C.cexp|x <= y|] - - mkPow Float32 = - [C.cedecl|static inline float fpow32(float x, float y) { return pow(x, y); }|] - mkPow Float64 = - [C.cedecl|static inline double fpow64(double x, double y) { return pow(x, y); }|] - - mkFPConv from_f to_f s from_t to_t = - [C.cedecl|static inline $ty:to_ct - $id:(convOp s from_t to_t)($ty:from_ct x) { return ($ty:to_ct)x;} |] - where - from_ct = from_f from_t - to_ct = to_f to_t - - mkFPConvFF = mkFPConv floatTypeToCType floatTypeToCType - mkFPConvFI = mkFPConv floatTypeToCType intTypeToCType - mkFPConvIF = mkFPConv intTypeToCType floatTypeToCType - mkFPConvFU = mkFPConv floatTypeToCType uintTypeToCType - mkFPConvUF = mkFPConv uintTypeToCType floatTypeToCType - - simpleFloatOp s e t = - [C.cedecl|static inline $ty:ct $id:(taggedF s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where - ct = floatTypeToCType t - floatCmpOp s e t = - [C.cedecl|static inline typename bool $id:(taggedF s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where - ct = floatTypeToCType t - -cFloat32Funs :: [C.Definition] -cFloat32Funs = - [C.cunit| - static inline typename bool $id:(funName' "isnan32")(float x) { - return isnan(x); - } - - static inline typename bool $id:(funName' "isinf32")(float x) { - return isinf(x); - } - -$esc:("#ifdef __OPENCL_VERSION__") - static inline float $id:(funName' "log32")(float x) { - return log(x); - } - - static inline float $id:(funName' "log2_32")(float x) { - return log2(x); - } - - static inline float $id:(funName' "log10_32")(float x) { - return log10(x); - } - - static inline float $id:(funName' "sqrt32")(float x) { - return sqrt(x); - } - - static inline float $id:(funName' "exp32")(float x) { - return exp(x); - } - - static inline float $id:(funName' "cos32")(float x) { - return cos(x); - } - - static inline float $id:(funName' "sin32")(float x) { - return sin(x); - } - - static inline float $id:(funName' "tan32")(float x) { - return tan(x); - } - - static inline float $id:(funName' "acos32")(float x) { - return acos(x); - } - - static inline float $id:(funName' "asin32")(float x) { - return asin(x); - } - - static inline float $id:(funName' "atan32")(float x) { - return atan(x); - } - - static inline float $id:(funName' "cosh32")(float x) { - return cosh(x); - } - - static inline float $id:(funName' "sinh32")(float x) { - return sinh(x); - } - - static inline float $id:(funName' "tanh32")(float x) { - return tanh(x); - } - - static inline float $id:(funName' "acosh32")(float x) { - return acosh(x); - } - - static inline float $id:(funName' "asinh32")(float x) { - return asinh(x); - } - - static inline float $id:(funName' "atanh32")(float x) { - return atanh(x); - } - - static inline float $id:(funName' "atan2_32")(float x, float y) { - return atan2(x,y); - } - - static inline float $id:(funName' "hypot32")(float x, float y) { - return hypot(x,y); - } - - static inline float $id:(funName' "gamma32")(float x) { - return tgamma(x); - } - - static inline float $id:(funName' "lgamma32")(float x) { - return lgamma(x); - } - - static inline float fmod32(float x, float y) { - return fmod(x, y); - } - static inline float $id:(funName' "round32")(float x) { - return rint(x); - } - static inline float $id:(funName' "floor32")(float x) { - return floor(x); - } - static inline float $id:(funName' "ceil32")(float x) { - return ceil(x); - } - static inline float $id:(funName' "lerp32")(float v0, float v1, float t) { - return mix(v0, v1, t); - } - static inline float $id:(funName' "mad32")(float a, float b, float c) { - return mad(a,b,c); - } - static inline float $id:(funName' "fma32")(float a, float b, float c) { - return fma(a,b,c); - } -$esc:("#else") - static inline float $id:(funName' "log32")(float x) { - return logf(x); - } - - static inline float $id:(funName' "log2_32")(float x) { - return log2f(x); - } - - static inline float $id:(funName' "log10_32")(float x) { - return log10f(x); - } - - static inline float $id:(funName' "sqrt32")(float x) { - return sqrtf(x); - } - - static inline float $id:(funName' "exp32")(float x) { - return expf(x); - } - - static inline float $id:(funName' "cos32")(float x) { - return cosf(x); - } - - static inline float $id:(funName' "sin32")(float x) { - return sinf(x); - } - - static inline float $id:(funName' "tan32")(float x) { - return tanf(x); - } - - static inline float $id:(funName' "acos32")(float x) { - return acosf(x); - } - - static inline float $id:(funName' "asin32")(float x) { - return asinf(x); - } - - static inline float $id:(funName' "atan32")(float x) { - return atanf(x); - } - - static inline float $id:(funName' "cosh32")(float x) { - return coshf(x); - } - - static inline float $id:(funName' "sinh32")(float x) { - return sinhf(x); - } - - static inline float $id:(funName' "tanh32")(float x) { - return tanhf(x); - } - - static inline float $id:(funName' "acosh32")(float x) { - return acoshf(x); - } - - static inline float $id:(funName' "asinh32")(float x) { - return asinhf(x); - } - - static inline float $id:(funName' "atanh32")(float x) { - return atanhf(x); - } - - static inline float $id:(funName' "atan2_32")(float x, float y) { - return atan2f(x,y); - } - - static inline float $id:(funName' "hypot32")(float x, float y) { - return hypotf(x,y); - } - - static inline float $id:(funName' "gamma32")(float x) { - return tgammaf(x); - } - - static inline float $id:(funName' "lgamma32")(float x) { - return lgammaf(x); - } - - static inline float fmod32(float x, float y) { - return fmodf(x, y); - } - static inline float $id:(funName' "round32")(float x) { - return rintf(x); - } - static inline float $id:(funName' "floor32")(float x) { - return floorf(x); - } - static inline float $id:(funName' "ceil32")(float x) { - return ceilf(x); - } - static inline float $id:(funName' "lerp32")(float v0, float v1, float t) { - return v0 + (v1-v0)*t; - } - static inline float $id:(funName' "mad32")(float a, float b, float c) { - return a*b+c; - } - static inline float $id:(funName' "fma32")(float a, float b, float c) { - return fmaf(a,b,c); - } -$esc:("#endif") - static inline typename int32_t $id:(funName' "to_bits32")(float x) { - union { - float f; - typename int32_t t; - } p; - p.f = x; - return p.t; - } - - static inline float $id:(funName' "from_bits32")(typename int32_t x) { - union { - typename int32_t f; - float t; - } p; - p.f = x; - return p.t; - } - - static inline float fsignum32(float x) { - return $id:(funName' "isnan32")(x) ? x : ((x > 0) - (x < 0)); - } -|] - -cFloat64Funs :: [C.Definition] -cFloat64Funs = - [C.cunit| - static inline double $id:(funName' "log64")(double x) { - return log(x); - } - - static inline double $id:(funName' "log2_64")(double x) { - return log2(x); - } - - static inline double $id:(funName' "log10_64")(double x) { - return log10(x); - } - - static inline double $id:(funName' "sqrt64")(double x) { - return sqrt(x); - } - - static inline double $id:(funName' "exp64")(double x) { - return exp(x); - } - - static inline double $id:(funName' "cos64")(double x) { - return cos(x); - } - - static inline double $id:(funName' "sin64")(double x) { - return sin(x); - } - - static inline double $id:(funName' "tan64")(double x) { - return tan(x); - } - - static inline double $id:(funName' "acos64")(double x) { - return acos(x); - } - - static inline double $id:(funName' "asin64")(double x) { - return asin(x); - } - - static inline double $id:(funName' "atan64")(double x) { - return atan(x); - } - - static inline double $id:(funName' "cosh64")(double x) { - return cosh(x); - } - - static inline double $id:(funName' "sinh64")(double x) { - return sinh(x); - } - - static inline double $id:(funName' "tanh64")(double x) { - return tanh(x); - } - - static inline double $id:(funName' "acosh64")(double x) { - return acosh(x); - } - - static inline double $id:(funName' "asinh64")(double x) { - return asinh(x); - } - - static inline double $id:(funName' "atanh64")(double x) { - return atanh(x); - } - - static inline double $id:(funName' "atan2_64")(double x, double y) { - return atan2(x,y); - } - - static inline double $id:(funName' "hypot64")(double x, double y) { - return hypot(x,y); - } - - static inline double $id:(funName' "gamma64")(double x) { - return tgamma(x); - } - - static inline double $id:(funName' "lgamma64")(double x) { - return lgamma(x); - } - - static inline double $id:(funName' "fma64")(double a, double b, double c) { - return fma(a,b,c); - } - - static inline double $id:(funName' "round64")(double x) { - return rint(x); - } - - static inline double $id:(funName' "ceil64")(double x) { - return ceil(x); - } - - static inline double $id:(funName' "floor64")(double x) { - return floor(x); - } - - static inline typename bool $id:(funName' "isnan64")(double x) { - return isnan(x); - } - - static inline typename bool $id:(funName' "isinf64")(double x) { - return isinf(x); - } - - static inline typename int64_t $id:(funName' "to_bits64")(double x) { - union { - double f; - typename int64_t t; - } p; - p.f = x; - return p.t; - } - - static inline double $id:(funName' "from_bits64")(typename int64_t x) { - union { - typename 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 $id:(funName' "isnan64")(x) ? x : ((x > 0) - (x < 0)); - } - -$esc:("#ifdef __OPENCL_VERSION__") - static inline double $id:(funName' "lerp64")(double v0, double v1, double t) { - return mix(v0, v1, t); - } - static inline double $id:(funName' "mad64")(double a, double b, double c) { - return mad(a,b,c); - } -$esc:("#else") - static inline double $id:(funName' "lerp64")(double v0, double v1, double t) { - return v0 + (v1-v0)*t; - } - static inline double $id:(funName' "mad64")(double a, double b, double c) { - return a*b+c; - } -$esc:("#endif") -|] +-- | Implementations of scalar operations. +cScalarDefs :: T.Text +cScalarDefs = scalarH <> scalarF16H storageSize :: PrimType -> Int -> C.Exp -> C.Exp storageSize pt rank shape = @@ -1094,6 +234,7 @@ case (sign, pt) of (_, Bool) -> "bool" (_, Unit) -> "bool" + (_, FloatType Float16) -> " f16" (_, FloatType Float32) -> " f32" (_, FloatType Float64) -> " f64" (TypeDirect, IntType Int8) -> " i8" 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 @@ -70,7 +70,7 @@ import Futhark.IR.Pretty () import Futhark.IR.Primitive import Futhark.IR.Prop.Names -import Futhark.IR.Syntax +import Futhark.IR.Syntax.Core ( ErrorMsg (..), ErrorMsgPart (..), Space (..), @@ -105,6 +105,9 @@ } deriving (Show) +instance Functor Definitions where + fmap f (Definitions consts funs) = Definitions (fmap f consts) (fmap f funs) + -- | A collection of imperative functions. newtype Functions a = Functions [(Name, Function a)] deriving (Show) @@ -125,6 +128,9 @@ } deriving (Show) +instance Functor Constants where + fmap f (Constants params code) = Constants params (fmap f code) + -- | Since the core language does not care for signedness, but the -- source language does, entry point input/output information has -- metadata for integer types (and arrays containing these) that @@ -264,6 +270,9 @@ -- debugging. Code generators are free to ignore this -- statement. DebugPrint String (Maybe Exp) + | -- | Log the given message, *without* a trailing linebreak (unless + -- part of the mssage). + TracePrint (ErrorMsg Exp) | -- | Perform an extensible operation. Op a deriving (Show) @@ -517,6 +526,8 @@ text "debug" <+> parens (commasep [text (show desc), ppr e]) ppr (DebugPrint desc Nothing) = text "debug" <+> parens (text (show desc)) + ppr (TracePrint msg) = + text "trace" <+> parens (ppr msg) instance Pretty Arg where ppr (MemArg m) = ppr m @@ -599,6 +610,8 @@ Comment s <$> traverse f code traverse _ (DebugPrint s v) = pure $ DebugPrint s v + traverse _ (TracePrint msg) = + pure $ TracePrint msg -- | The names declared with 'DeclareMem', 'DeclareScalar', and -- 'DeclareArray' in the given code. @@ -670,6 +683,8 @@ freeIn' code freeIn' (DebugPrint _ v) = maybe mempty freeIn' v + freeIn' (TracePrint msg) = + foldMap freeIn' msg instance FreeIn ExpLeaf where freeIn' (Index v e _ _ _) = freeIn' v <> freeIn' 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 @@ -24,6 +24,7 @@ where import qualified Data.Map as M +import qualified Data.Text as T import Futhark.CodeGen.ImpCode hiding (Code, Function) import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.IR.GPU.Sizes @@ -31,9 +32,9 @@ -- | An program calling OpenCL kernels. data Program = Program - { openClProgram :: String, + { openClProgram :: T.Text, -- | Must be prepended to the program. - openClPrelude :: String, + openClPrelude :: T.Text, openClKernelNames :: M.Map KernelName KernelSafety, -- | So we can detect whether the device is capable. openClUsedTypes :: [PrimType], 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 @@ -21,7 +21,8 @@ AllocCompiler, Operations (..), defaultOperations, - MemLocation (..), + MemLoc (..), + sliceMemLoc, MemEntry (..), ScalarEntry (..), @@ -92,6 +93,7 @@ dPrimV, dPrimVE, dIndexSpace, + dIndexSpace', sFor, sWhile, sComment, @@ -125,7 +127,7 @@ import Data.Bifunctor (first) import qualified Data.DList as DL import Data.Either -import Data.List (find, genericLength, sortOn) +import Data.List (find) import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S @@ -151,20 +153,18 @@ import Prelude hiding (quot) -- | How to compile an t'Op'. -type OpCompiler rep r op = Pattern rep -> Op rep -> ImpM rep r op () +type OpCompiler rep r op = Pat rep -> Op rep -> ImpM rep r op () -- | How to compile some 'Stms'. type StmsCompiler rep r op = Names -> Stms rep -> ImpM rep r op () -> ImpM rep r op () -- | How to compile an 'Exp'. -type ExpCompiler rep r op = Pattern rep -> Exp rep -> ImpM rep r op () +type ExpCompiler rep r op = Pat rep -> Exp rep -> ImpM rep r op () type CopyCompiler rep r op = PrimType -> - MemLocation -> - Slice (Imp.TExp Int64) -> - MemLocation -> - Slice (Imp.TExp Int64) -> + MemLoc -> + MemLoc -> ImpM rep r op () -- | An alternate way of compiling an allocation. @@ -181,7 +181,7 @@ -- | An operations set for which the expression compiler always -- returns 'defCompileExp'. defaultOperations :: - (Mem rep, FreeIn op) => + (Mem rep inner, FreeIn op) => OpCompiler rep r op -> Operations rep r op defaultOperations opc = @@ -194,21 +194,29 @@ } -- | When an array is dared, this is where it is stored. -data MemLocation = MemLocation - { memLocationName :: VName, - memLocationShape :: [Imp.DimSize], - memLocationIxFun :: IxFun.IxFun (Imp.TExp Int64) +data MemLoc = MemLoc + { memLocName :: VName, + memLocShape :: [Imp.DimSize], + memLocIxFun :: IxFun.IxFun (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 + +flatSliceMemLoc :: MemLoc -> FlatSlice (Imp.TExp Int64) -> MemLoc +flatSliceMemLoc (MemLoc mem shape ixfun) slice = + MemLoc mem shape $ IxFun.flatSlice ixfun slice + data ArrayEntry = ArrayEntry - { entryArrayLocation :: MemLocation, + { entryArrayLoc :: MemLoc, entryArrayElemType :: PrimType } deriving (Show) entryArrayShape :: ArrayEntry -> [Imp.DimSize] -entryArrayShape = memLocationShape . entryArrayLocation +entryArrayShape = memLocShape . entryArrayLoc newtype MemEntry = MemEntry {entryMemSpace :: Imp.Space} deriving (Show) @@ -226,25 +234,14 @@ | AccVar (Maybe (Exp rep)) (VName, Shape, [Type]) deriving (Show) --- | When compiling an expression, this is a description of where the --- result should end up. The integer is a reference to the construct --- that gave rise to this destination (for patterns, this will be the --- tag of the first name in the pattern). This can be used to make --- the generated code easier to relate to the original code. -data Destination = Destination - { destinationTag :: Maybe Int, - valueDestinations :: [ValueDestination] - } - deriving (Show) - data ValueDestination = ScalarDestination VName | MemoryDestination VName - | -- | The 'MemLocation' is 'Just' if a copy if + | -- | The 'MemLoc' is 'Just' if a copy if -- required. If it is 'Nothing', then a -- copy/assignment of a memory block somewhere -- takes care of this array. - ArrayDestination (Maybe MemLocation) + ArrayDestination (Maybe MemLoc) deriving (Show) data Env rep r op = Env @@ -425,16 +422,16 @@ let Imp.Functions fs = stateFunctions s in isJust $ lookup fname fs -constsVTable :: Mem rep => Stms rep -> VTable rep +constsVTable :: Mem rep inner => Stms rep -> VTable rep constsVTable = foldMap stmVtable where stmVtable (Let pat _ e) = - foldMap (peVtable e) $ patternElements pat + foldMap (peVtable e) $ patElems pat peVtable e (PatElem name dec) = - M.singleton name $ memBoundToVarEntry (Just e) dec + M.singleton name $ memBoundToVarEntry (Just e) $ letDecMem dec compileProg :: - (Mem rep, FreeIn op, MonadFreshNames m) => + (Mem rep inner, FreeIn op, MonadFreshNames m) => r -> Operations rep r op -> Imp.Space -> @@ -496,7 +493,7 @@ (mempty, s) compileInParam :: - Mem rep => + Mem rep inner => FParam rep -> ImpM rep r op (Either Imp.Param ArrayDecl) compileInParam fparam = case paramDec fparam of @@ -508,16 +505,16 @@ return $ Right $ ArrayDecl name bt $ - MemLocation mem (shapeDims shape) $ fmap (fmap Imp.ScalarVar) ixfun + MemLoc mem (shapeDims shape) $ fmap (fmap Imp.ScalarVar) ixfun MemAcc {} -> error "Functions may not have accumulator parameters." where name = paramName fparam -data ArrayDecl = ArrayDecl VName PrimType MemLocation +data ArrayDecl = ArrayDecl VName PrimType MemLoc compileInParams :: - Mem rep => + Mem rep inner => [FParam rep] -> [EntryPointType] -> ImpM rep r op ([Imp.Param], [ArrayDecl], [Imp.ExternalValue]) @@ -540,7 +537,7 @@ mkValueDesc fparam signedness = case (findArray $ paramName fparam, paramType fparam) of - (Just (ArrayDecl _ bt (MemLocation mem shape _)), _) -> do + (Just (ArrayDecl _ bt (MemLoc mem shape _)), _) -> do memspace <- findMemInfo mem Just $ Imp.ArrayValue mem memspace bt signedness shape (_, Prim bt) -> @@ -567,87 +564,81 @@ where isArrayDecl x (ArrayDecl y _ _) = x == y -compileOutParams :: - Mem rep => +compileOutParam :: + FunReturns -> ImpM rep r op (Maybe Imp.Param, ValueDestination) +compileOutParam (MemPrim t) = do + name <- newVName "prim_out" + pure (Just $ Imp.ScalarParam name t, ScalarDestination name) +compileOutParam (MemMem space) = do + name <- newVName "mem_out" + pure (Just $ Imp.MemParam name space, MemoryDestination name) +compileOutParam MemArray {} = + pure (Nothing, ArrayDestination Nothing) +compileOutParam MemAcc {} = + error "Functions may not return accumulators." + +compileExternalValues :: + Mem rep inner => [RetType rep] -> [EntryPointType] -> - ImpM rep r op ([Imp.ExternalValue], [Imp.Param], Destination) -compileOutParams orig_rts orig_epts = do - ((extvs, dests), (outparams, ctx_dests)) <- - runWriterT $ evalStateT (mkExts orig_epts orig_rts) (M.empty, M.empty) - let ctx_dests' = map snd $ sortOn fst $ M.toList ctx_dests - return (extvs, outparams, Destination Nothing $ ctx_dests' <> dests) - where - imp = lift . lift + [Maybe Imp.Param] -> + ImpM rep r op [Imp.ExternalValue] +compileExternalValues orig_rts orig_epts maybe_params = do + let (ctx_rts, val_rts) = + splitAt (length orig_rts - sum (map entryPointSize orig_epts)) orig_rts - mkExts (TypeOpaque u desc n : epts) rts = do - let (rts', rest) = splitAt n rts - (evs, dests) <- unzip <$> zipWithM mkParam rts' (repeat Imp.TypeDirect) - (more_values, more_dests) <- mkExts epts rest - return - ( Imp.OpaqueValue u desc evs : more_values, - dests ++ more_dests - ) - mkExts (TypeUnsigned u : epts) (rt : rts) = do - (ev, dest) <- mkParam rt Imp.TypeUnsigned - (more_values, more_dests) <- mkExts epts rts - return - ( Imp.TransparentValue u ev : more_values, - dest : more_dests - ) - mkExts (TypeDirect u : epts) (rt : rts) = do - (ev, dest) <- mkParam rt Imp.TypeDirect - (more_values, more_dests) <- mkExts epts rts - return - ( Imp.TransparentValue u ev : more_values, - dest : more_dests - ) - mkExts _ _ = return ([], []) + let nthOut i = case maybeNth i maybe_params of + Just (Just p) -> Imp.paramName p + Just Nothing -> error $ "Output " ++ show i ++ " not a param." + Nothing -> error $ "Param " ++ show i ++ " does not exist." - mkParam MemMem {} _ = - error "Functions may not explicitly return memory blocks." - mkParam MemAcc {} _ = - error "Functions may not return accumulators." - mkParam (MemPrim t) ept = do - out <- imp $ newVName "scalar_out" - tell ([Imp.ScalarParam out t], mempty) - return (Imp.ScalarValue t ept out, ScalarDestination out) - mkParam (MemArray t shape _ dec) ept = do - space <- asks envDefaultSpace - memout <- case dec of - ReturnsNewBlock _ x _ixfun -> do - memout <- imp $ newVName "out_mem" - tell - ( [Imp.MemParam memout space], - M.singleton x $ MemoryDestination memout - ) - return memout - ReturnsInBlock memout _ -> - return memout - resultshape <- mapM inspectExtSize $ shapeDims shape - return - ( Imp.ArrayValue memout space t ept resultshape, - ArrayDestination Nothing - ) + mkValueDesc _ signedness (MemArray t shape _ ret) = do + (mem, space) <- + case ret of + ReturnsNewBlock space j _ixfun -> + pure (nthOut j, space) + ReturnsInBlock mem _ixfun -> do + space <- entryMemSpace <$> lookupMemory mem + pure (mem, space) + pure $ Imp.ArrayValue mem space t signedness $ map f $ shapeDims shape + where + f (Free v) = v + f (Ext i) = Var $ nthOut i + mkValueDesc i signedness (MemPrim bt) = + pure $ Imp.ScalarValue bt signedness $ nthOut i + mkValueDesc _ _ MemAcc {} = + error "mkValueDesc: unexpected MemAcc output." + mkValueDesc _ _ MemMem {} = + error "mkValueDesc: unexpected MemMem output." - inspectExtSize (Ext x) = do - (memseen, arrseen) <- get - case M.lookup x arrseen of - Nothing -> do - out <- imp $ newVName "out_arrsize" - tell - ( [Imp.ScalarParam out int64], - M.singleton x $ ScalarDestination out - ) - put (memseen, M.insert x out arrseen) - return $ Var out - Just out -> - return $ Var out - inspectExtSize (Free se) = - return se + mkExts i (TypeOpaque u desc n : epts) rets = do + let (rets', rest) = splitAt n rets + vds <- zipWithM (`mkValueDesc` Imp.TypeDirect) [i ..] rets' + (Imp.OpaqueValue u desc vds :) <$> mkExts (i + n) epts rest + mkExts i (TypeUnsigned u : epts) (ret : rets) = do + vd <- mkValueDesc i Imp.TypeUnsigned ret + (Imp.TransparentValue u vd :) <$> mkExts (i + 1) epts rets + mkExts i (TypeDirect u : epts) (ret : rets) = do + vd <- mkValueDesc i Imp.TypeDirect ret + (Imp.TransparentValue u vd :) <$> mkExts (i + 1) epts rets + mkExts _ _ _ = pure [] + mkExts (length ctx_rts) orig_epts val_rts + +compileOutParams :: + Mem rep inner => + [RetType rep] -> + Maybe [EntryPointType] -> + ImpM rep r op ([Imp.ExternalValue], [Imp.Param], [ValueDestination]) +compileOutParams orig_rts maybe_orig_epts = do + (maybe_params, dests) <- unzip <$> mapM compileOutParam orig_rts + evs <- case maybe_orig_epts of + Just orig_epts -> compileExternalValues orig_rts orig_epts maybe_params + Nothing -> pure [] + return (evs, catMaybes maybe_params, dests) + compileFunDef :: - Mem rep => + Mem rep inner => FunDef rep -> ImpM rep r op () compileFunDef (FunDef entry _ fname rettype params body) = @@ -659,31 +650,31 @@ Nothing -> ( Nothing, replicate (length params) (TypeDirect mempty), - replicate (length rettype) (TypeDirect mempty) + Nothing ) - Just (x, y, z) -> (Just x, y, z) + Just (x, y, z) -> (Just x, y, Just z) compile = do (inparams, arrayds, args) <- compileInParams params params_entry - (results, outparams, Destination _ dests) <- compileOutParams rettype ret_entry + (results, outparams, dests) <- compileOutParams rettype ret_entry addFParams params addArrays arrayds let Body _ stms ses = body compileStms (freeIn ses) stms $ - forM_ (zip dests ses) $ \(d, se) -> copyDWIMDest d [] se [] + forM_ (zip dests ses) $ \(d, SubExpRes _ se) -> copyDWIMDest d [] se [] return (outparams, inparams, results, args) -compileBody :: (Mem rep) => Pattern rep -> Body rep -> ImpM rep r op () +compileBody :: Pat rep -> Body rep -> ImpM rep r op () compileBody pat (Body _ bnds ses) = do - Destination _ dests <- destinationFromPattern pat + dests <- destinationFromPat pat compileStms (freeIn ses) bnds $ - forM_ (zip dests ses) $ \(d, se) -> copyDWIMDest d [] se [] + forM_ (zip dests ses) $ \(d, SubExpRes _ se) -> copyDWIMDest d [] se [] compileBody' :: [Param dec] -> Body rep -> ImpM rep r op () compileBody' params (Body _ bnds ses) = compileStms (freeIn ses) bnds $ - forM_ (zip params ses) $ \(param, se) -> copyDWIM (paramName param) [] se [] + forM_ (zip params ses) $ \(param, SubExpRes _ se) -> copyDWIM (paramName param) [] se [] compileLoopBody :: Typed dec => [Param dec] -> Body rep -> ImpM rep r op () compileLoopBody mergeparams (Body _ bnds ses) = do @@ -695,7 +686,7 @@ -- operations are all scalar operations. tmpnames <- mapM (newVName . (++ "_tmp") . baseString . paramName) mergeparams compileStms (freeIn ses) bnds $ do - copy_to_merge_params <- forM (zip3 mergeparams tmpnames ses) $ \(p, tmp, se) -> + copy_to_merge_params <- forM (zip3 mergeparams tmpnames ses) $ \(p, tmp, SubExpRes _ se) -> case typeOf p of Prim pt -> do emit $ Imp.DeclareScalar tmp Imp.Nonvolatile pt @@ -714,7 +705,7 @@ cb alive_after_stms all_stms m defCompileStms :: - (Mem rep, FreeIn op) => + (Mem rep inner, FreeIn op) => Names -> Stms rep -> ImpM rep r op () -> @@ -727,7 +718,7 @@ void $ compileStms' mempty $ stmsToList all_stms where compileStms' allocs (Let pat aux e : bs) = do - dVars (Just e) (patternElements pat) + dVars (Just e) (patElems pat) e_code <- localAttrs (stmAuxAttrs aux) $ @@ -748,25 +739,25 @@ emit code return $ freeIn code <> alive_after_stms - patternAllocs = S.fromList . mapMaybe isMemPatElem . patternElements + patternAllocs = S.fromList . mapMaybe isMemPatElem . patElems isMemPatElem pe = case patElemType pe of Mem space -> Just (patElemName pe, space) _ -> Nothing -compileExp :: Pattern rep -> Exp rep -> ImpM rep r op () +compileExp :: Pat rep -> Exp rep -> ImpM rep r op () compileExp pat e = do ec <- asks envExpCompiler ec pat e defCompileExp :: - (Mem rep) => - Pattern rep -> + (Mem rep inner) => + Pat rep -> Exp rep -> ImpM rep r op () defCompileExp pat (If cond tbranch fbranch _) = sIf (toBoolExp cond) (compileBody pat tbranch) (compileBody pat fbranch) defCompileExp pat (Apply fname args _ _) = do - dest <- destinationFromPattern pat + dest <- destinationFromPat pat targets <- funcallTargets dest args' <- catMaybes <$> mapM compileArg args emit $ Imp.Call targets fname args' @@ -778,16 +769,16 @@ (Var v, Mem {}) -> return $ Just $ Imp.MemArg v _ -> return Nothing defCompileExp pat (BasicOp op) = defCompileBasicOp pat op -defCompileExp pat (DoLoop ctx val form body) = do +defCompileExp pat (DoLoop merge form body) = do attrs <- askAttrs when ("unroll" `inAttrs` attrs) $ warn (noLoc :: SrcLoc) [] "#[unroll] on loop with unknown number of iterations." -- FIXME: no location. - dFParams mergepat + dFParams params forM_ merge $ \(p, se) -> when ((== 0) $ arrayRank $ paramType p) $ copyDWIM (paramName p) [] se [] - let doBody = compileLoopBody mergepat body + let doBody = compileLoopBody params body case form of ForLoop i _ bound loopvars -> do @@ -805,12 +796,11 @@ WhileLoop cond -> sWhile (TPrimExp $ Imp.var cond Bool) doBody - Destination _ pat_dests <- destinationFromPattern pat + pat_dests <- destinationFromPat pat forM_ (zip pat_dests $ map (Var . paramName . fst) merge) $ \(d, r) -> copyDWIMDest d [] r [] where - merge = ctx ++ val - mergepat = map fst merge + params = map fst merge defCompileExp pat (WithAcc inputs lam) = do dLParams $ lambdaParams lam forM_ (zip inputs $ lambdaParams lam) $ \((_, arrs, op), p) -> @@ -818,8 +808,8 @@ s {stateAccs = M.insert (paramName p) (arrs, op) $ stateAccs s} compileStms mempty (bodyStms $ lambdaBody lam) $ do let nonacc_res = drop num_accs (bodyResult (lambdaBody lam)) - nonacc_pat_names = takeLast (length nonacc_res) (patternNames pat) - forM_ (zip nonacc_pat_names nonacc_res) $ \(v, se) -> + nonacc_pat_names = takeLast (length nonacc_res) (patNames pat) + forM_ (zip nonacc_pat_names nonacc_res) $ \(v, SubExpRes _ se) -> copyDWIM v [] se [] where num_accs = length inputs @@ -827,26 +817,50 @@ opc <- asks envOpCompiler opc pat op +tracePrim :: String -> PrimType -> SubExp -> ImpM rep r op () +tracePrim s t se = + emit . Imp.TracePrint $ + ErrorMsg [ErrorString (s <> ": "), ErrorVal t (toExp' t se), ErrorString "\n"] + +traceArray :: String -> PrimType -> Shape -> SubExp -> ImpM rep r op () +traceArray s t shape se = do + emit . Imp.TracePrint $ ErrorMsg [ErrorString (s <> ": ")] + sLoopNest shape $ \is -> do + arr_elem <- dPrim "arr_elem" t + copyDWIMFix (tvVar arr_elem) [] se is + emit . Imp.TracePrint $ ErrorMsg [ErrorVal t (untyped (tvExp arr_elem)), " "] + emit . Imp.TracePrint $ ErrorMsg ["\n"] + defCompileBasicOp :: - Mem rep => - Pattern rep -> + Mem rep inner => + Pat rep -> BasicOp -> ImpM rep r op () -defCompileBasicOp (Pattern _ [pe]) (SubExp se) = +defCompileBasicOp (Pat [pe]) (SubExp se) = copyDWIM (patElemName pe) [] se [] -defCompileBasicOp (Pattern _ [pe]) (Opaque se) = +defCompileBasicOp (Pat [pe]) (Opaque op se) = do copyDWIM (patElemName pe) [] se [] -defCompileBasicOp (Pattern _ [pe]) (UnOp op e) = do + case op of + OpaqueNil -> pure () + OpaqueTrace s -> comment ("Trace: " <> s) $ do + se_t <- subExpType se + case se_t of + Prim t -> tracePrim s t se + Array t shape _ -> traceArray s t shape se + _ -> + warn [mempty :: SrcLoc] mempty $ + s ++ ": cannot trace value of this (core) type: " <> pretty se_t +defCompileBasicOp (Pat [pe]) (UnOp op e) = do e' <- toExp e patElemName pe <~~ Imp.UnOpExp op e' -defCompileBasicOp (Pattern _ [pe]) (ConvOp conv e) = do +defCompileBasicOp (Pat [pe]) (ConvOp conv e) = do e' <- toExp e patElemName pe <~~ Imp.ConvOpExp conv e' -defCompileBasicOp (Pattern _ [pe]) (BinOp bop x y) = do +defCompileBasicOp (Pat [pe]) (BinOp bop x y) = do x' <- toExp x y' <- toExp y patElemName pe <~~ Imp.BinOpExp bop x' y' -defCompileBasicOp (Pattern _ [pe]) (CmpOp bop x y) = do +defCompileBasicOp (Pat [pe]) (CmpOp bop x y) = do x' <- toExp x y' <- toExp y patElemName pe <~~ Imp.CmpOpExp bop x' y' @@ -858,21 +872,35 @@ attrs <- askAttrs when (AttrComp "warn" ["safety_checks"] `inAttrs` attrs) $ uncurry warn loc "Safety check required at run-time." -defCompileBasicOp (Pattern _ [pe]) (Index src slice) +defCompileBasicOp (Pat [pe]) (Index src slice) | Just idxs <- sliceIndices slice = copyDWIM (patElemName pe) [] (Var src) $ map (DimFix . toInt64Exp) idxs defCompileBasicOp _ Index {} = return () -defCompileBasicOp (Pattern _ [pe]) (Update _ slice se) = - sUpdate (patElemName pe) (map (fmap toInt64Exp) slice) se -defCompileBasicOp (Pattern _ [pe]) (Replicate (Shape ds) se) = do +defCompileBasicOp (Pat [pe]) (Update safety _ slice se) = + case safety of + Unsafe -> write + Safe -> sWhen (inBounds slice' dims) write + where + slice' = fmap toInt64Exp slice + dims = map toInt64Exp $ arrayDims $ patElemType pe + write = sUpdate (patElemName pe) slice' se +defCompileBasicOp _ FlatIndex {} = + pure () +defCompileBasicOp (Pat [pe]) (FlatUpdate _ slice v) = do + pe_loc <- entryArrayLoc <$> lookupArray (patElemName pe) + v_loc <- entryArrayLoc <$> lookupArray v + copy (elemType (patElemType pe)) (flatSliceMemLoc pe_loc slice') v_loc + where + slice' = fmap toInt64Exp slice +defCompileBasicOp (Pat [pe]) (Replicate (Shape ds) se) = do ds' <- mapM toExp ds is <- replicateM (length ds) (newVName "i") copy_elem <- collect $ copyDWIM (patElemName pe) (map (DimFix . Imp.vi64) is) se [] emit $ foldl (.) id (zipWith Imp.For is ds') copy_elem defCompileBasicOp _ Scratch {} = return () -defCompileBasicOp (Pattern [] [pe]) (Iota n e s it) = do +defCompileBasicOp (Pat [pe]) (Iota n e s it) = do e' <- toExp e s' <- toExp s sFor "i" (toInt64Exp n) $ \i -> do @@ -883,11 +911,11 @@ BinOpExp (Add it OverflowUndef) e' $ BinOpExp (Mul it OverflowUndef) i' s' copyDWIM (patElemName pe) [DimFix i] (Var (tvVar x)) [] -defCompileBasicOp (Pattern _ [pe]) (Copy src) = +defCompileBasicOp (Pat [pe]) (Copy src) = copyDWIM (patElemName pe) [] (Var src) [] -defCompileBasicOp (Pattern _ [pe]) (Manifest _ src) = +defCompileBasicOp (Pat [pe]) (Manifest _ src) = copyDWIM (patElemName pe) [] (Var src) [] -defCompileBasicOp (Pattern _ [pe]) (Concat i x ys _) = do +defCompileBasicOp (Pat [pe]) (Concat i x ys _) = do offs_glb <- dPrimV "tmp_offs" 0 forM_ (x : ys) $ \y -> do @@ -901,20 +929,19 @@ destslice = skip_slices ++ [DimSlice (tvExp offs_glb) rows 1] copyDWIM (patElemName pe) destslice (Var y) [] offs_glb <-- tvExp offs_glb + rows -defCompileBasicOp (Pattern [] [pe]) (ArrayLit es _) +defCompileBasicOp (Pat [pe]) (ArrayLit es _) | Just vs@(v : _) <- mapM isLiteral es = do - dest_mem <- entryArrayLocation <$> lookupArray (patElemName pe) - dest_space <- entryMemSpace <$> lookupMemory (memLocationName dest_mem) + dest_mem <- entryArrayLoc <$> lookupArray (patElemName pe) + dest_space <- entryMemSpace <$> lookupMemory (memLocName dest_mem) let t = primValueType v static_array <- newVNameForFun "static_array" emit $ Imp.DeclareArray static_array dest_space t $ Imp.ArrayValues vs let static_src = - MemLocation static_array [intConst Int64 $ fromIntegral $ length es] $ + MemLoc static_array [intConst Int64 $ fromIntegral $ length es] $ IxFun.iota [fromIntegral $ length es] entry = MemVar Nothing $ MemEntry dest_space addVar static_array entry - let slice = [DimSlice 0 (genericLength es) 1] - copy t dest_mem slice static_src slice + copy t dest_mem static_src | otherwise = forM_ (zip [0 ..] es) $ \(i, e) -> copyDWIM (patElemName pe) [DimFix $ fromInteger i] e [] @@ -940,7 +967,7 @@ -- index parameters. (_, _, arrs, dims, op) <- lookupAcc acc is' - sWhen (inBounds (map DimFix is') dims) $ + sWhen (inBounds (Slice (map DimFix is')) dims) $ case op of Nothing -> -- Scatter-like. @@ -958,7 +985,7 @@ copyDWIM yp [] v [] compileStms mempty (bodyStms $ lambdaBody lam) $ - forM_ (zip arrs (bodyResult (lambdaBody lam))) $ \(arr, se) -> + forM_ (zip arrs (bodyResult (lambdaBody lam))) $ \(arr, SubExpRes _ se) -> copyDWIMFix arr is' se [] defCompileBasicOp pat e = error $ @@ -976,13 +1003,13 @@ ArrayVar Nothing ArrayEntry - { entryArrayLocation = location, + { entryArrayLoc = location, entryArrayElemType = bt } -- | Like 'dFParams', but does not create new declarations. -- Note: a hack to be used only for functions. -addFParams :: Mem rep => [FParam rep] -> ImpM rep r op () +addFParams :: Mem rep inner => [FParam rep] -> ImpM rep r op () addFParams = mapM_ addFParam where addFParam fparam = @@ -994,7 +1021,7 @@ addLoopVar i it = addVar i $ ScalarVar Nothing $ ScalarEntry $ IntType it dVars :: - Mem rep => + Mem rep inner => Maybe (Exp rep) -> [PatElem rep] -> ImpM rep r op () @@ -1002,10 +1029,10 @@ where dVar = dScope e . scopeOfPatElem -dFParams :: Mem rep => [FParam rep] -> ImpM rep r op () +dFParams :: Mem rep inner => [FParam rep] -> ImpM rep r op () dFParams = dScope Nothing . scopeOfFParams -dLParams :: Mem rep => [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) @@ -1060,25 +1087,25 @@ memBoundToVarEntry e (MemAcc acc ispace ts _) = AccVar e (acc, ispace, ts) memBoundToVarEntry e (MemArray bt shape _ (ArrayIn mem ixfun)) = - let location = MemLocation mem (shapeDims shape) $ fmap (fmap Imp.ScalarVar) ixfun + let location = MemLoc mem (shapeDims shape) $ fmap (fmap Imp.ScalarVar) ixfun in ArrayVar e ArrayEntry - { entryArrayLocation = location, + { entryArrayLoc = location, entryArrayElemType = bt } infoDec :: - Mem rep => + Mem rep inner => NameInfo rep -> MemInfo SubExp NoUniqueness MemBind -infoDec (LetName dec) = dec +infoDec (LetName dec) = letDecMem dec infoDec (FParamName dec) = noUniquenessReturns dec infoDec (LParamName dec) = dec infoDec (IndexName it) = MemPrim $ IntType it dInfo :: - Mem rep => + Mem rep inner => Maybe (Exp rep) -> VName -> NameInfo rep -> @@ -1097,7 +1124,7 @@ addVar name entry dScope :: - Mem rep => + Mem rep inner => Maybe (Exp rep) -> Scope rep -> ImpM rep r op () @@ -1112,8 +1139,8 @@ everythingVolatile = local $ \env -> env {envVolatility = Imp.Volatile} -- | Remove the array targets. -funcallTargets :: Destination -> ImpM rep r op [VName] -funcallTargets (Destination _ dests) = +funcallTargets :: [ValueDestination] -> ImpM rep r op [VName] +funcallTargets dests = concat <$> mapM funcallTarget dests where funcallTarget (ScalarDestination name) = @@ -1267,7 +1294,7 @@ lookupArraySpace :: VName -> ImpM rep r op Space lookupArraySpace = fmap entryMemSpace . lookupMemory - <=< fmap (memLocationName . entryArrayLocation) . lookupArray + <=< fmap (memLocName . entryArrayLoc) . lookupArray -- | In the case of a histogram-like accumulator, also sets the index -- parameters. @@ -1301,16 +1328,14 @@ error $ "ImpGen.lookupAcc: unlisted accumulator: " ++ pretty name _ -> error $ "ImpGen.lookupAcc: not an accumulator: " ++ pretty name -destinationFromPattern :: Mem rep => Pattern rep -> ImpM rep r op Destination -destinationFromPattern pat = - fmap (Destination (baseTag <$> maybeHead (patternNames pat))) . mapM inspect $ - patternElements pat +destinationFromPat :: Pat rep -> ImpM rep r op [ValueDestination] +destinationFromPat = mapM inspect . patElems where - inspect patElem = do - let name = patElemName patElem + inspect pe = do + let name = patElemName pe entry <- lookupVar name case entry of - ArrayVar _ (ArrayEntry MemLocation {} _) -> + ArrayVar _ (ArrayEntry MemLoc {} _) -> return $ ArrayDestination Nothing MemVar {} -> return $ MemoryDestination name @@ -1325,13 +1350,13 @@ ImpM rep r op (VName, Imp.Space, Count Elements (Imp.TExp Int64)) fullyIndexArray name indices = do arr <- lookupArray name - fullyIndexArray' (entryArrayLocation arr) indices + fullyIndexArray' (entryArrayLoc arr) indices fullyIndexArray' :: - MemLocation -> + MemLoc -> [Imp.TExp Int64] -> ImpM rep r op (VName, Imp.Space, Count Elements (Imp.TExp Int64)) -fullyIndexArray' (MemLocation mem _ ixfun) indices = do +fullyIndexArray' (MemLoc mem _ ixfun) indices = do space <- entryMemSpace <$> lookupMemory mem return ( mem, @@ -1342,17 +1367,15 @@ -- More complicated read/write operations that use index functions. copy :: CopyCompiler rep r op -copy bt dest destslice src srcslice = do +copy bt dest src = do cc <- asks envCopyCompiler - cc bt dest destslice src srcslice + cc bt dest src -- | Is this copy really a mapping with transpose? isMapTransposeCopy :: PrimType -> - MemLocation -> - Slice (Imp.TExp Int64) -> - MemLocation -> - Slice (Imp.TExp Int64) -> + MemLoc -> + MemLoc -> Maybe ( Imp.TExp Int64, Imp.TExp Int64, @@ -1360,45 +1383,37 @@ Imp.TExp Int64, Imp.TExp Int64 ) -isMapTransposeCopy - bt - (MemLocation _ _ destIxFun) - destslice - (MemLocation _ _ srcIxFun) - srcslice - | Just (dest_offset, perm_and_destshape) <- IxFun.rearrangeWithOffset destIxFun' bt_size, - (perm, destshape) <- unzip perm_and_destshape, - Just src_offset <- IxFun.linearWithOffset srcIxFun' bt_size, - Just (r1, r2, _) <- isMapTranspose perm = - isOk destshape swap r1 r2 dest_offset src_offset - | Just dest_offset <- IxFun.linearWithOffset destIxFun' bt_size, - Just (src_offset, perm_and_srcshape) <- IxFun.rearrangeWithOffset srcIxFun' bt_size, - (perm, srcshape) <- unzip perm_and_srcshape, - Just (r1, r2, _) <- isMapTranspose perm = - isOk srcshape id r1 r2 dest_offset src_offset - | otherwise = - Nothing - where - bt_size = primByteSize bt - swap (x, y) = (y, x) - - destIxFun' = IxFun.slice destIxFun destslice - srcIxFun' = IxFun.slice srcIxFun srcslice +isMapTransposeCopy bt (MemLoc _ _ destIxFun) (MemLoc _ _ srcIxFun) + | Just (dest_offset, perm_and_destshape) <- IxFun.rearrangeWithOffset destIxFun bt_size, + (perm, destshape) <- unzip perm_and_destshape, + Just src_offset <- IxFun.linearWithOffset srcIxFun bt_size, + Just (r1, r2, _) <- isMapTranspose perm = + isOk destshape swap r1 r2 dest_offset src_offset + | Just dest_offset <- IxFun.linearWithOffset destIxFun bt_size, + Just (src_offset, perm_and_srcshape) <- IxFun.rearrangeWithOffset srcIxFun bt_size, + (perm, srcshape) <- unzip perm_and_srcshape, + Just (r1, r2, _) <- isMapTranspose perm = + isOk srcshape id r1 r2 dest_offset src_offset + | otherwise = + Nothing + where + bt_size = primByteSize bt + swap (x, y) = (y, x) - isOk shape f r1 r2 dest_offset src_offset = do - let (num_arrays, size_x, size_y) = getSizes shape f r1 r2 - return - ( dest_offset, - src_offset, - num_arrays, - size_x, - size_y - ) + isOk shape f r1 r2 dest_offset src_offset = do + let (num_arrays, size_x, size_y) = getSizes shape f r1 r2 + return + ( dest_offset, + src_offset, + 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) + 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_" ++ pretty bt @@ -1414,15 +1429,9 @@ -- | Use an 'Imp.Copy' if possible, otherwise 'copyElementWise'. defaultCopy :: CopyCompiler rep r op -defaultCopy pt dest destslice src srcslice - | Just - ( destoffset, - srcoffset, - num_arrays, - size_x, - size_y - ) <- - isMapTransposeCopy pt dest destslice src srcslice = do +defaultCopy pt dest src + | Just (destoffset, srcoffset, num_arrays, size_x, size_y) <- + isMapTransposeCopy pt dest src = do fname <- mapTransposeForType pt emit $ Imp.Call @@ -1438,13 +1447,13 @@ size_x size_y | Just destoffset <- - IxFun.linearWithOffset (IxFun.slice dest_ixfun destslice) pt_size, + IxFun.linearWithOffset dest_ixfun pt_size, Just srcoffset <- - IxFun.linearWithOffset (IxFun.slice src_ixfun srcslice) pt_size = do + IxFun.linearWithOffset src_ixfun pt_size = do srcspace <- entryMemSpace <$> lookupMemory srcmem destspace <- entryMemSpace <$> lookupMemory destmem if isScalarSpace srcspace || isScalarSpace destspace - then copyElementWise pt dest destslice src srcslice + then copyElementWise pt dest src else emit $ Imp.Copy @@ -1456,26 +1465,24 @@ srcspace $ num_elems `withElemType` pt | otherwise = - copyElementWise pt dest destslice src srcslice + copyElementWise pt dest src where pt_size = primByteSize pt - num_elems = Imp.elements $ product $ sliceDims srcslice + num_elems = Imp.elements $ product $ IxFun.shape $ memLocIxFun src - MemLocation destmem _ dest_ixfun = dest - MemLocation srcmem _ src_ixfun = src + MemLoc destmem _ dest_ixfun = dest + MemLoc srcmem _ src_ixfun = src isScalarSpace ScalarSpace {} = True isScalarSpace _ = False copyElementWise :: CopyCompiler rep r op -copyElementWise bt dest destslice src srcslice = do - let bounds = sliceDims srcslice +copyElementWise bt dest src = do + let bounds = IxFun.shape $ memLocIxFun src is <- replicateM (length bounds) (newVName "i") let ivars = map Imp.vi64 is - (destmem, destspace, destidx) <- - fullyIndexArray' dest $ fixSlice destslice ivars - (srcmem, srcspace, srcidx) <- - fullyIndexArray' src $ fixSlice srcslice ivars + (destmem, destspace, destidx) <- fullyIndexArray' dest ivars + (srcmem, srcspace, srcidx) <- fullyIndexArray' src ivars vol <- asks envVolatility emit $ foldl (.) id (zipWith Imp.For is $ map untyped bounds) $ @@ -1486,16 +1493,16 @@ -- indexeded. copyArrayDWIM :: PrimType -> - MemLocation -> + MemLoc -> [DimIndex (Imp.TExp Int64)] -> - MemLocation -> + MemLoc -> [DimIndex (Imp.TExp Int64)] -> ImpM rep r op (Imp.Code op) copyArrayDWIM bt - destlocation@(MemLocation _ destshape _) + destlocation@(MemLoc _ destshape _) destslice - srclocation@(MemLocation _ srcshape _) + srclocation@(MemLoc _ srcshape _) srcslice | Just destis <- mapM dimFix destslice, Just srcis <- mapM dimFix srcslice, @@ -1510,28 +1517,28 @@ Imp.Write targetmem targetoffset bt destspace vol $ Imp.index srcmem srcoffset bt srcspace vol | otherwise = do - let destslice' = - fullSliceNum (map toInt64Exp destshape) destslice - srcslice' = - fullSliceNum (map toInt64Exp srcshape) srcslice + let destslice' = fullSliceNum (map toInt64Exp destshape) destslice + srcslice' = fullSliceNum (map toInt64Exp srcshape) srcslice destrank = length $ sliceDims destslice' srcrank = length $ sliceDims srcslice' + destlocation' = sliceMemLoc destlocation destslice' + srclocation' = sliceMemLoc srclocation srcslice' if destrank /= srcrank then error $ "copyArrayDWIM: cannot copy to " - ++ pretty (memLocationName destlocation) + ++ pretty (memLocName destlocation) ++ " from " - ++ pretty (memLocationName srclocation) + ++ pretty (memLocName srclocation) ++ " because ranks do not match (" ++ pretty destrank ++ " vs " ++ pretty srcrank ++ ")" else - if destlocation == srclocation && destslice' == srcslice' - then return mempty -- Copy would be no-op. - else collect $ copy bt destlocation destslice' srclocation srcslice' + if destlocation' == srclocation' + then pure mempty -- Copy would be no-op. + else collect $ copy bt destlocation' srclocation' -- | Like 'copyDWIM', but the target is a 'ValueDestination' -- instead of a variable name. @@ -1591,7 +1598,7 @@ length src_slice == length (entryArrayShape arr) -> do let bt = entryArrayElemType arr (mem, space, i) <- - fullyIndexArray' (entryArrayLocation arr) src_is + fullyIndexArray' (entryArrayLoc arr) src_is vol <- asks envVolatility emit $ Imp.SetScalar name $ Imp.index mem i bt space vol | otherwise -> @@ -1605,7 +1612,7 @@ pretty src_slice ] (ArrayDestination (Just dest_loc), ArrayVar _ src_arr) -> do - let src_loc = entryArrayLocation src_arr + let src_loc = entryArrayLoc src_arr bt = entryArrayElemType src_arr emit =<< copyArrayDWIM bt dest_loc dest_slice src_loc src_slice (ArrayDestination (Just dest_loc), ScalarVar _ (ScalarEntry bt)) @@ -1643,8 +1650,8 @@ case dest_entry of ScalarVar _ _ -> ScalarDestination dest - ArrayVar _ (ArrayEntry (MemLocation mem shape ixfun) _) -> - ArrayDestination $ Just $ MemLocation mem shape ixfun + ArrayVar _ (ArrayEntry (MemLoc mem shape ixfun) _) -> + ArrayDestination $ Just $ MemLoc mem shape ixfun MemVar _ _ -> MemoryDestination dest AccVar {} -> @@ -1666,12 +1673,8 @@ -- writing the result to @dest@, which must be a single -- 'MemoryDestination', compileAlloc :: - Mem rep => - Pattern rep -> - SubExp -> - Space -> - ImpM rep r op () -compileAlloc (Pattern [] [mem]) e space = do + Mem rep inner => Pat rep -> SubExp -> Space -> ImpM rep r op () +compileAlloc (Pat [mem]) e space = do let e' = Imp.bytes $ toInt64Exp e allocator <- asks $ M.lookup space . envAllocCompilers case allocator of @@ -1690,11 +1693,11 @@ -- is useful for things like scatter, which ignores out-of-bounds -- writes. inBounds :: Slice (Imp.TExp Int64) -> [Imp.TExp Int64] -> Imp.TExp Bool -inBounds slice dims = +inBounds (Slice slice) dims = let condInBounds (DimFix i) d = 0 .<=. i .&&. i .<. d condInBounds (DimSlice i n s) d = - 0 .<=. i .&&. i + n * s .<. d + 0 .<=. i .&&. i + (n -1) * s .<. d in foldl1 (.&&.) $ zipWith condInBounds slice dims --- Building blocks for constructing code. @@ -1805,7 +1808,7 @@ emit $ Imp.Write mem offset (primExpType v) space vol v sUpdate :: VName -> Slice (Imp.TExp Int64) -> SubExp -> ImpM rep r op () -sUpdate arr slice v = copyDWIM arr slice v [] +sUpdate arr slice v = copyDWIM arr (unSlice slice) v [] sLoopNest :: Shape -> @@ -1875,3 +1878,15 @@ i' <- dPrimVE "remnant" $ i - Imp.vi64 v * size loop rest i' loop _ _ = pure () + +-- | Like 'dIndexSpace', but invent some new names for the indexes +-- based on the given template. +dIndexSpace' :: + String -> + [Imp.TExp Int64] -> + Imp.TExp Int64 -> + ImpM rep r op [Imp.TExp Int64] +dIndexSpace' desc ds j = do + ivs <- replicateM (length ds) (newVName desc) + dIndexSpace (zip ivs ds) j + pure $ map Imp.vi64 ivs 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 @@ -83,8 +83,19 @@ Prog GPUMem -> m (Warnings, Imp.Program) compileProg env prog = - second (setDefaultSpace (Imp.Space "device")) - <$> Futhark.CodeGen.ImpGen.compileProg env callKernelOperations (Imp.Space "device") prog + second (fmap setOpSpace . setDefsSpace) + <$> Futhark.CodeGen.ImpGen.compileProg env callKernelOperations device_space prog + where + device_space = Imp.Space "device" + global_space = Imp.Space "global" + setDefsSpace = setDefaultSpace device_space + setOpSpace (Imp.CallKernel kernel) = + Imp.CallKernel + kernel + { Imp.kernelBody = + setDefaultCodeSpace global_space $ Imp.kernelBody kernel + } + setOpSpace op = op -- | Compile a 'GPUMem' program to low-level parallel code, with -- either CUDA or OpenCL characteristics. @@ -95,24 +106,24 @@ compileProgCUDA = compileProg $ HostEnv cudaAtomics CUDA mempty opCompiler :: - Pattern GPUMem -> + Pat GPUMem -> Op GPUMem -> CallKernelGen () opCompiler dest (Alloc e space) = compileAlloc dest e space -opCompiler (Pattern _ [pe]) (Inner (SizeOp (GetSize key size_class))) = do +opCompiler (Pat [pe]) (Inner (SizeOp (GetSize key size_class))) = do fname <- askFunction sOp $ Imp.GetSize (patElemName pe) (keyWithEntryPoint fname key) $ sizeClassWithEntryPoint fname size_class -opCompiler (Pattern _ [pe]) (Inner (SizeOp (CmpSizeLe key size_class x))) = do +opCompiler (Pat [pe]) (Inner (SizeOp (CmpSizeLe key size_class x))) = do fname <- askFunction let size_class' = sizeClassWithEntryPoint fname size_class sOp . Imp.CmpSizeLe (patElemName pe) (keyWithEntryPoint fname key) size_class' =<< toExp x -opCompiler (Pattern _ [pe]) (Inner (SizeOp (GetSizeMax size_class))) = +opCompiler (Pat [pe]) (Inner (SizeOp (GetSizeMax size_class))) = sOp $ Imp.GetSizeMax (patElemName pe) size_class -opCompiler (Pattern _ [pe]) (Inner (SizeOp (CalcNumGroups w64 max_num_groups_key group_size))) = do +opCompiler (Pat [pe]) (Inner (SizeOp (CalcNumGroups w64 max_num_groups_key group_size))) = do fname <- askFunction max_num_groups :: TV Int32 <- dPrim "max_num_groups" int32 sOp $ @@ -147,7 +158,7 @@ sizeClassWithEntryPoint _ size_class = size_class segOpCompiler :: - Pattern GPUMem -> + Pat GPUMem -> SegOp SegLevel GPUMem -> CallKernelGen () segOpCompiler pat (SegMap lvl space _ kbody) = @@ -200,7 +211,7 @@ alignedSize x = x + ((8 - (x `rem` 8)) `rem` 8) withAcc :: - Pattern GPUMem -> + Pat GPUMem -> [(Shape, [VName], Maybe (Lambda GPUMem, [SubExp]))] -> Lambda GPUMem -> CallKernelGen () @@ -226,12 +237,12 @@ expCompiler :: ExpCompiler GPUMem HostEnv Imp.HostOp -- We generate a simple kernel for itoa and replicate. -expCompiler (Pattern _ [pe]) (BasicOp (Iota n x s et)) = do +expCompiler (Pat [pe]) (BasicOp (Iota n x s et)) = do x' <- toExp x s' <- toExp s sIota (patElemName pe) (toInt64Exp n) x' s' et -expCompiler (Pattern _ [pe]) (BasicOp (Replicate _ se)) = +expCompiler (Pat [pe]) (BasicOp (Replicate _ se)) = sReplicate (patElemName pe) se -- Allocation in the "local" space is just a placeholder. expCompiler _ (Op (Alloc _ (Space "local"))) = @@ -255,51 +266,38 @@ defCompileExp dest e callKernelCopy :: CopyCompiler GPUMem HostEnv Imp.HostOp -callKernelCopy - bt - destloc@(MemLocation destmem _ destIxFun) - destslice - srcloc@(MemLocation srcmem srcshape srcIxFun) - srcslice - | Just - ( destoffset, - srcoffset, - num_arrays, - size_x, - size_y - ) <- - isMapTransposeCopy bt destloc destslice srcloc srcslice = do - fname <- mapTransposeForType bt - 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 - ] - | bt_size <- primByteSize bt, - Just destoffset <- - IxFun.linearWithOffset (IxFun.slice destIxFun destslice) bt_size, - Just srcoffset <- - IxFun.linearWithOffset (IxFun.slice srcIxFun srcslice) bt_size = do - let num_elems = Imp.elements $ product $ map toInt64Exp srcshape - srcspace <- entryMemSpace <$> lookupMemory srcmem - destspace <- entryMemSpace <$> lookupMemory destmem - emit $ - Imp.Copy - destmem - (bytes $ sExt64 destoffset) - destspace - srcmem - (bytes $ sExt64 srcoffset) - srcspace - $ num_elems `Imp.withElemType` bt - | otherwise = sCopy bt destloc destslice srcloc srcslice +callKernelCopy bt destloc@(MemLoc destmem _ destIxFun) srcloc@(MemLoc srcmem srcshape srcIxFun) + | Just (destoffset, srcoffset, num_arrays, size_x, size_y) <- + isMapTransposeCopy bt destloc srcloc = do + fname <- mapTransposeForType bt + 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 + ] + | bt_size <- primByteSize bt, + Just destoffset <- IxFun.linearWithOffset destIxFun bt_size, + Just srcoffset <- IxFun.linearWithOffset srcIxFun bt_size = do + let num_elems = Imp.elements $ product $ map toInt64Exp srcshape + srcspace <- entryMemSpace <$> lookupMemory srcmem + destspace <- entryMemSpace <$> lookupMemory destmem + emit $ + Imp.Copy + destmem + (bytes $ sExt64 destoffset) + destspace + srcmem + (bytes $ sExt64 srcoffset) + srcspace + $ num_elems `Imp.withElemType` bt + | otherwise = sCopy bt destloc srcloc mapTransposeForType :: PrimType -> CallKernelGen Name mapTransposeForType bt = do diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Base.hs b/src/Futhark/CodeGen/ImpGen/GPU/Base.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/Base.hs @@ -104,7 +104,7 @@ S.singleton $ map snd $ unSegSpace $ segSpace op onExp (If _ tbranch fbranch _) = onStms (bodyStms tbranch) <> onStms (bodyStms fbranch) - onExp (DoLoop _ _ _ body) = + onExp (DoLoop _ _ body) = onStms (bodyStms body) onExp _ = mempty @@ -120,9 +120,9 @@ localEnv f m where mkMap ltid dims = do - let dims' = map (sExt32 . toInt64Exp) dims - ids' <- mapM (dPrimVE "ltid_pre") $ unflattenIndex dims' ltid - return (dims, ids') + let dims' = map toInt64Exp dims + ids' <- dIndexSpace' "ltid_pre" dims' (sExt64 ltid) + return (dims, map sExt32 ids') keyWithEntryPoint :: Maybe Name -> Name -> Name keyWithEntryPoint fname key = @@ -133,30 +133,30 @@ sOp $ Imp.LocalAlloc mem size kernelAlloc :: - Pattern GPUMem -> + Pat GPUMem -> SubExp -> Space -> InKernelGen () -kernelAlloc (Pattern _ [_]) _ ScalarSpace {} = +kernelAlloc (Pat [_]) _ ScalarSpace {} = -- Handled by the declaration of the memory block, which is then -- translated to an actual scalar variable during C code generation. return () -kernelAlloc (Pattern _ [mem]) size (Space "local") = +kernelAlloc (Pat [mem]) size (Space "local") = allocLocal (patElemName mem) $ Imp.bytes $ toInt64Exp size -kernelAlloc (Pattern _ [mem]) _ _ = +kernelAlloc (Pat [mem]) _ _ = compilerLimitationS $ "Cannot allocate memory block " ++ pretty mem ++ " in kernel." kernelAlloc dest _ _ = error $ "Invalid target for in-kernel allocation: " ++ show dest splitSpace :: (ToExp w, ToExp i, ToExp elems_per_thread) => - Pattern GPUMem -> + Pat GPUMem -> SplitOrdering -> w -> i -> elems_per_thread -> ImpM rep r op () -splitSpace (Pattern [] [size]) o w i elems_per_thread = do +splitSpace (Pat [size]) o w i elems_per_thread = do num_elements <- Imp.elements . TPrimExp <$> toExp w let i' = toInt64Exp i elems_per_thread' <- Imp.elements . TPrimExp <$> toExp elems_per_thread @@ -169,7 +169,7 @@ -- See the ImpGen implementation of UpdateAcc for general notes. let is' = map toInt64Exp is (c, space, arrs, dims, op) <- lookupAcc acc is' - sWhen (inBounds (map DimFix is') dims) $ + sWhen (inBounds (Slice (map DimFix is')) dims) $ case op of Nothing -> forM_ (zip arrs vs) $ \(arr, v) -> copyDWIMFix arr is' v [] @@ -194,7 +194,10 @@ error $ "Missing locks for " ++ pretty acc compileThreadExp :: ExpCompiler GPUMem KernelEnv Imp.KernelOp -compileThreadExp (Pattern _ [dest]) (BasicOp (ArrayLit es _)) = +compileThreadExp (Pat [pe]) (BasicOp (Opaque _ se)) = + -- Cannot print in GPU code. + copyDWIM (patElemName pe) [] se [] +compileThreadExp (Pat [dest]) (BasicOp (ArrayLit es _)) = forM_ (zip [0 ..] es) $ \(i, e) -> copyDWIMFix (patElemName dest) [fromIntegral (i :: Int64)] e [] compileThreadExp _ (BasicOp (UpdateAcc acc is vs)) = @@ -250,18 +253,21 @@ groupLoop (product ds) $ f . unflattenIndex ds compileGroupExp :: ExpCompiler GPUMem KernelEnv Imp.KernelOp +compileGroupExp (Pat [pe]) (BasicOp (Opaque _ se)) = + -- Cannot print in GPU code. + copyDWIM (patElemName pe) [] se [] -- The static arrays stuff does not work inside kernels. -compileGroupExp (Pattern _ [dest]) (BasicOp (ArrayLit es _)) = +compileGroupExp (Pat [dest]) (BasicOp (ArrayLit es _)) = forM_ (zip [0 ..] es) $ \(i, e) -> copyDWIMFix (patElemName dest) [fromIntegral (i :: Int64)] e [] compileGroupExp _ (BasicOp (UpdateAcc acc is vs)) = updateAcc acc is vs -compileGroupExp (Pattern _ [dest]) (BasicOp (Replicate ds se)) = do +compileGroupExp (Pat [dest]) (BasicOp (Replicate ds se)) = do let ds' = map toInt64Exp $ shapeDims ds groupCoverSpace ds' $ \is -> copyDWIMFix (patElemName dest) is se (drop (shapeRank ds) is) sOp $ Imp.Barrier Imp.FenceLocal -compileGroupExp (Pattern _ [dest]) (BasicOp (Iota n e s it)) = do +compileGroupExp (Pat [dest]) (BasicOp (Iota n e s it)) = do n' <- toExp n e' <- toExp e s' <- toExp s @@ -278,13 +284,19 @@ -- sure that only one thread performs the write. When writing an -- array, the group-level copy code will take care of doing the right -- thing. -compileGroupExp (Pattern _ [pe]) (BasicOp (Update _ slice se)) +compileGroupExp (Pat [pe]) (BasicOp (Update safety _ slice se)) | null $ sliceDims slice = do sOp $ Imp.Barrier Imp.FenceLocal ltid <- kernelLocalThreadId . kernelConstants <$> askEnv sWhen (ltid .==. 0) $ - copyDWIM (patElemName pe) (map (fmap toInt64Exp) slice) se [] + case safety of + Unsafe -> write + Safe -> sWhen (inBounds slice' dims) write sOp $ Imp.Barrier Imp.FenceLocal + where + slice' = fmap toInt64Exp slice + dims = map toInt64Exp $ arrayDims $ patElemType pe + write = copyDWIM (patElemName pe) (unSlice slice') se [] compileGroupExp dest e = defCompileExp dest e @@ -371,7 +383,7 @@ whenActive lvl space $ localOps threadOperations $ compileStms mempty (kernelBodyStms body) $ - zipWithM_ (compileThreadResult space) (patternElements pat) $ + zipWithM_ (compileThreadResult space) (patElems pat) $ kernelBodyResult body sOp $ Imp.ErrorSync Imp.FenceLocal @@ -382,7 +394,7 @@ whenActive lvl space $ compileStms mempty (kernelBodyStms body) $ - forM_ (zip (patternNames pat) $ kernelBodyResult body) $ \(dest, res) -> + forM_ (zip (patNames pat) $ kernelBodyResult body) $ \(dest, res) -> copyDWIMFix dest (map Imp.vi64 ltids) @@ -401,8 +413,8 @@ -- row-major, but does not actually verify it. dims_flat <- dPrimV "dims_flat" $ product dims' let flattened pe = do - MemLocation mem _ _ <- - entryArrayLocation <$> lookupArray (patElemName pe) + MemLoc mem _ _ <- + entryArrayLoc <$> lookupArray (patElemName pe) let pe_t = typeOf pe arr_dims = Var (tvVar dims_flat) : drop (length dims') (arrayDims pe_t) sArray @@ -413,7 +425,7 @@ num_scan_results = sum $ map (length . segBinOpNeutral) scans - arrs_flat <- mapM flattened $ take num_scan_results $ patternElements pat + arrs_flat <- mapM flattened $ take num_scan_results $ patElems pat forM_ scans $ \scan -> do let scan_op = segBinOpLambda scan @@ -423,7 +435,7 @@ let (ltids, dims) = unzip $ unSegSpace space (red_pes, map_pes) = - splitAt (segBinOpResults ops) $ patternElements pat + splitAt (segBinOpResults ops) $ patElems pat dims' = map toInt64Exp dims @@ -468,9 +480,9 @@ let flat_shape = Shape $ Var (tvVar dims_flat) : - drop (length ltids) (memLocationShape arr_loc) + drop (length ltids) (memLocShape arr_loc) sArray "red_arr_flat" pt flat_shape $ - ArrayIn (memLocationName arr_loc) $ + ArrayIn (memLocName arr_loc) $ IxFun.iota $ map pe64 $ shapeDims flat_shape let segment_size = last dims' @@ -505,7 +517,7 @@ -- the ops. let num_red_res = length ops + sum (map (length . histNeutral) ops) (_red_pes, map_pes) = - splitAt num_red_res $ patternElements pat + splitAt num_red_res $ patElems pat ops' <- prepareIntraGroupSegHist (segGroupSize lvl) ops @@ -1397,27 +1409,35 @@ f copyInGroup :: CopyCompiler GPUMem KernelEnv Imp.KernelOp -copyInGroup pt destloc destslice srcloc srcslice = do - dest_space <- entryMemSpace <$> lookupMemory (memLocationName destloc) - src_space <- entryMemSpace <$> lookupMemory (memLocationName srcloc) +copyInGroup pt destloc srcloc = do + dest_space <- entryMemSpace <$> lookupMemory (memLocName destloc) + src_space <- entryMemSpace <$> lookupMemory (memLocName srcloc) + let src_ixfun = memLocIxFun srcloc + dims = IxFun.shape src_ixfun + rank = length dims + case (dest_space, src_space) of (ScalarSpace destds _, ScalarSpace srcds _) -> do - let destslice' = - replicate (length destslice - length destds) (DimFix 0) - ++ takeLast (length destds) destslice + let fullDim d = DimSlice 0 d 1 + destslice' = + Slice $ + replicate (rank - length destds) (DimFix 0) + ++ takeLast (length destds) (map fullDim dims) srcslice' = - replicate (length srcslice - length srcds) (DimFix 0) - ++ takeLast (length srcds) srcslice - copyElementWise pt destloc destslice' srcloc srcslice' + Slice $ + replicate (rank - length srcds) (DimFix 0) + ++ takeLast (length srcds) (map fullDim dims) + copyElementWise + pt + (sliceMemLoc destloc destslice') + (sliceMemLoc srcloc srcslice') _ -> do - groupCoverSpace (sliceDims destslice) $ \is -> + groupCoverSpace dims $ \is -> copyElementWise pt - destloc - (map DimFix $ fixSlice destslice is) - srcloc - (map DimFix $ fixSlice srcslice is) + (sliceMemLoc destloc (Slice $ map DimFix is)) + (sliceMemLoc srcloc (Slice $ map DimFix is)) sOp $ Imp.Barrier Imp.FenceLocal threadOperations, groupOperations :: Operations GPUMem KernelEnv Imp.KernelOp @@ -1453,10 +1473,10 @@ keyWithEntryPoint fname $ nameFromString $ "replicate_" ++ show (baseTag $ kernelGlobalThreadIdVar constants) - is' = unflattenIndex dims $ sExt64 $ kernelGlobalThreadId constants sKernelFailureTolerant True threadOperations constants name $ do set_constants + is' <- dIndexSpace' "rep_i" dims $ sExt64 $ kernelGlobalThreadId constants sWhen (kernelThreadActive constants) $ copyDWIMFix arr is' se $ drop (length ds) is' @@ -1491,7 +1511,7 @@ replicateIsFill :: VName -> SubExp -> CallKernelGen (Maybe (CallKernelGen ())) replicateIsFill arr v = do - ArrayEntry (MemLocation arr_mem arr_shape arr_ixfun) _ <- lookupArray arr + ArrayEntry (MemLoc arr_mem arr_shape arr_ixfun) _ <- lookupArray arr v_t <- subExpType v case v_t of Prim v_t' @@ -1528,7 +1548,7 @@ IntType -> CallKernelGen () sIotaKernel arr n x s et = do - destloc <- entryArrayLocation <$> lookupArray arr + destloc <- entryArrayLoc <$> lookupArray arr (constants, set_constants) <- simpleKernelConstants n "iota" fname <- askFunction @@ -1595,7 +1615,7 @@ IntType -> CallKernelGen () sIota arr n x s et = do - ArrayEntry (MemLocation arr_mem _ arr_ixfun) _ <- lookupArray arr + ArrayEntry (MemLoc arr_mem _ arr_ixfun) _ <- lookupArray arr if IxFun.isLinear arr_ixfun then do fname <- iotaForType et @@ -1607,49 +1627,40 @@ else sIotaKernel arr n x s et sCopy :: CopyCompiler GPUMem HostEnv Imp.HostOp -sCopy - bt - destloc@(MemLocation destmem _ _) - destslice - srcloc@(MemLocation srcmem _ _) - srcslice = - do - -- Note that the shape of the destination and the source are - -- necessarily the same. - let shape = sliceDims srcslice - kernel_size = product shape +sCopy bt destloc@(MemLoc destmem _ _) srcloc@(MemLoc srcmem srcdims _) = do + -- Note that the shape of the destination and the source are + -- necessarily the same. + let shape = map toInt64Exp srcdims + kernel_size = product shape - (constants, set_constants) <- simpleKernelConstants kernel_size "copy" + (constants, set_constants) <- simpleKernelConstants kernel_size "copy" - fname <- askFunction - let name = - keyWithEntryPoint fname $ - nameFromString $ - "copy_" ++ show (baseTag $ kernelGlobalThreadIdVar constants) + fname <- askFunction + let name = + keyWithEntryPoint fname $ + nameFromString $ + "copy_" ++ show (baseTag $ kernelGlobalThreadIdVar constants) - sKernelFailureTolerant True threadOperations constants name $ do - set_constants + sKernelFailureTolerant True threadOperations constants name $ do + set_constants - let gtid = sExt64 $ kernelGlobalThreadId constants - dest_is = unflattenIndex shape gtid - src_is = dest_is + let gtid = sExt64 $ kernelGlobalThreadId constants + is <- dIndexSpace' "copy_i" shape gtid - (_, destspace, destidx) <- - fullyIndexArray' destloc $ fixSlice destslice dest_is - (_, srcspace, srcidx) <- - fullyIndexArray' srcloc $ fixSlice srcslice src_is + (_, destspace, destidx) <- fullyIndexArray' destloc is + (_, srcspace, srcidx) <- fullyIndexArray' srcloc is - sWhen (gtid .<. kernel_size) $ - emit $ - Imp.Write destmem destidx bt destspace Imp.Nonvolatile $ - Imp.index srcmem srcidx bt srcspace Imp.Nonvolatile + sWhen (gtid .<. kernel_size) $ + emit $ + Imp.Write destmem destidx bt destspace Imp.Nonvolatile $ + Imp.index srcmem srcidx bt srcspace Imp.Nonvolatile compileGroupResult :: SegSpace -> PatElem GPUMem -> KernelResult -> InKernelGen () -compileGroupResult _ pe (TileReturns [(w, per_group_elems)] what) = do +compileGroupResult _ pe (TileReturns _ [(w, per_group_elems)] what) = do n <- toInt64Exp . arraySize 0 <$> lookupType what constants <- kernelConstants <$> askEnv @@ -1669,7 +1680,7 @@ j <- dPrimVE "j" $ kernelGroupSize constants * i + ltid sWhen (j + offset .<. toInt64Exp w) $ copyDWIMFix (patElemName pe) [j + offset] (Var what) [j] -compileGroupResult space pe (TileReturns dims what) = do +compileGroupResult space pe (TileReturns _ dims what) = do let gids = map fst $ unSegSpace space out_tile_sizes = map (toInt64Exp . snd) dims group_is = zipWith (*) (map Imp.vi64 gids) out_tile_sizes @@ -1681,7 +1692,7 @@ localOps threadOperations $ sWhen (isActive $ zip (map tvVar is_for_thread) $ map fst dims) $ copyDWIMFix (patElemName pe) (map tvExp is_for_thread) (Var what) local_is -compileGroupResult space pe (RegTileReturns dims_n_tiles what) = do +compileGroupResult space pe (RegTileReturns _ dims_n_tiles what) = do constants <- kernelConstants <$> askEnv let gids = map fst $ unSegSpace space @@ -1695,8 +1706,7 @@ -- Within the group tile, which register tile is this thread -- responsible for? reg_tile_is <- - mapM (dPrimVE "reg_tile_i") $ - unflattenIndex group_tiles' $ sExt64 $ kernelLocalThreadId constants + dIndexSpace' "reg_tile_i" group_tiles' $ sExt64 $ kernelLocalThreadId constants -- Compute output array slice for the register tile belonging to -- this thread. @@ -1706,10 +1716,11 @@ reg_tile * (group_tile * group_tile_i + reg_tile_i) return $ DimSlice tile_dim_start reg_tile 1 reg_tile_slices <- - zipWithM - regTileSliceDim - (zip group_tiles' group_tile_is) - (zip reg_tiles' reg_tile_is) + Slice + <$> zipWithM + regTileSliceDim + (zip group_tiles' group_tile_is) + (zip reg_tiles' reg_tile_is) localOps threadOperations $ sLoopNest (Shape reg_tiles) $ \is_in_reg_tile -> do @@ -1717,7 +1728,7 @@ src_is = reg_tile_is ++ is_in_reg_tile sWhen (foldl1 (.&&.) $ zipWith (.<.) dest_is $ map toInt64Exp dims) $ copyDWIMFix (patElemName pe) dest_is (Var what) src_is -compileGroupResult space pe (Returns _ what) = do +compileGroupResult space pe (Returns _ _ what) = do constants <- kernelConstants <$> askEnv in_local_memory <- arrayInLocalMemory what let gids = map (Imp.vi64 . fst) $ unSegSpace space @@ -1744,33 +1755,27 @@ InKernelGen () compileThreadResult _ _ RegTileReturns {} = compilerLimitationS "compileThreadResult: RegTileReturns not yet handled." -compileThreadResult space pe (Returns _ what) = do +compileThreadResult space pe (Returns _ _ what) = do let is = map (Imp.vi64 . fst) $ unSegSpace space copyDWIMFix (patElemName pe) is what [] -compileThreadResult _ pe (ConcatReturns SplitContiguous _ per_thread_elems what) = do +compileThreadResult _ pe (ConcatReturns _ SplitContiguous _ per_thread_elems what) = do constants <- kernelConstants <$> askEnv let offset = toInt64Exp per_thread_elems * sExt64 (kernelGlobalThreadId constants) n <- toInt64Exp . arraySize 0 <$> lookupType what copyDWIM (patElemName pe) [DimSlice offset n 1] (Var what) [] -compileThreadResult _ pe (ConcatReturns (SplitStrided stride) _ _ what) = do +compileThreadResult _ pe (ConcatReturns _ (SplitStrided stride) _ _ what) = do offset <- sExt64 . kernelGlobalThreadId . kernelConstants <$> askEnv n <- toInt64Exp . arraySize 0 <$> lookupType what copyDWIM (patElemName pe) [DimSlice offset n $ toInt64Exp stride] (Var what) [] -compileThreadResult _ pe (WriteReturns (Shape rws) _arr dests) = do +compileThreadResult _ pe (WriteReturns _ (Shape rws) _arr dests) = do constants <- kernelConstants <$> askEnv let rws' = map toInt64Exp rws forM_ dests $ \(slice, e) -> do - let slice' = map (fmap toInt64Exp) slice - condInBounds (DimFix i) rw = - 0 .<=. i .&&. i .<. rw - condInBounds (DimSlice i n s) rw = - 0 .<=. i .&&. i + n * s .<. rw - write = - foldl (.&&.) (kernelThreadActive constants) $ - zipWith condInBounds slice' rws' - sWhen write $ copyDWIM (patElemName pe) slice' e [] + let slice' = fmap toInt64Exp slice + write = kernelThreadActive constants .&&. inBounds slice' rws' + sWhen write $ copyDWIM (patElemName pe) (unSlice slice') e [] compileThreadResult _ _ TileReturns {} = compilerBugS "compileThreadResult: TileReturns unhandled." @@ -1780,6 +1785,6 @@ case res of ArrayVar _ entry -> (Space "local" ==) . entryMemSpace - <$> lookupMemory (memLocationName (entryArrayLocation entry)) + <$> lookupMemory (memLocName (entryArrayLoc entry)) _ -> return False arrayInLocalMemory Constant {} = return False 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 @@ -99,7 +99,7 @@ num_subhistos <- dPrim "num_subhistos" int32 subhisto_infos <- forM (zip (histDest op) (histNeutral op)) $ \(dest, ne) -> do dest_t <- lookupType dest - dest_mem <- entryArrayLocation <$> lookupArray dest + dest_mem <- entryArrayLoc <$> lookupArray dest subhistos_mem <- sDeclareMem (baseString dest ++ "_subhistos_mem") (Space "device") @@ -122,7 +122,7 @@ SubhistosInfo subhistos $ do let unitHistoCase = emit $ - Imp.SetMem subhistos_mem (memLocationName dest_mem) $ + Imp.SetMem subhistos_mem (memLocName dest_mem) $ Space "device" multiHistoCase = do @@ -360,16 +360,16 @@ -- destination. The idea is to avoid a copy if we are writing a -- small number of values into a very large prior histogram. dests <- forM (zip (histDest op) subhisto_info) $ \(dest, info) -> do - dest_mem <- entryArrayLocation <$> lookupArray dest + dest_mem <- entryArrayLoc <$> lookupArray dest sub_mem <- - fmap memLocationName $ - entryArrayLocation + fmap memLocName $ + entryArrayLoc <$> lookupArray (subhistosArray info) let unitHistoCase = emit $ - Imp.SetMem sub_mem (memLocationName dest_mem) $ + Imp.SetMem sub_mem (memLocName dest_mem) $ Space "device" multiHistoCase = subhistosAlloc info @@ -1023,14 +1023,14 @@ -- | Generate code for a segmented histogram called from the host. compileSegHist :: - Pattern GPUMem -> + Pat GPUMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace -> [HistOp GPUMem] -> KernelBody GPUMem -> CallKernelGen () -compileSegHist (Pattern _ pes) num_groups group_size space ops kbody = do +compileSegHist (Pat pes) num_groups group_size space ops kbody = do -- Most of this function is not the histogram part itself, but -- rather figuring out whether to use a local or global memory -- strategy, as well as collapsing the subhistograms produced (which @@ -1107,10 +1107,10 @@ -- large as the ones we are supposed to use for the result. forM_ (zip red_pes subhistos) $ \(pe, subhisto) -> do pe_mem <- - memLocationName . entryArrayLocation + memLocName . entryArrayLoc <$> lookupArray (patElemName pe) subhisto_mem <- - memLocationName . entryArrayLocation + memLocName . entryArrayLoc <$> lookupArray subhisto emit $ Imp.SetMem pe_mem subhisto_mem $ Space "device" @@ -1138,7 +1138,7 @@ ++ [(subhistogram_id, Var $ tvVar num_histos)] let segred_op = SegBinOp Commutative (histOp op) (histNeutral op) mempty - compileSegRed' (Pattern [] red_pes) lvl segred_space [segred_op] $ \red_cont -> + compileSegRed' (Pat red_pes) lvl segred_space [segred_op] $ \red_cont -> red_cont $ flip map subhistos $ \subhisto -> ( Var subhisto, diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegMap.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegMap.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegMap.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegMap.hs @@ -17,7 +17,7 @@ -- | Compile 'SegMap' instance code. compileSegMap :: - Pattern GPUMem -> + Pat GPUMem -> SegLevel -> SegSpace -> KernelBody GPUMem -> @@ -46,7 +46,7 @@ sWhen (isActive $ unSegSpace space) $ compileStms mempty (kernelBodyStms kbody) $ - zipWithM_ (compileThreadResult space) (patternElements pat) $ + zipWithM_ (compileThreadResult space) (patElems pat) $ kernelBodyResult kbody SegGroup {} -> sKernelGroup "segmap_intragroup" num_groups' group_size' (segFlat space) $ do @@ -56,6 +56,6 @@ dIndexSpace (zip is dims') $ sExt64 group_id compileStms mempty (kernelBodyStms kbody) $ - zipWithM_ (compileGroupResult space) (patternElements pat) $ + zipWithM_ (compileGroupResult space) (patElems pat) $ kernelBodyResult kbody emit $ Imp.DebugPrint "" Nothing 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 @@ -77,7 +77,7 @@ -- | Compile 'SegRed' instance to host-level code with calls to -- various kernels. compileSegRed :: - Pattern GPUMem -> + Pat GPUMem -> SegLevel -> SegSpace -> [SegBinOp GPUMem] -> @@ -89,14 +89,14 @@ let (red_res, map_res) = splitAt (segBinOpResults reds) $ kernelBodyResult body sComment "save map-out results" $ do - let map_arrs = drop (segBinOpResults reds) $ patternElements pat + let map_arrs = drop (segBinOpResults reds) $ patElems pat zipWithM_ (compileThreadResult space) map_arrs map_res red_cont $ zip (map kernelResultSubExp red_res) $ repeat [] -- | Like 'compileSegRed', but where the body is a monadic action. compileSegRed' :: - Pattern GPUMem -> + Pat GPUMem -> SegLevel -> SegSpace -> [SegBinOp GPUMem] -> @@ -171,7 +171,7 @@ sAllocArrayPerm "segred_tmp" pt full_shape (Space "device") perm nonsegmentedReduction :: - Pattern GPUMem -> + Pat GPUMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace -> @@ -228,7 +228,7 @@ let segred_pes = chunks (map (length . segBinOpNeutral) reds) $ - patternElements segred_pat + patElems segred_pat forM_ (zip7 reds reds_arrs reds_group_res_arrs segred_pes slugs reds_op_renamed [0 ..]) $ \(SegBinOp _ red_op nes _, red_arrs, group_res_arrs, pes, slug, red_op_renamed, i) -> do let (red_x_params, red_y_params) = splitAt (length nes) $ lambdaParams red_op @@ -255,14 +255,14 @@ emit $ Imp.DebugPrint "" Nothing smallSegmentsReduction :: - Pattern GPUMem -> + Pat GPUMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace -> [SegBinOp GPUMem] -> DoSegBody -> CallKernelGen () -smallSegmentsReduction (Pattern _ segred_pes) num_groups group_size space reds body = do +smallSegmentsReduction (Pat segred_pes) num_groups group_size space reds body = do let (gtids, dims) = unzip $ unSegSpace space dims' = map toInt64Exp dims segment_size = last dims' @@ -364,7 +364,7 @@ emit $ Imp.DebugPrint "" Nothing largeSegmentsReduction :: - Pattern GPUMem -> + Pat GPUMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace -> @@ -466,7 +466,7 @@ let segred_pes = chunks (map (length . segBinOpNeutral) reds) $ - patternElements segred_pat + patElems segred_pat multiple_groups_per_segment = forM_ (zip7 reds reds_arrs reds_group_res_arrs segred_pes slugs reds_op_renamed [0 ..]) $ @@ -661,7 +661,7 @@ forM_ ( zip (slugAccs slug) - (bodyResult $ slugBody slug) + (map resSubExp $ bodyResult $ slugBody slug) ) $ \((acc, acc_is), se) -> copyDWIMFix acc (acc_is ++ vec_is) se [] @@ -820,7 +820,7 @@ ([0, index_of_group_res] ++ vec_is) compileStms mempty (bodyStms $ slugBody slug) $ - forM_ (zip red_x_params (bodyResult $ slugBody slug)) $ \(p, se) -> + forM_ (zip red_x_params $ map resSubExp $ bodyResult $ slugBody slug) $ \(p, se) -> copyDWIMFix (paramName p) [] se [] forM_ (zip red_x_params red_arrs) $ \(p, arr) -> 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 @@ -35,10 +35,9 @@ (concatMap (bodyResult . lambdaBody) lams) } -canBeSinglePass :: SegSpace -> [SegBinOp GPUMem] -> Maybe (SegBinOp GPUMem) -canBeSinglePass space ops - | [_] <- unSegSpace space, - all ok ops = +canBeSinglePass :: [SegBinOp GPUMem] -> Maybe (SegBinOp GPUMem) +canBeSinglePass ops + | all ok ops = Just $ combineScans ops | otherwise = Nothing @@ -50,7 +49,7 @@ -- | Compile 'SegScan' instance to host-level code with calls to -- various kernels. compileSegScan :: - Pattern GPUMem -> + Pat GPUMem -> SegLevel -> SegSpace -> [SegBinOp GPUMem] -> @@ -61,7 +60,7 @@ target <- hostTarget <$> askEnv case target of CUDA - | Just scan' <- canBeSinglePass space scans -> + | Just scan' <- canBeSinglePass scans -> SinglePass.compileSegScan pat lvl space scan' kbody _ -> TwoPass.compileSegScan pat lvl space scans kbody where 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 @@ -103,14 +103,14 @@ -- | Compile 'SegScan' instance to host-level code with calls to a -- single-pass kernel. compileSegScan :: - Pattern GPUMem -> + Pat GPUMem -> SegLevel -> SegSpace -> SegBinOp GPUMem -> KernelBody GPUMem -> CallKernelGen () compileSegScan pat lvl space scanOp kbody = do - let Pattern _ all_pes = pat + let Pat all_pes = pat group_size = toInt64Exp <$> segGroupSize lvl n = product $ map toInt64Exp $ segSpaceDims space num_groups = Count (n `divUp` (unCount group_size * m)) @@ -272,7 +272,7 @@ copyDWIMFix y [] (Var src) [i + 1] compileStms mempty (bodyStms $ lambdaBody $ segBinOpLambda scanOp) $ - forM_ (zip privateArrays $ bodyResult $ lambdaBody $ segBinOpLambda scanOp) $ \(dest, res) -> + forM_ (zip privateArrays $ map resSubExp $ bodyResult $ lambdaBody $ segBinOpLambda scanOp) $ \(dest, res) -> copyDWIMFix dest [i + 1] res [] sComment "Publish results in shared memory" $ do @@ -437,7 +437,7 @@ ( do used1 <-- tvExp used1 + tvExp used2 compileStms mempty (bodyStms $ lambdaBody scanOp'') $ - forM_ (zip3 agg1s tys $ bodyResult $ lambdaBody scanOp'') $ + forM_ (zip3 agg1s tys $ map resSubExp $ bodyResult $ lambdaBody scanOp'') $ \(agg1, ty, res) -> agg1 <~~ toExp' ty res ) flag <-- tvExp flag1 @@ -460,7 +460,7 @@ forM_ (zip xs aggrs) $ \(x, aggr) -> dPrimV_ x (tvExp aggr) forM_ (zip ys prefixes) $ \(y, prefix) -> dPrimV_ y (tvExp prefix) compileStms mempty (bodyStms $ lambdaBody scanOp''') $ - forM_ (zip3 prefixes tys $ bodyResult $ lambdaBody scanOp''') $ + forM_ (zip3 prefixes tys $ map resSubExp $ bodyResult $ lambdaBody scanOp''') $ \(prefix, ty, res) -> prefix <-- TPrimExp (toExp' ty res) -- end sWhen sOp localFence @@ -477,7 +477,7 @@ forM_ (zip ys accs) $ \(y, acc) -> dPrimV_ y $ tvExp acc compileStms mempty (bodyStms $ lambdaBody scanOp'''') $ everythingVolatile $ - forM_ (zip incprefixArrays $ bodyResult $ lambdaBody scanOp'''') $ + forM_ (zip incprefixArrays $ map resSubExp $ bodyResult $ lambdaBody scanOp'''') $ \(incprefixArray, res) -> copyDWIMFix incprefixArray [tvExp dynamicId] res [] sOp globalFence everythingVolatile $ copyDWIMFix statusFlags [tvExp dynamicId] (intConst Int8 statusP) [] @@ -513,7 +513,7 @@ sIf (kernelLocalThreadId constants * m .<. boundary .&&. bNot blockNewSgm) ( compileStms mempty (bodyStms $ lambdaBody scanOp'''''') $ - forM_ (zip3 xs tys $ bodyResult $ lambdaBody scanOp'''''') $ + forM_ (zip3 xs tys $ map resSubExp $ bodyResult $ lambdaBody scanOp'''''') $ \(x, ty, res) -> x <~~ toExp' ty res ) (forM_ (zip xs accs) $ \(x, acc) -> copyDWIMFix x [] (Var $ tvVar acc) []) @@ -528,7 +528,7 @@ -- only include prefix for the first segment part per thread copyDWIMFix y [] (Var src) [i] compileStms mempty (bodyStms $ lambdaBody scanOp''''') $ - forM_ (zip privateArrays $ bodyResult $ lambdaBody scanOp''''') $ + forM_ (zip privateArrays $ map resSubExp $ bodyResult $ lambdaBody scanOp''''') $ \(dest, res) -> copyDWIMFix dest [i] res [] 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 @@ -146,14 +146,14 @@ -- | Produce partially scanned intervals; one per workgroup. scanStage1 :: - Pattern GPUMem -> + Pat GPUMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace -> [SegBinOp GPUMem] -> KernelBody GPUMem -> CallKernelGen (TV Int32, Imp.TExp Int64, CrossesSegment) -scanStage1 (Pattern _ all_pes) num_groups group_size space scans kbody = do +scanStage1 (Pat all_pes) num_groups group_size space scans kbody = do let num_groups' = fmap toInt64Exp num_groups group_size' = fmap toInt64Exp group_size num_threads <- dPrimV "num_threads" $ sExt32 $ unCount num_groups' * unCount group_size' @@ -241,7 +241,7 @@ sComment "combine with carry and write to local memory" $ compileStms mempty (bodyStms $ lambdaBody scan_op) $ - forM_ (zip3 rets local_arrs (bodyResult $ lambdaBody scan_op)) $ + forM_ (zip3 rets local_arrs $ map resSubExp $ bodyResult $ lambdaBody scan_op) $ \(t, arr, se) -> copyDWIMFix arr [localArrayIndex constants t] se [] @@ -314,7 +314,7 @@ return (num_threads, elems_per_group, crossesSegment) scanStage2 :: - Pattern GPUMem -> + Pat GPUMem -> TV Int32 -> Imp.TExp Int64 -> Count NumGroups SubExp -> @@ -322,7 +322,7 @@ SegSpace -> [SegBinOp GPUMem] -> CallKernelGen () -scanStage2 (Pattern _ all_pes) stage1_num_threads elems_per_group num_groups crossesSegment space scans = do +scanStage2 (Pat all_pes) stage1_num_threads elems_per_group num_groups crossesSegment space scans = do let (gtids, dims) = unzip $ unSegSpace space dims' = map toInt64Exp dims @@ -391,7 +391,7 @@ [localArrayIndex constants t] scanStage3 :: - Pattern GPUMem -> + Pat GPUMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> Imp.TExp Int64 -> @@ -399,7 +399,7 @@ SegSpace -> [SegBinOp GPUMem] -> CallKernelGen () -scanStage3 (Pattern _ all_pes) num_groups group_size elems_per_group crossesSegment space scans = do +scanStage3 (Pat all_pes) num_groups group_size elems_per_group crossesSegment space scans = do let num_groups' = fmap toInt64Exp num_groups group_size' = fmap toInt64Exp group_size (gtids, dims) = unzip $ unSegSpace space @@ -478,7 +478,7 @@ -- | Compile 'SegScan' instance to host-level code with calls to -- various kernels. compileSegScan :: - Pattern GPUMem -> + Pat GPUMem -> SegLevel -> SegSpace -> [SegBinOp GPUMem] -> 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 @@ -13,24 +13,25 @@ import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State -import Data.FileEmbed import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S +import qualified Data.Text as T import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode.GPU hiding (Program) import qualified Futhark.CodeGen.ImpCode.GPU as ImpGPU import Futhark.CodeGen.ImpCode.OpenCL hiding (Program) import qualified Futhark.CodeGen.ImpCode.OpenCL as ImpOpenCL +import Futhark.CodeGen.RTS.C (atomicsH, halfH) import Futhark.Error (compilerLimitationS) import Futhark.IR.Prop (isBuiltInFunction) import Futhark.MonadFreshNames import Futhark.Util (zEncodeString) -import Futhark.Util.Pretty (prettyOneLine) -import qualified Language.C.Quote.CUDA as CUDAC +import Futhark.Util.Pretty (prettyOneLine, prettyText) import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C +import NeatInterpolation (untrimming) kernelsToCUDA, kernelsToOpenCL :: ImpGPU.Program -> ImpOpenCL.Program kernelsToCUDA = translateGPU TargetCUDA @@ -63,10 +64,10 @@ opencl_code = openClCode $ map snd $ M.elems kernels opencl_prelude = - unlines - [ pretty $ genPrelude target used_types, - unlines $ map pretty device_prototypes, - unlines $ map pretty device_defs + T.unlines + [ genPrelude target used_types, + T.unlines $ map prettyText device_prototypes, + T.unlines $ map prettyText device_defs ] in ImpOpenCL.Program opencl_code @@ -357,14 +358,14 @@ return ( Just $ SharedMemoryKArg size, Just [C.cparam|__local volatile typename int64_t* $id:mem_aligned|], - [C.citem|__local volatile char* restrict $id:mem = (__local volatile char*)$id:mem_aligned;|] + [C.citem|__local volatile unsigned char* restrict $id:mem = (__local volatile unsigned char*) $id:mem_aligned;|] ) prepareLocalMemory TargetCUDA (mem, size) = do param <- newVName $ baseString mem ++ "_offset" return ( Just $ SharedMemoryKArg size, Just [C.cparam|uint $id:param|], - [C.citem|volatile char *$id:mem = &shared_mem[$id:param];|] + [C.citem|volatile $ty:defaultMemBlockType $id:mem = &shared_mem[$id:param];|] ) useAsParam :: KernelUse -> Maybe C.Param @@ -376,7 +377,7 @@ _ -> GC.primTypeToCType bt in Just [C.cparam|$ty:ctp $id:name|] useAsParam (MemoryUse name) = - Just [C.cparam|__global unsigned char *$id:name|] + Just [C.cparam|__global $ty:defaultMemBlockType $id:name|] useAsParam ConstUse {} = Nothing @@ -395,42 +396,34 @@ undef = "#undef " ++ pretty (C.toIdent v mempty) constDef _ = Nothing -openClCode :: [C.Func] -> String +openClCode :: [C.Func] -> T.Text openClCode kernels = - pretty [C.cunit|$edecls:funcs|] + prettyText [C.cunit|$edecls:funcs|] where funcs = [ [C.cedecl|$func:kernel_func|] | kernel_func <- kernels ] -atomicsDefs :: String -atomicsDefs = $(embedStringFile "rts/c/atomics.h") - -genOpenClPrelude :: S.Set PrimType -> [C.Definition] +genOpenClPrelude :: S.Set PrimType -> T.Text genOpenClPrelude ts = - -- Clang-based OpenCL implementations need this for 'static' to work. - [ [C.cedecl|$esc:("#ifdef cl_clang_storage_class_specifiers")|], - [C.cedecl|$esc:("#pragma OPENCL EXTENSION cl_clang_storage_class_specifiers : enable")|], - [C.cedecl|$esc:("#endif")|], - [C.cedecl|$esc:("#pragma OPENCL EXTENSION cl_khr_byte_addressable_store : enable")|] - ] - ++ concat - [ [C.cunit|$esc:("#pragma OPENCL EXTENSION cl_khr_fp64 : enable") - $esc:("#define FUTHARK_F64_ENABLED")|] - | uses_float64 - ] - ++ [C.cunit| -/* Some OpenCL programs dislike empty progams, or programs with no kernels. - * Declare a dummy kernel to ensure they remain our friends. */ + [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; } -$esc:("#pragma OPENCL EXTENSION cl_khr_int64_base_atomics : enable") -$esc:("#pragma OPENCL EXTENSION cl_khr_int64_extended_atomics : enable") +#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; @@ -444,40 +437,36 @@ // 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. -$esc:("#ifdef cl_nv_pragma_unroll") +#ifdef cl_nv_pragma_unroll static inline void mem_fence_global() { asm("membar.gl;"); } -$esc:("#else") +#else static inline void mem_fence_global() { mem_fence(CLK_LOCAL_MEM_FENCE | CLK_GLOBAL_MEM_FENCE); } -$esc:("#endif") +#endif static inline void mem_fence_local() { mem_fence(CLK_LOCAL_MEM_FENCE); } |] - ++ cIntOps - ++ cFloat32Ops - ++ cFloat32Funs - ++ (if uses_float64 then cFloat64Ops ++ cFloat64Funs ++ cFloatConvOps else []) - ++ [[C.cedecl|$esc:atomicsDefs|]] + <> halfH + <> cScalarDefs + <> atomicsH where - uses_float64 = FloatType Float64 `S.member` ts + enable_f64 + | FloatType Float64 `S.member` ts = + [untrimming| + #pragma OPENCL EXTENSION cl_khr_fp64 : enable + #define FUTHARK_F64_ENABLED + |] + | otherwise = mempty -genCUDAPrelude :: [C.Definition] +genCUDAPrelude :: T.Text genCUDAPrelude = - cudafy ++ ops - where - ops = - cIntOps ++ cFloat32Ops ++ cFloat32Funs ++ cFloat64Ops - ++ cFloat64Funs - ++ cFloatConvOps - ++ [[C.cedecl|$esc:atomicsDefs|]] - cudafy = - [CUDAC.cunit| -$esc:("#define FUTHARK_CUDA") -$esc:("#define FUTHARK_F64_ENABLED") + [untrimming| +#define FUTHARK_CUDA +#define FUTHARK_F64_ENABLED typedef char int8_t; typedef short int16_t; @@ -491,16 +480,15 @@ typedef uint16_t ushort; typedef uint32_t uint; typedef uint64_t ulong; -$esc:("#define __kernel extern \"C\" __global__ __launch_bounds__(MAX_THREADS_PER_BLOCK)") -$esc:("#define __global") -$esc:("#define __local") -$esc:("#define __private") -$esc:("#define __constant") -$esc:("#define __write_only") -$esc:("#define __read_only") +#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) -{ +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; @@ -513,10 +501,9 @@ default: return 0; } } -$esc:("#define get_group_id(d) get_group_id_fn(block_dim0, block_dim1, block_dim2, d)") +#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) -{ +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; @@ -529,10 +516,9 @@ default: return 0; } } -$esc:("#define get_num_groups(d) get_num_groups_fn(block_dim0, block_dim1, block_dim2, d)") +#define get_num_groups(d) get_num_groups_fn(block_dim0, block_dim1, block_dim2, d) -static inline int get_local_id(int d) -{ +static inline int get_local_id(int d) { switch (d) { case 0: return threadIdx.x; case 1: return threadIdx.y; @@ -541,8 +527,7 @@ } } -static inline int get_local_size(int d) -{ +static inline int get_local_size(int d) { switch (d) { case 0: return blockDim.x; case 1: return blockDim.y; @@ -551,21 +536,18 @@ } } -static inline int get_global_id_fn(int block_dim0, int block_dim1, int block_dim2, int d) -{ +static inline int get_global_id_fn(int block_dim0, int block_dim1, int block_dim2, int d) { return get_group_id(d) * get_local_size(d) + get_local_id(d); } -$esc:("#define get_global_id(d) get_global_id_fn(block_dim0, block_dim1, block_dim2, d)") +#define get_global_id(d) get_global_id_fn(block_dim0, block_dim1, block_dim2, d) -static inline int get_global_size(int block_dim0, int block_dim1, int block_dim2, int d) -{ +static inline int get_global_size(int block_dim0, int block_dim1, int block_dim2, int d) { return get_num_groups(d) * get_local_size(d); } -$esc:("#define CLK_LOCAL_MEM_FENCE 1") -$esc:("#define CLK_GLOBAL_MEM_FENCE 2") -static inline void barrier(int x) -{ +#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() { @@ -575,10 +557,13 @@ __threadfence(); } -$esc:("#define NAN (0.0/0.0)") -$esc:("#define INFINITY (1.0/0.0)") -extern volatile __shared__ char shared_mem[]; +#define NAN (0.0/0.0) +#define INFINITY (1.0/0.0) +extern volatile __shared__ unsigned char shared_mem[]; |] + <> halfH + <> cScalarDefs + <> atomicsH compilePrimExp :: PrimExp KernelConst -> C.Exp compilePrimExp e = runIdentity $ GC.compilePrimExp compileKernelConst e @@ -666,7 +651,7 @@ name' <- newVName $ pretty name ++ "_backing" GC.modifyUserState $ \s -> s {kernelLocalMemory = (name', fmap untyped size) : kernelLocalMemory s} - GC.stm [C.cstm|$id:name = (__local char*) $id:name';|] + GC.stm [C.cstm|$id:name = (__local unsigned char*) $id:name';|] kernelOps (ErrorSync f) = do label <- nextErrorLabel pending <- kernelSyncPending <$> GC.getUserState @@ -738,8 +723,8 @@ -- atomicOps s (AtomicAdd t old arr ind val) = doAtomic s t old arr ind val "atomic_add" [C.cty|int|] - atomicOps s (AtomicFAdd Float32 old arr ind val) = - doAtomic s Float32 old arr ind val "atomic_fadd" [C.cty|float|] + atomicOps s (AtomicFAdd t old arr ind val) = + doAtomic s t old arr ind val "atomic_fadd" [C.cty|float|] atomicOps s (AtomicSMax t old arr ind val) = doAtomic s t old arr ind val "atomic_smax" [C.cty|int|] atomicOps s (AtomicSMin t old arr ind val) = @@ -816,14 +801,11 @@ s {kernelFailures = kernelFailures s ++ [FailureMsg msg backtrace]} let setArgs _ [] = return [] setArgs i (ErrorString {} : parts') = setArgs i parts' - setArgs i (ErrorInt32 x : parts') = do + -- FIXME: bogus for non-ints. + setArgs i (ErrorVal _ x : parts') = do x' <- GC.compileExp x stms <- setArgs (i + 1) parts' return $ [C.cstm|global_failure_args[$int:i] = (typename int64_t)$exp:x';|] : stms - setArgs i (ErrorInt64 x : parts') = do - x' <- GC.compileExp x - stms <- setArgs (i + 1) parts' - return $ [C.cstm|global_failure_args[$int:i] = $exp:x';|] : stms argstms <- setArgs (0 :: Int) parts what_next <- whatNext @@ -873,6 +855,7 @@ typesInCode (Assert e _ _) = typesInExp e typesInCode (Comment _ c) = typesInCode c typesInCode (DebugPrint _ v) = maybe mempty typesInExp v +typesInCode (TracePrint msg) = foldMap typesInExp msg typesInCode Op {} = mempty typesInExp :: Exp -> S.Set PrimType 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 @@ -58,7 +58,7 @@ -- See the ImpGen implementation of UpdateAcc for general notes. let is' = map toInt64Exp is (c, _space, arrs, dims, op) <- lookupAcc acc is' - sWhen (inBounds (map DimFix is') dims) $ + sWhen (inBounds (Slice (map DimFix is')) dims) $ case op of Nothing -> forM_ (zip arrs vs) $ \(arr, v) -> copyDWIMFix arr is' v [] @@ -83,7 +83,7 @@ error $ "Missing locks for " ++ pretty acc withAcc :: - Pattern MCMem -> + Pat MCMem -> [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))] -> Lambda MCMem -> MulticoreGen () @@ -116,7 +116,7 @@ defCompileExp dest e compileMCOp :: - Pattern MCMem -> + Pat MCMem -> MCOp MCMem () -> ImpM MCMem HostEnv Imp.Multicore () compileMCOp _ (OtherOp ()) = pure () @@ -156,7 +156,7 @@ emit $ Imp.Op $ Imp.Segop s free_params seq_task par_task retvals $ scheduling_info (decideScheduling' op seq_code) compileSegOp :: - Pattern MCMem -> + Pat MCMem -> SegOp () MCMem -> TV Int32 -> ImpM MCMem HostEnv Imp.Multicore Imp.Code 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 @@ -60,7 +60,7 @@ arrParam arr = do name_entry <- lookupVar arr case name_entry of - ArrayVar _ (ArrayEntry (MemLocation mem _ _) _) -> + ArrayVar _ (ArrayEntry (MemLoc mem _ _) _) -> return $ Imp.MemParam mem DefaultSpace _ -> error $ "arrParam: could not handle array " ++ show arr @@ -93,9 +93,9 @@ -- When the SegRed's return value is a scalar -- we perform a call by value-result in the segop function -getReturnParams :: Pattern MCMem -> SegOp () MCMem -> MulticoreGen [Imp.Param] +getReturnParams :: Pat MCMem -> SegOp () MCMem -> MulticoreGen [Imp.Param] getReturnParams pat SegRed {} = do - let retvals = map patElemName $ patternElements pat + let retvals = map patElemName $ patElems pat retvals_ts <- mapM lookupType retvals concat <$> zipWithM toParam retvals retvals_ts getReturnParams _ _ = return mempty @@ -111,7 +111,7 @@ PatElem MCMem -> KernelResult -> MulticoreGen () -compileThreadResult space pe (Returns _ what) = do +compileThreadResult space pe (Returns _ _ what) = do let is = map (Imp.vi64 . fst) $ unSegSpace space copyDWIMFix (patElemName pe) is what [] compileThreadResult _ _ ConcatReturns {} = diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs @@ -16,7 +16,7 @@ import Prelude hiding (quot, rem) compileSegHist :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [HistOp MCMem] -> KernelBody MCMem -> @@ -34,7 +34,7 @@ segHistOpChunks = chunks . map (length . histNeutral) nonsegmentedHist :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [HistOp MCMem] -> KernelBody MCMem -> @@ -91,7 +91,7 @@ return $ f l' atomicHistogram :: - Pattern MCMem -> + Pat MCMem -> TV Int64 -> SegSpace -> [HistOp MCMem] -> @@ -101,7 +101,7 @@ let (is, ns) = unzip $ unSegSpace space ns_64 = map toInt64Exp ns let num_red_res = length histops + sum (map (length . histNeutral) histops) - (all_red_pes, map_pes) = splitAt num_red_res $ patternValueElements pat + (all_red_pes, map_pes) = splitAt num_red_res $ patElems pat atomicOps <- mapM onOpAtomic histops @@ -144,7 +144,7 @@ copyDWIMFix (paramName acc_p) [] (Var arr) bucket op_body = compileBody' [] $ lambdaBody $ histOp op writeArray arr val = copyDWIMFix arr bucket val [] - do_hist = zipWithM_ writeArray arrs $ bodyResult $ lambdaBody $ histOp op + do_hist = zipWithM_ writeArray arrs $ map resSubExp $ bodyResult $ lambdaBody $ histOp op sComment "Start of body" $ do dLParams acc_params @@ -159,7 +159,7 @@ -- across the histogram indicies. -- This is expected to be fast if len(histDest) is small subHistogram :: - Pattern MCMem -> + Pat MCMem -> TV Int64 -> SegSpace -> [HistOp MCMem] -> @@ -172,10 +172,10 @@ let (is, ns) = unzip $ unSegSpace space ns_64 = map toInt64Exp ns - let pes = patternElements pat + let pes = patElems pat num_red_res = length histops + sum (map (length . histNeutral) histops) map_pes = drop num_red_res pes - per_red_pes = segHistOpChunks histops $ patternValueElements pat + per_red_pes = segHistOpChunks histops $ patElems pat -- Allocate array of subhistograms in the calling thread. Each -- tasks will work in its own private allocations (to avoid false @@ -270,7 +270,7 @@ segred_op = SegBinOp Noncommutative (histOp op) (histNeutral op) (histShape op) nsubtasks_red <- dPrim "num_tasks" $ IntType Int32 - red_code <- compileSegRed' (Pattern [] red_pes) segred_space [segred_op] nsubtasks_red $ \red_cont -> + red_code <- compileSegRed' (Pat red_pes) segred_space [segred_op] nsubtasks_red $ \red_cont -> red_cont $ flip map hists $ \subhisto -> ( Var subhisto, @@ -291,7 +291,7 @@ -- parallelize over the segments, -- where each segment is updated sequentially. segmentedHist :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [HistOp MCMem] -> KernelBody MCMem -> @@ -308,7 +308,7 @@ compileSegHistBody :: Imp.TExp Int64 -> - Pattern MCMem -> + Pat MCMem -> SegSpace -> [HistOp MCMem] -> KernelBody MCMem -> @@ -318,8 +318,8 @@ ns_64 = map toInt64Exp ns let num_red_res = length histops + sum (map (length . histNeutral) histops) - map_pes = drop num_red_res $ patternValueElements pat - per_red_pes = segHistOpChunks histops $ patternValueElements pat + map_pes = drop num_red_res $ patElems pat + per_red_pes = segHistOpChunks histops $ patElems pat collect $ do let inner_bound = last ns_64 @@ -357,5 +357,5 @@ forM_ (zip vs_params vs') $ \(p, v) -> copyDWIMFix (paramName p) [] v vec_is compileStms mempty (bodyStms $ lambdaBody lam) $ - forM_ (zip red_pes $ bodyResult $ lambdaBody lam) $ + forM_ (zip red_pes $ map resSubExp $ bodyResult $ lambdaBody lam) $ \(pe, se) -> copyDWIMFix (patElemName pe) (map Imp.vi64 (init is) ++ [buck] ++ vec_is) se [] diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs @@ -16,26 +16,21 @@ PatElemT dec -> KernelResult -> MulticoreGen () -writeResult is pe (Returns _ se) = +writeResult is pe (Returns _ _ se) = copyDWIMFix (patElemName pe) (map Imp.vi64 is) se [] -writeResult _ pe (WriteReturns (Shape rws) _ idx_vals) = do +writeResult _ pe (WriteReturns _ (Shape rws) _ idx_vals) = do let (iss, vs) = unzip idx_vals rws' = map toInt64Exp rws forM_ (zip iss vs) $ \(slice, v) -> do - let slice' = map (fmap toInt64Exp) slice - condInBounds (DimFix i) rw = - 0 .<=. i .&&. i .<. rw - condInBounds (DimSlice i n s) rw = - 0 .<=. i .&&. i + n * s .<. rw - in_bounds = foldl1 (.&&.) $ zipWith condInBounds slice' rws' - when_in_bounds = copyDWIM (patElemName pe) slice' v [] - sWhen in_bounds when_in_bounds + let slice' = fmap toInt64Exp slice + when_in_bounds = copyDWIM (patElemName pe) (unSlice slice') v [] + sWhen (inBounds slice' rws') when_in_bounds writeResult _ _ res = error $ "writeResult: cannot handle " ++ pretty res compileSegMapBody :: TV Int64 -> - Pattern MCMem -> + Pat MCMem -> SegSpace -> KernelBody MCMem -> MulticoreGen Imp.Code @@ -47,10 +42,10 @@ emit $ Imp.DebugPrint "SegMap fbody" Nothing dIndexSpace (zip is ns') $ tvExp flat_idx compileStms (freeIn kres) kstms' $ - zipWithM_ (writeResult is) (patternElements pat) kres + zipWithM_ (writeResult is) (patElems pat) kres compileSegMap :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> KernelBody MCMem -> MulticoreGen Imp.Code 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 @@ -16,7 +16,7 @@ -- | Generate code for a SegRed construct compileSegRed :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> KernelBody MCMem -> @@ -28,14 +28,14 @@ let (red_res, map_res) = splitAt (segBinOpResults reds) $ kernelBodyResult kbody sComment "save map-out results" $ do - let map_arrs = drop (segBinOpResults reds) $ patternElements pat + let map_arrs = drop (segBinOpResults reds) $ patElems pat zipWithM_ (compileThreadResult space) map_arrs map_res red_cont $ zip (map kernelResultSubExp red_res) $ repeat [] -- | Like 'compileSegRed', but where the body is a monadic action. compileSegRed' :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> TV Int32 -> @@ -72,7 +72,7 @@ nextParams slug = drop (length (slugNeutral slug)) $ slugParams slug nonsegmentedReduction :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> TV Int32 -> @@ -149,7 +149,7 @@ sComment "Red body" $ compileStms mempty (bodyStms $ slugBody slug) $ - forM_ (zip local_accs (bodyResult $ slugBody slug)) $ + forM_ (zip local_accs $ map resSubExp $ bodyResult $ slugBody slug) $ \(local_acc, se) -> copyDWIMFix local_acc vec_is se [] @@ -163,13 +163,13 @@ emit $ Imp.Op $ Imp.ParLoop "segred_stage_1" (tvVar flat_idx) (body_allocs <> prebody) fbody' postbody free_params $ segFlat space reductionStage2 :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> Imp.TExp Int32 -> [SegBinOpSlug] -> MulticoreGen () reductionStage2 pat space nsubtasks slugs = do - let per_red_pes = segBinOpChunks (map slugOp slugs) $ patternValueElements pat + let per_red_pes = segBinOpChunks (map slugOp slugs) $ patElems pat phys_id = Imp.vi64 (segFlat space) sComment "neutral-initialise the output" $ forM_ (zip (map slugOp slugs) per_red_pes) $ \(red, red_res) -> @@ -192,7 +192,7 @@ copyDWIMFix (paramName p) [] (Var acc) (phys_id : vec_is) sComment "red body" $ compileStms mempty (bodyStms $ slugBody slug) $ - forM_ (zip red_res (bodyResult $ slugBody slug)) $ + forM_ (zip red_res $ map resSubExp $ bodyResult $ slugBody slug) $ \(pe, se') -> copyDWIMFix (patElemName pe) vec_is se' [] -- Each thread reduces over the number of segments @@ -200,7 +200,7 @@ -- Maybe we should select the work of the inner loop -- based on n_segments and dimensions etc. segmentedReduction :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> DoSegBody -> @@ -215,7 +215,7 @@ compileSegRedBody :: TV Int64 -> - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> DoSegBody -> @@ -226,7 +226,7 @@ inner_bound = last ns_64 n_segments' = tvExp n_segments - let per_red_pes = segBinOpChunks reds $ patternValueElements pat + let per_red_pes = segBinOpChunks reds $ patElems pat -- Perform sequential reduce on inner most dimension collect $ do flat_idx <- dPrimVE "flat_idx" $ n_segments' * inner_bound @@ -263,5 +263,5 @@ let lbody = (lambdaBody . segBinOpLambda) red compileStms mempty (bodyStms lbody) $ sComment "write back to res" $ - forM_ (zip pes (bodyResult lbody)) $ + forM_ (zip pes $ map resSubExp $ bodyResult lbody) $ \(pe, se') -> copyDWIMFix (patElemName pe) (map Imp.vi64 (init is) ++ vec_is) se' [] diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs @@ -14,7 +14,7 @@ -- Compile a SegScan construct compileSegScan :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> KernelBody MCMem -> @@ -45,7 +45,7 @@ sAllocArray s pt full_shape DefaultSpace nonsegmentedScan :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> KernelBody MCMem -> @@ -64,7 +64,7 @@ scanStage3 pat space scan_ops3 kbody scanStage1 :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> KernelBody MCMem -> @@ -72,7 +72,7 @@ scanStage1 pat space scan_ops kbody = do let (all_scan_res, map_res) = splitAt (segBinOpResults scan_ops) $ kernelBodyResult kbody per_scan_res = segBinOpChunks scan_ops all_scan_res - per_scan_pes = segBinOpChunks scan_ops $ patternValueElements pat + per_scan_pes = segBinOpChunks scan_ops $ patElems pat let (is, ns) = unzip $ unSegSpace space ns' = map toInt64Exp ns iter <- dPrim "iter" $ IntType Int64 @@ -103,7 +103,7 @@ sComment "stage 1 scan body" $ compileStms mempty (kernelBodyStms kbody) $ do sComment "write mapped values results to memory" $ do - let map_arrs = drop (segBinOpResults scan_ops) $ patternElements pat + let map_arrs = drop (segBinOpResults scan_ops) $ patElems pat zipWithM_ (compileThreadResult space) map_arrs map_res forM_ (zip4 per_scan_pes scan_ops per_scan_res local_accs) $ \(pes, scan_op, scan_res, acc) -> @@ -118,7 +118,7 @@ copyDWIMFix (paramName p) [] (kernelResultSubExp se) vec_is compileStms mempty (bodyStms $ lamBody scan_op) $ - forM_ (zip3 acc pes (bodyResult $ lamBody scan_op)) $ + forM_ (zip3 acc pes $ map resSubExp $ bodyResult $ lamBody scan_op) $ \(acc', pe, se) -> do copyDWIMFix (patElemName pe) (map Imp.vi64 is ++ vec_is) se [] copyDWIMFix acc' vec_is se [] @@ -128,7 +128,7 @@ emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" (tvVar iter) (body_allocs <> prebody) body' mempty free_params $ segFlat space scanStage2 :: - Pattern MCMem -> + Pat MCMem -> TV Int32 -> SegSpace -> [SegBinOp MCMem] -> @@ -138,7 +138,7 @@ emit $ Imp.DebugPrint "nonsegmentedScan stage 2" Nothing let (is, ns) = unzip $ unSegSpace space ns_64 = map toInt64Exp ns - per_scan_pes = segBinOpChunks scan_ops $ patternValueElements pat + per_scan_pes = segBinOpChunks scan_ops $ patElems pat nsubtasks' = tvExp nsubtasks dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) scan_ops @@ -178,7 +178,7 @@ copyDWIMFix (paramName p) [] (Var $ patElemName pe) ((offset_index' - 1) : vec_is) compileStms mempty (bodyStms $ lamBody scan_op) $ - forM_ (zip3 acc pes (bodyResult $ lamBody scan_op)) $ + forM_ (zip3 acc pes $ map resSubExp $ bodyResult $ lamBody scan_op) $ \(acc', pe, se) -> do copyDWIMFix (patElemName pe) ((offset_index' - 1) : vec_is) se [] copyDWIMFix acc' vec_is se [] @@ -186,7 +186,7 @@ -- Stage 3 : Finally each thread partially scans a chunk of the input -- reading its corresponding carry-in scanStage3 :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> KernelBody MCMem -> @@ -195,7 +195,7 @@ let (is, ns) = unzip $ unSegSpace space all_scan_res = take (segBinOpResults scan_ops) $ kernelBodyResult kbody per_scan_res = segBinOpChunks scan_ops all_scan_res - per_scan_pes = segBinOpChunks scan_ops $ patternValueElements pat + per_scan_pes = segBinOpChunks scan_ops $ patElems pat ns' = map toInt64Exp ns iter <- dPrimV "iter" (0 :: Imp.TExp Int64) @@ -238,7 +238,7 @@ copyDWIMFix (paramName p) [] (kernelResultSubExp se) vec_is compileStms mempty (bodyStms $ lamBody scan_op) $ - forM_ (zip3 pes (bodyResult $ lamBody scan_op) acc) $ + forM_ (zip3 pes (map resSubExp $ bodyResult $ lamBody scan_op) acc) $ \(pe, se, acc') -> do copyDWIMFix (patElemName pe) (map Imp.vi64 is ++ vec_is) se [] copyDWIMFix acc' vec_is se [] @@ -251,7 +251,7 @@ -- parallelize over the segments and each segment is -- scanned sequentially. segmentedScan :: - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> KernelBody MCMem -> @@ -267,7 +267,7 @@ compileSegScanBody :: Imp.TExp Int64 -> - Pattern MCMem -> + Pat MCMem -> SegSpace -> [SegBinOp MCMem] -> KernelBody MCMem -> @@ -276,7 +276,7 @@ let (is, ns) = unzip $ unSegSpace space ns_64 = map toInt64Exp ns - let per_scan_pes = segBinOpChunks scan_ops $ patternValueElements pat + let per_scan_pes = segBinOpChunks scan_ops $ patElems pat collect $ forM_ (zip scan_ops per_scan_pes) $ \(scan_op, scan_pes) -> do dScope Nothing $ scopeOfLParams $ lambdaParams $ segBinOpLambda scan_op @@ -297,11 +297,11 @@ copyDWIMFix (paramName p) [] (kernelResultSubExp se) [] sComment "write mapped values results to memory" $ - forM_ (zip (drop (length $ segBinOpNeutral scan_op) $ patternElements pat) map_res) $ \(pe, se) -> + forM_ (zip (drop (length $ segBinOpNeutral scan_op) $ patElems pat) map_res) $ \(pe, se) -> copyDWIMFix (patElemName pe) (map Imp.vi64 is) (kernelResultSubExp se) [] sComment "combine with carry and write to memory" $ compileStms mempty (bodyStms $ lambdaBody $ segBinOpLambda scan_op) $ - forM_ (zip3 scan_x_params scan_pes (bodyResult $ lambdaBody $ segBinOpLambda scan_op)) $ \(p, pe, se) -> do + forM_ (zip3 scan_x_params scan_pes $ map resSubExp $ bodyResult $ lambdaBody $ segBinOpLambda scan_op) $ \(p, pe, se) -> do copyDWIMFix (patElemName pe) (map Imp.vi64 is) se [] copyDWIMFix (paramName p) [] se [] diff --git a/src/Futhark/CodeGen/RTS/C.hs b/src/Futhark/CodeGen/RTS/C.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/RTS/C.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Code snippets used by the C backends. +module Futhark.CodeGen.RTS.C + ( atomicsH, + chaselevH, + cudaH, + freeListH, + halfH, + lockH, + openclH, + scalarF16H, + scalarH, + schedulerH, + serverH, + timingH, + tuningH, + utilH, + valuesH, + ) +where + +import Data.FileEmbed +import qualified Data.Text as T + +-- We mark everything here NOINLINE so that the dependent modules +-- don't have to be recompiled just because we change the RTS files. + +-- | @rts/c/atomics.h@ +atomicsH :: T.Text +atomicsH = $(embedStringFile "rts/c/atomics.h") +{-# NOINLINE atomicsH #-} + +-- | @rts/c/chaselev.h@ +chaselevH :: T.Text +chaselevH = $(embedStringFile "rts/c/chaselev.h") +{-# NOINLINE chaselevH #-} + +-- | @rts/c/cuda.h@ +cudaH :: T.Text +cudaH = $(embedStringFile "rts/c/cuda.h") +{-# NOINLINE cudaH #-} + +-- | @rts/c/free_list.h@ +freeListH :: T.Text +freeListH = $(embedStringFile "rts/c/free_list.h") +{-# NOINLINE freeListH #-} + +-- | @rts/c/half.h@ +halfH :: T.Text +halfH = $(embedStringFile "rts/c/half.h") +{-# NOINLINE halfH #-} + +-- | @rts/c/lock.h@ +lockH :: T.Text +lockH = $(embedStringFile "rts/c/lock.h") +{-# NOINLINE lockH #-} + +-- | @rts/c/opencl.h@ +openclH :: T.Text +openclH = $(embedStringFile "rts/c/opencl.h") +{-# NOINLINE openclH #-} + +-- | @rts/c/scalar_f16.h@ +scalarF16H :: T.Text +scalarF16H = $(embedStringFile "rts/c/scalar_f16.h") +{-# NOINLINE scalarF16H #-} + +-- | @rts/c/scalar.h@ +scalarH :: T.Text +scalarH = $(embedStringFile "rts/c/scalar.h") +{-# NOINLINE scalarH #-} + +-- | @rts/c/scheduler.h@ +schedulerH :: T.Text +schedulerH = $(embedStringFile "rts/c/scheduler.h") +{-# NOINLINE schedulerH #-} + +-- | @rts/c/server.h@ +serverH :: T.Text +serverH = $(embedStringFile "rts/c/server.h") +{-# NOINLINE serverH #-} + +-- | @rts/c/timing.h@ +timingH :: T.Text +timingH = $(embedStringFile "rts/c/timing.h") +{-# NOINLINE timingH #-} + +-- | @rts/c/tuning.h@ +tuningH :: T.Text +tuningH = $(embedStringFile "rts/c/tuning.h") +{-# NOINLINE tuningH #-} + +-- | @rts/c/util.h@ +utilH :: T.Text +utilH = $(embedStringFile "rts/c/util.h") +{-# NOINLINE utilH #-} + +-- | @rts/c/values.h@ +valuesH :: T.Text +valuesH = $(embedStringFile "rts/c/values.h") +{-# NOINLINE valuesH #-} diff --git a/src/Futhark/CodeGen/RTS/JavaScript.hs b/src/Futhark/CodeGen/RTS/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/RTS/JavaScript.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Code snippets used by the JS backends. +module Futhark.CodeGen.RTS.JavaScript + ( serverJs, + valuesJs, + wrapperclassesJs, + ) +where + +import Data.FileEmbed +import qualified Data.Text as T + +-- | @rts/javascript/server.js@ +serverJs :: T.Text +serverJs = $(embedStringFile "rts/javascript/server.js") + +-- | @rts/javascript/values.js@ +valuesJs :: T.Text +valuesJs = $(embedStringFile "rts/javascript/values.js") + +-- | @rts/javascript/wrapperclasses.js@ +wrapperclassesJs :: T.Text +wrapperclassesJs = $(embedStringFile "rts/javascript/wrapperclasses.js") diff --git a/src/Futhark/CodeGen/RTS/Python.hs b/src/Futhark/CodeGen/RTS/Python.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/RTS/Python.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Code snippets used by the Python backends. +module Futhark.CodeGen.RTS.Python + ( memoryPy, + openclPy, + panicPy, + scalarPy, + serverPy, + tuningPy, + valuesPy, + ) +where + +import Data.FileEmbed +import qualified Data.Text as T + +-- | @rts/python/memory.py@ +memoryPy :: T.Text +memoryPy = $(embedStringFile "rts/python/memory.py") + +-- | @rts/python/opencl.py@ +openclPy :: T.Text +openclPy = $(embedStringFile "rts/python/opencl.py") + +-- | @rts/python/panic.py@ +panicPy :: T.Text +panicPy = $(embedStringFile "rts/python/panic.py") + +-- | @rts/python/scalar.py@ +scalarPy :: T.Text +scalarPy = $(embedStringFile "rts/python/scalar.py") + +-- | @rts/python/server.py@ +serverPy :: T.Text +serverPy = $(embedStringFile "rts/python/server.py") + +-- | @rts/python/tuning.py@ +tuningPy :: T.Text +tuningPy = $(embedStringFile "rts/python/tuning.py") + +-- | @rts/python/values.py@ +valuesPy :: T.Text +valuesPy = $(embedStringFile "rts/python/values.py") diff --git a/src/Futhark/CodeGen/SetDefaultSpace.hs b/src/Futhark/CodeGen/SetDefaultSpace.hs --- a/src/Futhark/CodeGen/SetDefaultSpace.hs +++ b/src/Futhark/CodeGen/SetDefaultSpace.hs @@ -4,6 +4,7 @@ -- assumes that 'DefaultSpace' is CPU memory. module Futhark.CodeGen.SetDefaultSpace ( setDefaultSpace, + setDefaultCodeSpace, ) where @@ -14,20 +15,24 @@ setDefaultSpace :: Space -> Definitions op -> Definitions op setDefaultSpace space (Definitions (Constants ps consts) (Functions fundecs)) = Definitions - (Constants (map (setParamSpace space) ps) (setBodySpace space consts)) + (Constants (map (setParamSpace space) ps) (setCodeSpace space consts)) ( Functions [ (fname, setFunctionSpace space func) | (fname, func) <- fundecs ] ) +-- | Like 'setDefaultSpace', but for 'Code'. +setDefaultCodeSpace :: Space -> Code op -> Code op +setDefaultCodeSpace = setCodeSpace + setFunctionSpace :: Space -> Function op -> Function op setFunctionSpace space (Function entry outputs inputs body results args) = Function entry (map (setParamSpace space) outputs) (map (setParamSpace space) inputs) - (setBodySpace space body) + (setCodeSpace space body) (map (setExtValueSpace space) results) (map (setExtValueSpace space) args) @@ -49,16 +54,16 @@ setValueSpace _ (ScalarValue bt ept v) = ScalarValue bt ept v -setBodySpace :: Space -> Code op -> Code op -setBodySpace space (Allocate v e old_space) = +setCodeSpace :: Space -> Code op -> Code op +setCodeSpace space (Allocate v e old_space) = Allocate v (fmap (setTExpSpace space) e) $ setSpace space old_space -setBodySpace space (Free v old_space) = +setCodeSpace space (Free v old_space) = Free v $ setSpace space old_space -setBodySpace space (DeclareMem name old_space) = +setCodeSpace space (DeclareMem name old_space) = DeclareMem name $ setSpace space old_space -setBodySpace space (DeclareArray name _ t vs) = +setCodeSpace space (DeclareArray name _ t vs) = DeclareArray name space t vs -setBodySpace space (Copy dest dest_offset dest_space src src_offset src_space n) = +setCodeSpace space (Copy dest dest_offset dest_space src src_offset src_space n) = Copy dest (fmap (setTExpSpace space) dest_offset) @@ -70,7 +75,7 @@ where dest_space' = setSpace space dest_space src_space' = setSpace space src_space -setBodySpace space (Write dest dest_offset bt dest_space vol e) = +setCodeSpace space (Write dest dest_offset bt dest_space vol e) = Write dest (fmap (setTExpSpace space) dest_offset) @@ -78,34 +83,36 @@ (setSpace space dest_space) vol (setExpSpace space e) -setBodySpace space (c1 :>>: c2) = - setBodySpace space c1 :>>: setBodySpace space c2 -setBodySpace space (For i e body) = - For i (setExpSpace space e) $ setBodySpace space body -setBodySpace space (While e body) = - While (setTExpSpace space e) $ setBodySpace space body -setBodySpace space (If e c1 c2) = - If (setTExpSpace space e) (setBodySpace space c1) (setBodySpace space c2) -setBodySpace space (Comment s c) = - Comment s $ setBodySpace space c -setBodySpace _ Skip = +setCodeSpace space (c1 :>>: c2) = + setCodeSpace space c1 :>>: setCodeSpace space c2 +setCodeSpace space (For i e body) = + For i (setExpSpace space e) $ setCodeSpace space body +setCodeSpace space (While e body) = + While (setTExpSpace space e) $ setCodeSpace space body +setCodeSpace space (If e c1 c2) = + If (setTExpSpace space e) (setCodeSpace space c1) (setCodeSpace space c2) +setCodeSpace space (Comment s c) = + Comment s $ setCodeSpace space c +setCodeSpace _ Skip = Skip -setBodySpace _ (DeclareScalar name vol bt) = +setCodeSpace _ (DeclareScalar name vol bt) = DeclareScalar name vol bt -setBodySpace space (SetScalar name e) = +setCodeSpace space (SetScalar name e) = SetScalar name $ setExpSpace space e -setBodySpace space (SetMem to from old_space) = +setCodeSpace space (SetMem to from old_space) = SetMem to from $ setSpace space old_space -setBodySpace space (Call dests fname args) = +setCodeSpace space (Call dests fname args) = Call dests fname $ map setArgSpace args where setArgSpace (MemArg m) = MemArg m setArgSpace (ExpArg e) = ExpArg $ setExpSpace space e -setBodySpace space (Assert e msg loc) = - Assert (setExpSpace space e) msg loc -setBodySpace space (DebugPrint s v) = +setCodeSpace space (Assert e msg loc) = + Assert (setExpSpace space e) (fmap (setExpSpace space) msg) loc +setCodeSpace space (DebugPrint s v) = DebugPrint s $ fmap (setExpSpace space) v -setBodySpace _ (Op op) = +setCodeSpace space (TracePrint msg) = + TracePrint $ fmap (setExpSpace space) msg +setCodeSpace _ (Op op) = Op op setExpSpace :: Space -> Exp -> Exp diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -16,29 +16,29 @@ -- own bespoke source of unique names) to manually construct -- expressions, statements, and entire ASTs. In practice, this would -- be very tedious. Instead, we have defined a collection of building --- blocks (centered around the 'MonadBinder' type class) that permits +-- blocks (centered around the 'MonadBuilder' type class) that permits -- a more abstract way of generating code. -- -- Constructing ASTs with these building blocks requires you to ensure -- that all free variables are in scope. See -- "Futhark.IR.Prop.Scope". -- --- == 'MonadBinder' +-- == 'MonadBuilder' -- --- A monad that implements 'MonadBinder' tracks the statements added +-- A monad that implements 'MonadBuilder' tracks the statements added -- so far, the current names in scope, and allows you to add -- additional statements with 'addStm'. Any monad that implements --- 'MonadBinder' also implements the t'REp' type family, which --- indicates which rep it works with. Inside a 'MonadBinder' we can +-- 'MonadBuilder' also implements the t'Rep' type family, which +-- indicates which rep it works with. Inside a 'MonadBuilder' we can -- use 'collectStms' to gather up the 'Stms' added with 'addStm' in -- some nested computation. -- --- The 'BinderT' monad (and its convenient 'Binder' version) provides --- the simplest implementation of 'MonadBinder'. +-- The 'BuilderT' monad (and its convenient 'Builder' version) provides +-- the simplest implementation of 'MonadBuilder'. -- -- == Higher-level building blocks -- --- On top of the raw facilities provided by 'MonadBinder', we have +-- On top of the raw facilities provided by 'MonadBuilder', we have -- more convenient facilities. For example, 'letSubExp' lets us -- conveniently create a 'Stm' for an 'Exp' that produces a /single/ -- value, and returns the (fresh) name for the resulting variable: @@ -60,6 +60,7 @@ letTupExp', letInPlace, eSubExp, + eParam, eIf, eIf', eBinOp, @@ -74,7 +75,6 @@ eBlank, eAll, eOutOfBounds, - eWriteArray, asIntZ, asIntS, resultBody, @@ -93,7 +93,7 @@ isFullSlice, sliceAt, ifCommon, - module Futhark.Binder, + module Futhark.Builder, -- * Result types instantiateShapes, @@ -109,15 +109,15 @@ import Control.Monad.Identity import Control.Monad.State -import Control.Monad.Writer -import Data.Bifunctor (second) import Data.List (sortOn) import qualified Data.Map.Strict as M -import Futhark.Binder +import qualified Data.Set as S +import Futhark.Builder import Futhark.IR +import Futhark.Util (maybeNth) letSubExp :: - MonadBinder m => + MonadBuilder m => String -> Exp (Rep m) -> m SubExp @@ -125,7 +125,7 @@ letSubExp desc e = Var <$> letExp desc e letExp :: - MonadBinder m => + MonadBuilder m => String -> Exp (Rep m) -> m VName @@ -140,7 +140,7 @@ _ -> error $ "letExp: tuple-typed expression given:\n" ++ pretty e letInPlace :: - MonadBinder m => + MonadBuilder m => String -> VName -> Slice SubExp -> @@ -148,30 +148,33 @@ m VName letInPlace desc src slice e = do tmp <- letSubExp (desc ++ "_tmp") e - letExp desc $ BasicOp $ Update src slice tmp + letExp desc $ BasicOp $ Update Unsafe src slice tmp letSubExps :: - MonadBinder m => + MonadBuilder m => String -> [Exp (Rep m)] -> m [SubExp] letSubExps desc = mapM $ letSubExp desc +-- | Only returns those pattern names that are not used in the pattern +-- itself (the "non-existential" part, you could say). letTupExp :: - (MonadBinder m) => + (MonadBuilder m) => String -> Exp (Rep m) -> m [VName] letTupExp _ (BasicOp (SubExp (Var v))) = return [v] letTupExp name e = do - numValues <- length <$> expExtType e - names <- replicateM numValues $ newVName name + e_t <- expExtType e + names <- replicateM (length e_t) $ newVName name letBindNames names e - return names + let ctx = shapeContext e_t + pure $ map fst $ filter ((`S.notMember` ctx) . snd) $ zip names [0 ..] letTupExp' :: - (MonadBinder m) => + (MonadBuilder m) => String -> Exp (Rep m) -> m [SubExp] @@ -179,13 +182,19 @@ letTupExp' name ses = map Var <$> letTupExp name ses eSubExp :: - MonadBinder m => + MonadBuilder m => SubExp -> m (Exp (Rep m)) eSubExp = pure . BasicOp . SubExp +eParam :: + MonadBuilder m => + Param t -> + m (Exp (Rep m)) +eParam = eSubExp . Var . paramName + eIf :: - (MonadBinder m, BranchType (Rep m) ~ ExtType) => + (MonadBuilder m, BranchType (Rep m) ~ ExtType) => m (Exp (Rep m)) -> m (Body (Rep m)) -> m (Body (Rep m)) -> @@ -194,7 +203,7 @@ -- | As 'eIf', but an 'IfSort' can be given. eIf' :: - (MonadBinder m, BranchType (Rep m) ~ ExtType) => + (MonadBuilder m, BranchType (Rep m) ~ ExtType) => m (Exp (Rep m)) -> m (Body (Rep m)) -> m (Body (Rep m)) -> @@ -208,15 +217,14 @@ ts <- generaliseExtTypes <$> bodyExtType te' <*> bodyExtType fe' te'' <- addContextForBranch ts te' fe'' <- addContextForBranch ts fe' - return $ If ce' te'' fe'' $ IfDec ts if_sort + let ts' = replicate (length (shapeContext ts)) (Prim int64) ++ ts + return $ If ce' te'' fe'' $ IfDec ts' if_sort where addContextForBranch ts (Body _ stms val_res) = do - body_ts <- extendedScope (traverse subExpType val_res) stmsscope + body_ts <- extendedScope (traverse subExpResType val_res) stmsscope let ctx_res = - map snd $ - sortOn fst $ - M.toList $ shapeExtMapping ts body_ts - mkBodyM stms $ ctx_res ++ val_res + map snd $ sortOn fst $ M.toList $ shapeExtMapping ts body_ts + mkBodyM stms $ subExpsRes ctx_res ++ val_res where stmsscope = scopeOf stms @@ -225,12 +233,12 @@ bodyExtType :: (HasScope rep m, Monad m) => Body rep -> m [ExtType] bodyExtType (Body _ stms res) = existentialiseExtTypes (M.keys stmsscope) . staticShapes - <$> extendedScope (traverse subExpType res) stmsscope + <$> extendedScope (traverse subExpResType res) stmsscope where stmsscope = scopeOf stms eBinOp :: - MonadBinder m => + MonadBuilder m => BinOp -> m (Exp (Rep m)) -> m (Exp (Rep m)) -> @@ -241,7 +249,7 @@ return $ BasicOp $ BinOp op x' y' eCmpOp :: - MonadBinder m => + MonadBuilder m => CmpOp -> m (Exp (Rep m)) -> m (Exp (Rep m)) -> @@ -252,7 +260,7 @@ return $ BasicOp $ CmpOp op x' y' eConvOp :: - MonadBinder m => + MonadBuilder m => ConvOp -> m (Exp (Rep m)) -> m (Exp (Rep m)) @@ -261,7 +269,7 @@ return $ BasicOp $ ConvOp op x' eSignum :: - MonadBinder m => + MonadBuilder m => m (Exp (Rep m)) -> m (Exp (Rep m)) eSignum em = do @@ -275,25 +283,25 @@ error $ "eSignum: operand " ++ pretty e ++ " has invalid type." eCopy :: - MonadBinder m => + MonadBuilder m => m (Exp (Rep m)) -> m (Exp (Rep m)) eCopy e = BasicOp . Copy <$> (letExp "copy_arg" =<< e) eBody :: - (MonadBinder m) => + (MonadBuilder m) => [m (Exp (Rep m))] -> m (Body (Rep m)) eBody es = buildBody_ $ do es' <- sequence es xs <- mapM (letTupExp "x") es' - pure $ map Var $ concat xs + pure $ varsRes $ concat xs eLambda :: - MonadBinder m => + MonadBuilder m => Lambda (Rep m) -> [m (Exp (Rep m))] -> - m [SubExp] + m [SubExpRes] eLambda lam args = do zipWithM_ bindParam (lambdaParams lam) args bodyBind $ lambdaBody lam @@ -301,7 +309,7 @@ bindParam param arg = letBindNames [paramName param] =<< arg eRoundToMultipleOf :: - MonadBinder m => + MonadBuilder m => IntType -> m (Exp (Rep m)) -> m (Exp (Rep m)) -> @@ -315,7 +323,7 @@ -- | Construct an 'Index' expressions that slices an array with unit stride. eSliceArray :: - MonadBinder m => + MonadBuilder m => Int -> VName -> m (Exp (Rep m)) -> @@ -332,7 +340,7 @@ -- | Are these indexes out-of-bounds for the array? eOutOfBounds :: - MonadBinder m => + MonadBuilder m => VName -> [m (Exp (Rep m))] -> m (Exp (Rep m)) @@ -351,52 +359,23 @@ BasicOp $ BinOp LogOr less_than_zero greater_than_size foldBinOp LogOr (constant False) =<< zipWithM checkDim ws is' --- | Write to an index of the array, if within bounds. Otherwise, --- nothing. Produces the updated array. -eWriteArray :: - (MonadBinder m, BranchType (Rep m) ~ ExtType) => - VName -> - [m (Exp (Rep m))] -> - m (Exp (Rep m)) -> - m (Exp (Rep m)) -eWriteArray arr is v = do - arr_t <- lookupType arr - is' <- mapM (letSubExp "write_i") =<< sequence is - v' <- letSubExp "write_v" =<< v - - outside_bounds <- letSubExp "outside_bounds" =<< eOutOfBounds arr is - - outside_bounds_branch <- buildBody_ $ pure [Var arr] - - in_bounds_branch <- - buildBody_ . fmap (pure . Var) $ - letInPlace - "write_out_inside_bounds" - arr - (fullSlice arr_t (map DimFix is')) - (BasicOp $ SubExp v') - - return $ - If outside_bounds outside_bounds_branch in_bounds_branch $ - ifCommon [arr_t] - -- | Construct an unspecified value of the given type. -eBlank :: MonadBinder m => Type -> m (Exp (Rep m)) +eBlank :: MonadBuilder m => Type -> m (Exp (Rep m)) eBlank (Prim t) = return $ BasicOp $ SubExp $ Constant $ blankPrimValue t eBlank (Array t shape _) = return $ 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 :: MonadBinder m => IntType -> SubExp -> m SubExp +asIntS :: MonadBuilder m => IntType -> SubExp -> m SubExp asIntS = asInt SExt -- | Zero-extend to the given integer type. -asIntZ :: MonadBinder m => IntType -> SubExp -> m SubExp +asIntZ :: MonadBuilder m => IntType -> SubExp -> m SubExp asIntZ = asInt ZExt asInt :: - MonadBinder m => + MonadBuilder m => (IntType -> IntType -> ConvOp) -> IntType -> SubExp -> @@ -415,7 +394,7 @@ -- | Apply a binary operator to several subexpressions. A left-fold. foldBinOp :: - MonadBinder m => + MonadBuilder m => BinOp -> SubExp -> [SubExp] -> @@ -426,7 +405,7 @@ eBinOp bop (pure $ BasicOp $ SubExp e) (foldBinOp bop ne es) -- | True if all operands are true. -eAll :: MonadBinder m => [SubExp] -> m (Exp (Rep m)) +eAll :: MonadBuilder m => [SubExp] -> m (Exp (Rep m)) eAll [] = pure $ BasicOp $ SubExp $ constant True eAll (x : xs) = foldBinOp LogAnd x xs @@ -435,7 +414,7 @@ -- result types are the same. (This assumption should be fixed at -- some point.) binOpLambda :: - (MonadBinder m, Bindable (Rep m)) => + (MonadBuilder m, Buildable (Rep m)) => BinOp -> PrimType -> m (Lambda (Rep m)) @@ -443,13 +422,13 @@ -- | As 'binOpLambda', but for t'CmpOp's. cmpOpLambda :: - (MonadBinder m, Bindable (Rep m)) => + (MonadBuilder m, Buildable (Rep m)) => CmpOp -> m (Lambda (Rep m)) cmpOpLambda cop = binLambda (CmpOp cop) (cmpOpType cop) Bool binLambda :: - (MonadBinder m, Bindable (Rep m)) => + (MonadBuilder m, Buildable (Rep m)) => (SubExp -> SubExp -> BasicOp) -> PrimType -> PrimType -> @@ -458,7 +437,7 @@ x <- newVName "x" y <- newVName "y" body <- - buildBody_ . fmap pure $ + buildBody_ . fmap (pure . subExpRes) $ letSubExp "binlam_res" $ BasicOp $ bop (Var x) (Var y) return Lambda @@ -470,16 +449,16 @@ lambdaBody = body } --- | Easily construct a 'Lambda' within a 'MonadBinder'. +-- | Easily construct a 'Lambda' within a 'MonadBuilder'. mkLambda :: - MonadBinder m => + MonadBuilder m => [LParam (Rep m)] -> m Result -> m (Lambda (Rep m)) mkLambda params m = do (body, ret) <- buildBody . localScope (scopeOfLParams params) $ do res <- m - ret <- mapM subExpType res + ret <- mapM subExpResType res pure (res, ret) pure $ Lambda params body ret @@ -493,7 +472,7 @@ -- by 'Index'. fullSlice :: Type -> [DimIndex SubExp] -> Slice SubExp fullSlice t slice = - slice ++ map sliceDim (drop (length slice) $ arrayDims t) + Slice $ slice ++ map sliceDim (drop (length slice) $ arrayDims t) -- | @ sliceAt t n slice@ returns @slice@ but with 'DimSlice's of the -- outer @n@ dimensions prepended, and as many appended as to make it @@ -505,13 +484,13 @@ -- | Like 'fullSlice', but the dimensions are simply numeric. fullSliceNum :: Num d => [d] -> [DimIndex d] -> Slice d fullSliceNum dims slice = - slice ++ map (\d -> DimSlice 0 d 1) (drop (length slice) dims) + Slice $ slice ++ map (\d -> DimSlice 0 d 1) (drop (length slice) dims) -- | Does the slice describe the full size of the array? The most -- obvious such slice is one that 'DimSlice's the full span of every -- dimension, but also one that fixes all unit dimensions. isFullSlice :: Shape -> Slice SubExp -> Bool -isFullSlice shape slice = and $ zipWith allOfIt (shapeDims shape) slice +isFullSlice shape slice = and $ zipWith allOfIt (shapeDims shape) (unSlice slice) where allOfIt (Constant v) DimFix {} = oneIsh v allOfIt d (DimSlice _ n _) = d == n @@ -521,21 +500,18 @@ ifCommon ts = IfDec (staticShapes ts) IfNormal -- | Conveniently construct a body that contains no bindings. -resultBody :: Bindable rep => [SubExp] -> Body rep -resultBody = mkBody mempty +resultBody :: Buildable rep => [SubExp] -> Body rep +resultBody = mkBody mempty . subExpsRes -- | Conveniently construct a body that contains no bindings - but -- this time, monadically! -resultBodyM :: - MonadBinder m => - [SubExp] -> - m (Body (Rep m)) -resultBodyM = mkBodyM mempty +resultBodyM :: MonadBuilder m => [SubExp] -> m (Body (Rep m)) +resultBodyM = mkBodyM mempty . subExpsRes -- | Evaluate the action, producing a body, then wrap it in all the -- bindings it created using 'addStm'. insertStmsM :: - (MonadBinder m) => + (MonadBuilder m) => m (Body (Rep m)) -> m (Body (Rep m)) insertStmsM m = do @@ -546,7 +522,7 @@ -- value, then return the body constructed from the 'Result' and any -- statements added during the action, along the auxiliary value. buildBody :: - MonadBinder m => + MonadBuilder m => m (Result, a) -> m (Body (Rep m), a) buildBody m = do @@ -556,7 +532,7 @@ -- | As 'buildBody', but there is no auxiliary value. buildBody_ :: - MonadBinder m => + MonadBuilder m => m Result -> m (Body (Rep m)) buildBody_ m = fst <$> buildBody ((,()) <$> m) @@ -564,7 +540,7 @@ -- | Change that result where evaluation of the body would stop. Also -- change type annotations at branches. mapResult :: - Bindable rep => + Buildable rep => (Result -> Body rep) -> Body rep -> Body rep @@ -596,20 +572,16 @@ return se instantiate' (Free se) = return se -instantiateShapes' :: - MonadFreshNames m => - [TypeBase ExtShape u] -> - m ([TypeBase Shape u], [Ident]) -instantiateShapes' ts = +instantiateShapes' :: [VName] -> [TypeBase ExtShape u] -> [TypeBase Shape u] +instantiateShapes' names ts = -- Carefully ensure that the order of idents we produce corresponds -- to their existential index. - second (map snd . sortOn fst) - <$> runWriterT (instantiateShapes instantiate ts) + runIdentity $ instantiateShapes instantiate ts where - instantiate x = do - v <- lift $ newIdent "size" $ Prim int64 - tell [(x, v)] - return $ Var $ identName v + instantiate x = + case maybeNth x names of + Nothing -> error $ "instantiateShapes': " ++ pretty names ++ ", " ++ show x + Just name -> pure $ Var name removeExistentials :: ExtType -> Type -> Type removeExistentials t1 t2 = @@ -622,7 +594,7 @@ nonExistential (Ext _) dim = dim nonExistential (Free dim) _ = dim --- | Can be used as the definition of 'mkLetNames' for a 'Bindable' +-- | Can be used as the definition of 'mkLetNames' for a 'Buildable' -- instance for simple representations. simpleMkLetNames :: ( ExpDec rep ~ (), @@ -636,15 +608,13 @@ m (Stm rep) simpleMkLetNames names e = do et <- expExtType e - (ts, shapes) <- instantiateShapes' et - let shapeElems = [PatElem shape shapet | Ident shape shapet <- shapes] - let valElems = zipWith PatElem names ts - return $ Let (Pattern shapeElems valElems) (defAux ()) e + let ts = instantiateShapes' names et + return $ Let (Pat $ zipWith PatElem names ts) (defAux ()) e -- | Instances of this class can be converted to Futhark expressions --- within a 'MonadBinder'. +-- within a 'MonadBuilder'. class ToExp a where - toExp :: MonadBinder m => a -> m (Exp (Rep m)) + toExp :: MonadBuilder m => a -> m (Exp (Rep m)) instance ToExp SubExp where toExp = return . BasicOp . SubExp @@ -653,5 +623,5 @@ toExp = return . BasicOp . SubExp . Var -- | A convenient composition of 'letSubExp' and 'toExp'. -toSubExp :: (MonadBinder m, ToExp a) => String -> a -> m SubExp +toSubExp :: (MonadBuilder m, ToExp a) => String -> a -> m SubExp toSubExp s e = letSubExp s =<< toExp e diff --git a/src/Futhark/Doc/Generator.hs b/src/Futhark/Doc/Generator.hs --- a/src/Futhark/Doc/Generator.hs +++ b/src/Futhark/Doc/Generator.hs @@ -401,7 +401,7 @@ noLink' = noLink $ map typeParamName tparams - ++ map identName (S.toList $ mconcat $ map patternIdents params) + ++ map identName (S.toList $ mconcat $ map patIdents params) rettype' <- noLink' $ maybe (typeHtml rettype) typeExpHtml retdecl params' <- noLink' $ mapM patternHtml params return @@ -666,7 +666,7 @@ typeNameHtml :: TypeName -> DocM Html typeNameHtml = qualNameHtml . qualNameFromTypeName -patternHtml :: Pattern -> DocM Html +patternHtml :: Pat -> DocM Html patternHtml pat = do let (pat_param, t) = patternParam pat t' <- typeHtml t 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 @@ -23,10 +23,10 @@ module Futhark.IR.Syntax, -- * Adding aliases - addAliasesToPattern, + addAliasesToPat, mkAliasedLetStm, mkAliasedBody, - mkPatternAliases, + mkPatAliases, mkBodyAliases, -- * Removing aliases @@ -35,7 +35,7 @@ removeExpAliases, removeStmAliases, removeLambdaAliases, - removePatternAliases, + removePatAliases, removeScopeAliases, -- * Tracking aliases @@ -50,7 +50,7 @@ import qualified Data.Map.Strict as M import Data.Maybe import Futhark.Analysis.Rephrase -import Futhark.Binder +import Futhark.Builder import Futhark.IR.Pretty import Futhark.IR.Prop import Futhark.IR.Prop.Aliases @@ -126,8 +126,8 @@ runReaderT m scope instance (ASTRep rep, CanBeAliased (Op rep)) => ASTRep (Aliases rep) where - expTypesFromPattern = - withoutAliases . expTypesFromPattern . removePatternAliases + expTypesFromPat = + withoutAliases . expTypesFromPat . removePatAliases instance (ASTRep rep, CanBeAliased (Op rep)) => Aliased (Aliases rep) where bodyAliases = map unAliases . fst . fst . bodyDec @@ -135,25 +135,20 @@ instance (ASTRep rep, CanBeAliased (Op rep)) => PrettyRep (Aliases rep) where ppExpDec (consumed, inner) e = - maybeComment $ - catMaybes - [ exp_dec, - merge_dec, - ppExpDec inner $ removeExpAliases e - ] + maybeComment . catMaybes $ + [exp_dec, merge_dec, ppExpDec inner $ removeExpAliases e] where merge_dec = case e of - DoLoop _ merge _ body -> + DoLoop merge _ body -> let mergeParamAliases fparam als | primType (paramType fparam) = Nothing | otherwise = resultAliasComment (paramName fparam) als - in maybeComment $ - catMaybes $ - zipWith mergeParamAliases (map fst merge) $ - bodyAliases body + in maybeComment . catMaybes $ + zipWith mergeParamAliases (map fst merge) $ + bodyAliases body _ -> Nothing exp_dec = case namesToList $ unAliases consumed of @@ -228,18 +223,18 @@ Lambda rep removeLambdaAliases = runIdentity . rephraseLambda removeAliases -removePatternAliases :: - PatternT (AliasDec, a) -> - PatternT a -removePatternAliases = runIdentity . rephrasePattern (return . snd) +removePatAliases :: + PatT (AliasDec, a) -> + PatT a +removePatAliases = runIdentity . rephrasePat (return . snd) -addAliasesToPattern :: +addAliasesToPat :: (ASTRep rep, CanBeAliased (Op rep), Typed dec) => - PatternT dec -> + PatT dec -> Exp (Aliases rep) -> - PatternT (VarAliases, dec) -addAliasesToPattern pat e = - uncurry Pattern $ mkPatternAliases pat e + PatT (VarAliases, dec) +addAliasesToPat pat e = + Pat $ mkPatAliases pat e mkAliasedBody :: (ASTRep rep, CanBeAliased (Op rep)) => @@ -250,26 +245,19 @@ mkAliasedBody dec bnds res = Body (mkBodyAliases bnds res, dec) bnds res -mkPatternAliases :: +mkPatAliases :: (Aliased rep, Typed dec) => - PatternT dec -> + PatT dec -> Exp rep -> - ( [PatElemT (VarAliases, dec)], - [PatElemT (VarAliases, dec)] - ) -mkPatternAliases pat e = - -- Some part of the pattern may be the context. This does not have - -- aliases from expAliases, so we use a hack to compute aliases of - -- the context. - let als = expAliases e ++ repeat mempty -- In case the pattern has - -- more elements (this - -- implies a type error). - context_als = mkContextAliases pat e - in ( zipWith annotateBindee (patternContextElements pat) context_als, - zipWith annotateBindee (patternValueElements pat) als - ) + [PatElemT (VarAliases, dec)] +mkPatAliases pat e = + let als = expAliases e ++ repeat mempty + in -- In case the pattern has + -- more elements (this + -- implies a type error). + zipWith annotatePatElem (patElems pat) als where - annotateBindee bindee names = + annotatePatElem bindee names = bindee `setPatElemDec` (AliasDec names', patElemDec bindee) where names' = @@ -278,31 +266,6 @@ Mem _ -> names _ -> mempty -mkContextAliases :: - Aliased rep => - PatternT dec -> - Exp rep -> - [Names] -mkContextAliases pat (DoLoop ctxmerge valmerge _ body) = - let ctx = map fst ctxmerge - init_als = zip mergenames $ map (subExpAliases . snd) $ ctxmerge ++ valmerge - expand als = als <> mconcat (mapMaybe (`lookup` init_als) (namesToList als)) - merge_als = - zip mergenames $ - map ((`namesSubtract` mergenames_set) . expand) $ - bodyAliases body - in if length ctx == length (patternContextElements pat) - then map (fromMaybe mempty . flip lookup merge_als . paramName) ctx - else map (const mempty) $ patternContextElements pat - where - mergenames = map (paramName . fst) $ ctxmerge ++ valmerge - mergenames_set = namesFromList mergenames -mkContextAliases pat (If _ tbranch fbranch _) = - take (length $ patternContextNames pat) $ - zipWith (<>) (bodyAliases tbranch) (bodyAliases fbranch) -mkContextAliases pat _ = - replicate (length $ patternContextElements pat) mempty - mkBodyAliases :: Aliased rep => Stms rep -> @@ -314,8 +277,7 @@ -- closure of the alias map (within bnds), then removing anything -- bound in bnds. let (aliases, consumed) = mkStmsAliases bnds res - boundNames = - foldMap (namesFromList . patternNames . stmPattern) bnds + boundNames = foldMap (namesFromList . patNames . stmPat) bnds aliases' = map (`namesSubtract` boundNames) aliases consumed' = consumed `namesSubtract` boundNames in (map AliasDec aliases', AliasDec consumed') @@ -325,12 +287,12 @@ mkStmsAliases :: Aliased rep => Stms rep -> - [SubExp] -> + Result -> ([Names], Names) mkStmsAliases bnds res = delve mempty $ stmsToList bnds where delve (aliasmap, consumed) [] = - ( map (aliasClosure aliasmap . subExpAliases) res, + ( map (aliasClosure aliasmap . subExpAliases . resSubExp) res, consumed ) delve (aliasmap, consumed) (bnd : bnds') = @@ -351,9 +313,9 @@ Stm rep -> AliasesAndConsumed trackAliases (aliasmap, consumed) stm = - let pat = stmPattern stm + let pat = stmPat stm pe_als = - zip (patternNames pat) $ map addAliasesOfAliases $ patternAliases pat + zip (patNames pat) $ map addAliasesOfAliases $ patAliases pat als = M.fromList pe_als rev_als = foldMap revAls pe_als revAls (v, v_als) = @@ -369,23 +331,23 @@ mkAliasedLetStm :: (ASTRep rep, CanBeAliased (Op rep)) => - Pattern rep -> + Pat rep -> StmAux (ExpDec rep) -> Exp (Aliases rep) -> Stm (Aliases rep) mkAliasedLetStm pat (StmAux cs attrs dec) e = Let - (addAliasesToPattern pat e) + (addAliasesToPat pat e) (StmAux cs attrs (AliasDec $ consumedInExp e, dec)) e -instance (Bindable rep, CanBeAliased (Op rep)) => Bindable (Aliases rep) where +instance (Buildable rep, CanBeAliased (Op rep)) => Buildable (Aliases rep) where mkExpDec pat e = - let dec = mkExpDec (removePatternAliases pat) $ removeExpAliases e + let dec = mkExpDec (removePatAliases pat) $ removeExpAliases e in (AliasDec $ consumedInExp e, dec) - mkExpPat ctx val e = - addAliasesToPattern (mkExpPat ctx val $ removeExpAliases e) e + mkExpPat ids e = + addAliasesToPat (mkExpPat ids $ removeExpAliases e) e mkLetNames names e = do env <- asksScope removeScopeAliases @@ -397,4 +359,4 @@ let Body bodyrep _ _ = mkBody (fmap removeStmAliases bnds) res in mkAliasedBody bodyrep bnds res -instance (ASTRep (Aliases rep), Bindable (Aliases rep)) => BinderOps (Aliases rep) +instance (ASTRep (Aliases rep), Buildable (Aliases rep)) => BuilderOps (Aliases rep) diff --git a/src/Futhark/IR/GPU.hs b/src/Futhark/IR/GPU.hs --- a/src/Futhark/IR/GPU.hs +++ b/src/Futhark/IR/GPU.hs @@ -10,15 +10,15 @@ module Futhark.IR.Traversals, module Futhark.IR.Pretty, module Futhark.IR.Syntax, - module Futhark.IR.GPU.Kernel, + module Futhark.IR.GPU.Op, module Futhark.IR.GPU.Sizes, module Futhark.IR.SOACS.SOAC, ) where -import Futhark.Binder +import Futhark.Builder import Futhark.Construct -import Futhark.IR.GPU.Kernel +import Futhark.IR.GPU.Op import Futhark.IR.GPU.Sizes import Futhark.IR.Pretty import Futhark.IR.Prop @@ -34,7 +34,7 @@ type Op GPU = HostOp GPU (SOAC GPU) instance ASTRep GPU where - expTypesFromPattern = return . expExtTypesFromPattern + expTypesFromPat = return . expExtTypesFromPat instance TypeCheck.CheckableOp GPU where checkOp = typeCheckGPUOp Nothing @@ -44,13 +44,13 @@ instance TypeCheck.Checkable GPU -instance Bindable GPU where +instance Buildable GPU where mkBody = Body () - mkExpPat ctx val _ = basicPattern ctx val + mkExpPat idents _ = basicPat idents mkExpDec _ _ = () mkLetNames = simpleMkLetNames -instance BinderOps GPU +instance BuilderOps GPU instance PrettyRep GPU diff --git a/src/Futhark/IR/GPU/Kernel.hs b/src/Futhark/IR/GPU/Kernel.hs deleted file mode 100644 --- a/src/Futhark/IR/GPU/Kernel.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Futhark.IR.GPU.Kernel - ( -- * Size operations - SizeOp (..), - - -- * Host operations - HostOp (..), - typeCheckHostOp, - - -- * SegOp refinements - SegLevel (..), - - -- * Reexports - module Futhark.IR.GPU.Sizes, - module Futhark.IR.SegOp, - ) -where - -import Futhark.Analysis.Metrics -import qualified Futhark.Analysis.SymbolTable as ST -import Futhark.IR -import Futhark.IR.Aliases (Aliases) -import Futhark.IR.GPU.Sizes -import Futhark.IR.Prop.Aliases -import Futhark.IR.SegOp -import qualified Futhark.Optimise.Simplify.Engine as Engine -import Futhark.Optimise.Simplify.Rep -import Futhark.Transform.Rename -import Futhark.Transform.Substitute -import qualified Futhark.TypeCheck as TC -import Futhark.Util.Pretty - ( commasep, - parens, - ppr, - text, - (<+>), - ) -import qualified Futhark.Util.Pretty as PP -import Prelude hiding (id, (.)) - --- | At which level the *body* of a t'SegOp' executes. -data SegLevel - = SegThread - { segNumGroups :: Count NumGroups SubExp, - segGroupSize :: Count GroupSize SubExp, - segVirt :: SegVirt - } - | SegGroup - { segNumGroups :: Count NumGroups SubExp, - segGroupSize :: Count GroupSize SubExp, - segVirt :: SegVirt - } - deriving (Eq, Ord, Show) - -instance PP.Pretty SegLevel where - ppr lvl = - PP.parens - ( lvl' <> PP.semi - <+> text "#groups=" <> ppr (segNumGroups lvl) <> PP.semi - <+> text "groupsize=" <> ppr (segGroupSize lvl) <> virt - ) - where - lvl' = case lvl of - SegThread {} -> "thread" - SegGroup {} -> "group" - virt = case segVirt lvl of - SegNoVirt -> mempty - SegNoVirtFull -> PP.semi <+> text "full" - SegVirt -> PP.semi <+> text "virtualise" - -instance Engine.Simplifiable SegLevel where - simplify (SegThread num_groups group_size virt) = - SegThread <$> traverse Engine.simplify num_groups - <*> traverse Engine.simplify group_size - <*> pure virt - simplify (SegGroup num_groups group_size virt) = - SegGroup <$> traverse Engine.simplify num_groups - <*> traverse Engine.simplify group_size - <*> pure virt - -instance Substitute SegLevel where - substituteNames substs (SegThread num_groups group_size virt) = - SegThread - (substituteNames substs num_groups) - (substituteNames substs group_size) - virt - substituteNames substs (SegGroup num_groups group_size virt) = - SegGroup - (substituteNames substs num_groups) - (substituteNames substs group_size) - virt - -instance Rename SegLevel where - rename = substituteRename - -instance FreeIn SegLevel where - freeIn' (SegThread num_groups group_size _) = - freeIn' num_groups <> freeIn' group_size - freeIn' (SegGroup num_groups group_size _) = - freeIn' num_groups <> freeIn' group_size - --- | A simple size-level query or computation. -data SizeOp - = -- | @SplitSpace o w i elems_per_thread@. - -- - -- Computes how to divide array elements to - -- threads in a kernel. Returns the number of - -- elements in the chunk that the current thread - -- should take. - -- - -- @w@ is the length of the outer dimension in - -- the array. @i@ is the current thread - -- index. Each thread takes at most - -- @elems_per_thread@ elements. - -- - -- If the order @o@ is 'SplitContiguous', thread with index @i@ - -- should receive elements - -- @i*elems_per_tread, i*elems_per_thread + 1, - -- ..., i*elems_per_thread + (elems_per_thread-1)@. - -- - -- If the order @o@ is @'SplitStrided' stride@, - -- the thread will receive elements @i, - -- i+stride, i+2*stride, ..., - -- i+(elems_per_thread-1)*stride@. - SplitSpace SplitOrdering SubExp SubExp SubExp - | -- | Produce some runtime-configurable size. - GetSize Name SizeClass - | -- | The maximum size of some class. - GetSizeMax SizeClass - | -- | Compare size (likely a threshold) with some integer value. - CmpSizeLe Name SizeClass SubExp - | -- | @CalcNumGroups w max_num_groups group_size@ calculates the - -- number of GPU workgroups to use for an input of the given size. - -- The @Name@ is a size name. Note that @w@ is an i64 to avoid - -- overflow issues. - CalcNumGroups SubExp Name SubExp - deriving (Eq, Ord, Show) - -instance Substitute SizeOp where - substituteNames subst (SplitSpace o w i elems_per_thread) = - SplitSpace - (substituteNames subst o) - (substituteNames subst w) - (substituteNames subst i) - (substituteNames subst elems_per_thread) - substituteNames substs (CmpSizeLe name sclass x) = - CmpSizeLe name sclass (substituteNames substs x) - substituteNames substs (CalcNumGroups w max_num_groups group_size) = - CalcNumGroups - (substituteNames substs w) - max_num_groups - (substituteNames substs group_size) - substituteNames _ op = op - -instance Rename SizeOp where - rename (SplitSpace o w i elems_per_thread) = - SplitSpace - <$> rename o - <*> rename w - <*> rename i - <*> rename elems_per_thread - rename (CmpSizeLe name sclass x) = - CmpSizeLe name sclass <$> rename x - rename (CalcNumGroups w max_num_groups group_size) = - CalcNumGroups <$> rename w <*> pure max_num_groups <*> rename group_size - rename x = pure x - -instance IsOp SizeOp where - safeOp _ = True - cheapOp _ = True - -instance TypedOp SizeOp where - opType SplitSpace {} = pure [Prim int64] - opType (GetSize _ _) = pure [Prim int64] - opType (GetSizeMax _) = pure [Prim int64] - opType CmpSizeLe {} = pure [Prim Bool] - opType CalcNumGroups {} = pure [Prim int64] - -instance AliasedOp SizeOp where - opAliases _ = [mempty] - consumedInOp _ = mempty - -instance FreeIn SizeOp where - freeIn' (SplitSpace o w i elems_per_thread) = - freeIn' o <> freeIn' [w, i, elems_per_thread] - freeIn' (CmpSizeLe _ _ x) = freeIn' x - freeIn' (CalcNumGroups w _ group_size) = freeIn' w <> freeIn' group_size - freeIn' _ = mempty - -instance PP.Pretty SizeOp where - ppr (SplitSpace SplitContiguous w i elems_per_thread) = - text "split_space" - <> parens (commasep [ppr w, ppr i, ppr elems_per_thread]) - ppr (SplitSpace (SplitStrided stride) w i elems_per_thread) = - text "split_space_strided" - <> parens (commasep [ppr stride, ppr w, ppr i, ppr elems_per_thread]) - ppr (GetSize name size_class) = - text "get_size" <> parens (commasep [ppr name, ppr size_class]) - ppr (GetSizeMax size_class) = - text "get_size_max" <> parens (commasep [ppr size_class]) - ppr (CmpSizeLe name size_class x) = - text "cmp_size" <> parens (commasep [ppr name, ppr size_class]) - <+> text "<=" - <+> ppr x - ppr (CalcNumGroups w max_num_groups group_size) = - text "calc_num_groups" <> parens (commasep [ppr w, ppr max_num_groups, ppr group_size]) - -instance OpMetrics SizeOp where - opMetrics SplitSpace {} = seen "SplitSpace" - opMetrics GetSize {} = seen "GetSize" - opMetrics GetSizeMax {} = seen "GetSizeMax" - opMetrics CmpSizeLe {} = seen "CmpSizeLe" - opMetrics CalcNumGroups {} = seen "CalcNumGroups" - -typeCheckSizeOp :: TC.Checkable rep => SizeOp -> TC.TypeM rep () -typeCheckSizeOp (SplitSpace o w i elems_per_thread) = do - case o of - SplitContiguous -> return () - SplitStrided stride -> TC.require [Prim int64] stride - mapM_ (TC.require [Prim int64]) [w, i, elems_per_thread] -typeCheckSizeOp GetSize {} = return () -typeCheckSizeOp GetSizeMax {} = return () -typeCheckSizeOp (CmpSizeLe _ _ x) = TC.require [Prim int64] x -typeCheckSizeOp (CalcNumGroups w _ group_size) = do - TC.require [Prim int64] w - TC.require [Prim int64] group_size - --- | A host-level operation; parameterised by what else it can do. -data HostOp rep op - = -- | A segmented operation. - SegOp (SegOp SegLevel rep) - | SizeOp SizeOp - | OtherOp op - deriving (Eq, Ord, Show) - -instance (ASTRep rep, Substitute op) => Substitute (HostOp rep op) where - substituteNames substs (SegOp op) = - SegOp $ substituteNames substs op - substituteNames substs (OtherOp op) = - OtherOp $ substituteNames substs op - substituteNames substs (SizeOp op) = - SizeOp $ substituteNames substs op - -instance (ASTRep rep, Rename op) => Rename (HostOp rep op) where - rename (SegOp op) = SegOp <$> rename op - rename (OtherOp op) = OtherOp <$> rename op - rename (SizeOp op) = SizeOp <$> rename op - -instance (ASTRep rep, IsOp op) => IsOp (HostOp rep op) where - safeOp (SegOp op) = safeOp op - safeOp (OtherOp op) = safeOp op - safeOp (SizeOp op) = safeOp op - - cheapOp (SegOp op) = cheapOp op - cheapOp (OtherOp op) = cheapOp op - cheapOp (SizeOp op) = cheapOp op - -instance TypedOp op => TypedOp (HostOp rep op) where - opType (SegOp op) = opType op - opType (OtherOp op) = opType op - opType (SizeOp op) = opType op - -instance (Aliased rep, AliasedOp op, ASTRep rep) => AliasedOp (HostOp rep op) where - opAliases (SegOp op) = opAliases op - opAliases (OtherOp op) = opAliases op - opAliases (SizeOp op) = opAliases op - - consumedInOp (SegOp op) = consumedInOp op - consumedInOp (OtherOp op) = consumedInOp op - consumedInOp (SizeOp op) = consumedInOp op - -instance (ASTRep rep, FreeIn op) => FreeIn (HostOp rep op) where - freeIn' (SegOp op) = freeIn' op - freeIn' (OtherOp op) = freeIn' op - freeIn' (SizeOp op) = freeIn' op - -instance (CanBeAliased (Op rep), CanBeAliased op, ASTRep rep) => CanBeAliased (HostOp rep op) where - type OpWithAliases (HostOp rep op) = HostOp (Aliases rep) (OpWithAliases op) - - addOpAliases aliases (SegOp op) = SegOp $ addOpAliases aliases op - addOpAliases aliases (OtherOp op) = OtherOp $ addOpAliases aliases op - addOpAliases _ (SizeOp op) = SizeOp op - - removeOpAliases (SegOp op) = SegOp $ removeOpAliases op - removeOpAliases (OtherOp op) = OtherOp $ removeOpAliases op - removeOpAliases (SizeOp op) = SizeOp op - -instance (CanBeWise (Op rep), CanBeWise op, ASTRep rep) => CanBeWise (HostOp rep op) where - type OpWithWisdom (HostOp rep op) = HostOp (Wise rep) (OpWithWisdom op) - - removeOpWisdom (SegOp op) = SegOp $ removeOpWisdom op - removeOpWisdom (OtherOp op) = OtherOp $ removeOpWisdom op - removeOpWisdom (SizeOp op) = SizeOp op - -instance (ASTRep rep, ST.IndexOp op) => ST.IndexOp (HostOp rep op) where - indexOp vtable k (SegOp op) is = ST.indexOp vtable k op is - indexOp vtable k (OtherOp op) is = ST.indexOp vtable k op is - indexOp _ _ _ _ = Nothing - -instance (PrettyRep rep, PP.Pretty op) => PP.Pretty (HostOp rep op) where - ppr (SegOp op) = ppr op - ppr (OtherOp op) = ppr op - ppr (SizeOp op) = ppr op - -instance (OpMetrics (Op rep), OpMetrics op) => OpMetrics (HostOp rep op) where - opMetrics (SegOp op) = opMetrics op - opMetrics (OtherOp op) = opMetrics op - opMetrics (SizeOp op) = opMetrics op - -checkSegLevel :: - TC.Checkable rep => - Maybe SegLevel -> - SegLevel -> - TC.TypeM rep () -checkSegLevel Nothing lvl = do - TC.require [Prim int64] $ unCount $ segNumGroups lvl - TC.require [Prim int64] $ unCount $ segGroupSize lvl -checkSegLevel (Just SegThread {}) _ = - TC.bad $ TC.TypeError "SegOps cannot occur when already at thread level." -checkSegLevel (Just x) y - | x == y = TC.bad $ TC.TypeError $ "Already at at level " ++ pretty x - | segNumGroups x /= segNumGroups y || segGroupSize x /= segGroupSize y = - TC.bad $ TC.TypeError "Physical layout for SegLevel does not match parent SegLevel." - | otherwise = - return () - -typeCheckHostOp :: - TC.Checkable rep => - (SegLevel -> OpWithAliases (Op rep) -> TC.TypeM rep ()) -> - Maybe SegLevel -> - (op -> TC.TypeM rep ()) -> - HostOp (Aliases rep) op -> - TC.TypeM rep () -typeCheckHostOp checker lvl _ (SegOp op) = - TC.checkOpWith (checker $ segLevel op) $ - typeCheckSegOp (checkSegLevel lvl) op -typeCheckHostOp _ _ f (OtherOp op) = f op -typeCheckHostOp _ _ _ (SizeOp op) = typeCheckSizeOp op diff --git a/src/Futhark/IR/GPU/Op.hs b/src/Futhark/IR/GPU/Op.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/GPU/Op.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Futhark.IR.GPU.Op + ( -- * Size operations + SizeOp (..), + + -- * Host operations + HostOp (..), + typeCheckHostOp, + + -- * SegOp refinements + SegLevel (..), + + -- * Reexports + module Futhark.IR.GPU.Sizes, + module Futhark.IR.SegOp, + ) +where + +import Futhark.Analysis.Metrics +import qualified Futhark.Analysis.SymbolTable as ST +import Futhark.IR +import Futhark.IR.Aliases (Aliases) +import Futhark.IR.GPU.Sizes +import Futhark.IR.Prop.Aliases +import Futhark.IR.SegOp +import qualified Futhark.Optimise.Simplify.Engine as Engine +import Futhark.Optimise.Simplify.Rep +import Futhark.Transform.Rename +import Futhark.Transform.Substitute +import qualified Futhark.TypeCheck as TC +import Futhark.Util.Pretty + ( commasep, + parens, + ppr, + text, + (<+>), + ) +import qualified Futhark.Util.Pretty as PP +import Prelude hiding (id, (.)) + +-- | At which level the *body* of a t'SegOp' executes. +data SegLevel + = SegThread + { segNumGroups :: Count NumGroups SubExp, + segGroupSize :: Count GroupSize SubExp, + segVirt :: SegVirt + } + | SegGroup + { segNumGroups :: Count NumGroups SubExp, + segGroupSize :: Count GroupSize SubExp, + segVirt :: SegVirt + } + deriving (Eq, Ord, Show) + +instance PP.Pretty SegLevel where + ppr lvl = + PP.parens + ( lvl' <> PP.semi + <+> text "#groups=" <> ppr (segNumGroups lvl) <> PP.semi + <+> text "groupsize=" <> ppr (segGroupSize lvl) <> virt + ) + where + lvl' = case lvl of + SegThread {} -> "thread" + SegGroup {} -> "group" + virt = case segVirt lvl of + SegNoVirt -> mempty + SegNoVirtFull -> PP.semi <+> text "full" + SegVirt -> PP.semi <+> text "virtualise" + +instance Engine.Simplifiable SegLevel where + simplify (SegThread num_groups group_size virt) = + SegThread <$> traverse Engine.simplify num_groups + <*> traverse Engine.simplify group_size + <*> pure virt + simplify (SegGroup num_groups group_size virt) = + SegGroup <$> traverse Engine.simplify num_groups + <*> traverse Engine.simplify group_size + <*> pure virt + +instance Substitute SegLevel where + substituteNames substs (SegThread num_groups group_size virt) = + SegThread + (substituteNames substs num_groups) + (substituteNames substs group_size) + virt + substituteNames substs (SegGroup num_groups group_size virt) = + SegGroup + (substituteNames substs num_groups) + (substituteNames substs group_size) + virt + +instance Rename SegLevel where + rename = substituteRename + +instance FreeIn SegLevel where + freeIn' (SegThread num_groups group_size _) = + freeIn' num_groups <> freeIn' group_size + freeIn' (SegGroup num_groups group_size _) = + freeIn' num_groups <> freeIn' group_size + +-- | A simple size-level query or computation. +data SizeOp + = -- | @SplitSpace o w i elems_per_thread@. + -- + -- Computes how to divide array elements to + -- threads in a kernel. Returns the number of + -- elements in the chunk that the current thread + -- should take. + -- + -- @w@ is the length of the outer dimension in + -- the array. @i@ is the current thread + -- index. Each thread takes at most + -- @elems_per_thread@ elements. + -- + -- If the order @o@ is 'SplitContiguous', thread with index @i@ + -- should receive elements + -- @i*elems_per_tread, i*elems_per_thread + 1, + -- ..., i*elems_per_thread + (elems_per_thread-1)@. + -- + -- If the order @o@ is @'SplitStrided' stride@, + -- the thread will receive elements @i, + -- i+stride, i+2*stride, ..., + -- i+(elems_per_thread-1)*stride@. + SplitSpace SplitOrdering SubExp SubExp SubExp + | -- | Produce some runtime-configurable size. + GetSize Name SizeClass + | -- | The maximum size of some class. + GetSizeMax SizeClass + | -- | Compare size (likely a threshold) with some integer value. + CmpSizeLe Name SizeClass SubExp + | -- | @CalcNumGroups w max_num_groups group_size@ calculates the + -- number of GPU workgroups to use for an input of the given size. + -- The @Name@ is a size name. Note that @w@ is an i64 to avoid + -- overflow issues. + CalcNumGroups SubExp Name SubExp + deriving (Eq, Ord, Show) + +instance Substitute SizeOp where + substituteNames subst (SplitSpace o w i elems_per_thread) = + SplitSpace + (substituteNames subst o) + (substituteNames subst w) + (substituteNames subst i) + (substituteNames subst elems_per_thread) + substituteNames substs (CmpSizeLe name sclass x) = + CmpSizeLe name sclass (substituteNames substs x) + substituteNames substs (CalcNumGroups w max_num_groups group_size) = + CalcNumGroups + (substituteNames substs w) + max_num_groups + (substituteNames substs group_size) + substituteNames _ op = op + +instance Rename SizeOp where + rename (SplitSpace o w i elems_per_thread) = + SplitSpace + <$> rename o + <*> rename w + <*> rename i + <*> rename elems_per_thread + rename (CmpSizeLe name sclass x) = + CmpSizeLe name sclass <$> rename x + rename (CalcNumGroups w max_num_groups group_size) = + CalcNumGroups <$> rename w <*> pure max_num_groups <*> rename group_size + rename x = pure x + +instance IsOp SizeOp where + safeOp _ = True + cheapOp _ = True + +instance TypedOp SizeOp where + opType SplitSpace {} = pure [Prim int64] + opType (GetSize _ _) = pure [Prim int64] + opType (GetSizeMax _) = pure [Prim int64] + opType CmpSizeLe {} = pure [Prim Bool] + opType CalcNumGroups {} = pure [Prim int64] + +instance AliasedOp SizeOp where + opAliases _ = [mempty] + consumedInOp _ = mempty + +instance FreeIn SizeOp where + freeIn' (SplitSpace o w i elems_per_thread) = + freeIn' o <> freeIn' [w, i, elems_per_thread] + freeIn' (CmpSizeLe _ _ x) = freeIn' x + freeIn' (CalcNumGroups w _ group_size) = freeIn' w <> freeIn' group_size + freeIn' _ = mempty + +instance PP.Pretty SizeOp where + ppr (SplitSpace SplitContiguous w i elems_per_thread) = + text "split_space" + <> parens (commasep [ppr w, ppr i, ppr elems_per_thread]) + ppr (SplitSpace (SplitStrided stride) w i elems_per_thread) = + text "split_space_strided" + <> parens (commasep [ppr stride, ppr w, ppr i, ppr elems_per_thread]) + ppr (GetSize name size_class) = + text "get_size" <> parens (commasep [ppr name, ppr size_class]) + ppr (GetSizeMax size_class) = + text "get_size_max" <> parens (commasep [ppr size_class]) + ppr (CmpSizeLe name size_class x) = + text "cmp_size" <> parens (commasep [ppr name, ppr size_class]) + <+> text "<=" + <+> ppr x + ppr (CalcNumGroups w max_num_groups group_size) = + text "calc_num_groups" <> parens (commasep [ppr w, ppr max_num_groups, ppr group_size]) + +instance OpMetrics SizeOp where + opMetrics SplitSpace {} = seen "SplitSpace" + opMetrics GetSize {} = seen "GetSize" + opMetrics GetSizeMax {} = seen "GetSizeMax" + opMetrics CmpSizeLe {} = seen "CmpSizeLe" + opMetrics CalcNumGroups {} = seen "CalcNumGroups" + +typeCheckSizeOp :: TC.Checkable rep => SizeOp -> TC.TypeM rep () +typeCheckSizeOp (SplitSpace o w i elems_per_thread) = do + case o of + SplitContiguous -> return () + SplitStrided stride -> TC.require [Prim int64] stride + mapM_ (TC.require [Prim int64]) [w, i, elems_per_thread] +typeCheckSizeOp GetSize {} = return () +typeCheckSizeOp GetSizeMax {} = return () +typeCheckSizeOp (CmpSizeLe _ _ x) = TC.require [Prim int64] x +typeCheckSizeOp (CalcNumGroups w _ group_size) = do + TC.require [Prim int64] w + TC.require [Prim int64] group_size + +-- | A host-level operation; parameterised by what else it can do. +data HostOp rep op + = -- | A segmented operation. + SegOp (SegOp SegLevel rep) + | SizeOp SizeOp + | OtherOp op + deriving (Eq, Ord, Show) + +instance (ASTRep rep, Substitute op) => Substitute (HostOp rep op) where + substituteNames substs (SegOp op) = + SegOp $ substituteNames substs op + substituteNames substs (OtherOp op) = + OtherOp $ substituteNames substs op + substituteNames substs (SizeOp op) = + SizeOp $ substituteNames substs op + +instance (ASTRep rep, Rename op) => Rename (HostOp rep op) where + rename (SegOp op) = SegOp <$> rename op + rename (OtherOp op) = OtherOp <$> rename op + rename (SizeOp op) = SizeOp <$> rename op + +instance (ASTRep rep, IsOp op) => IsOp (HostOp rep op) where + safeOp (SegOp op) = safeOp op + safeOp (OtherOp op) = safeOp op + safeOp (SizeOp op) = safeOp op + + cheapOp (SegOp op) = cheapOp op + cheapOp (OtherOp op) = cheapOp op + cheapOp (SizeOp op) = cheapOp op + +instance TypedOp op => TypedOp (HostOp rep op) where + opType (SegOp op) = opType op + opType (OtherOp op) = opType op + opType (SizeOp op) = opType op + +instance (Aliased rep, AliasedOp op, ASTRep rep) => AliasedOp (HostOp rep op) where + opAliases (SegOp op) = opAliases op + opAliases (OtherOp op) = opAliases op + opAliases (SizeOp op) = opAliases op + + consumedInOp (SegOp op) = consumedInOp op + consumedInOp (OtherOp op) = consumedInOp op + consumedInOp (SizeOp op) = consumedInOp op + +instance (ASTRep rep, FreeIn op) => FreeIn (HostOp rep op) where + freeIn' (SegOp op) = freeIn' op + freeIn' (OtherOp op) = freeIn' op + freeIn' (SizeOp op) = freeIn' op + +instance (CanBeAliased (Op rep), CanBeAliased op, ASTRep rep) => CanBeAliased (HostOp rep op) where + type OpWithAliases (HostOp rep op) = HostOp (Aliases rep) (OpWithAliases op) + + addOpAliases aliases (SegOp op) = SegOp $ addOpAliases aliases op + addOpAliases aliases (OtherOp op) = OtherOp $ addOpAliases aliases op + addOpAliases _ (SizeOp op) = SizeOp op + + removeOpAliases (SegOp op) = SegOp $ removeOpAliases op + removeOpAliases (OtherOp op) = OtherOp $ removeOpAliases op + removeOpAliases (SizeOp op) = SizeOp op + +instance (CanBeWise (Op rep), CanBeWise op, ASTRep rep) => CanBeWise (HostOp rep op) where + type OpWithWisdom (HostOp rep op) = HostOp (Wise rep) (OpWithWisdom op) + + removeOpWisdom (SegOp op) = SegOp $ removeOpWisdom op + removeOpWisdom (OtherOp op) = OtherOp $ removeOpWisdom op + removeOpWisdom (SizeOp op) = SizeOp op + +instance (ASTRep rep, ST.IndexOp op) => ST.IndexOp (HostOp rep op) where + indexOp vtable k (SegOp op) is = ST.indexOp vtable k op is + indexOp vtable k (OtherOp op) is = ST.indexOp vtable k op is + indexOp _ _ _ _ = Nothing + +instance (PrettyRep rep, PP.Pretty op) => PP.Pretty (HostOp rep op) where + ppr (SegOp op) = ppr op + ppr (OtherOp op) = ppr op + ppr (SizeOp op) = ppr op + +instance (OpMetrics (Op rep), OpMetrics op) => OpMetrics (HostOp rep op) where + opMetrics (SegOp op) = opMetrics op + opMetrics (OtherOp op) = opMetrics op + opMetrics (SizeOp op) = opMetrics op + +checkSegLevel :: + TC.Checkable rep => + Maybe SegLevel -> + SegLevel -> + TC.TypeM rep () +checkSegLevel Nothing lvl = do + TC.require [Prim int64] $ unCount $ segNumGroups lvl + TC.require [Prim int64] $ unCount $ segGroupSize lvl +checkSegLevel (Just SegThread {}) _ = + TC.bad $ TC.TypeError "SegOps cannot occur when already at thread level." +checkSegLevel (Just x) y + | x == y = TC.bad $ TC.TypeError $ "Already at at level " ++ pretty x + | segNumGroups x /= segNumGroups y || segGroupSize x /= segGroupSize y = + TC.bad $ TC.TypeError "Physical layout for SegLevel does not match parent SegLevel." + | otherwise = + return () + +typeCheckHostOp :: + TC.Checkable rep => + (SegLevel -> OpWithAliases (Op rep) -> TC.TypeM rep ()) -> + Maybe SegLevel -> + (op -> TC.TypeM rep ()) -> + HostOp (Aliases rep) op -> + TC.TypeM rep () +typeCheckHostOp checker lvl _ (SegOp op) = + TC.checkOpWith (checker $ segLevel op) $ + typeCheckSegOp (checkSegLevel lvl) op +typeCheckHostOp _ _ f (OtherOp op) = f op +typeCheckHostOp _ _ _ (SizeOp op) = typeCheckSizeOp op diff --git a/src/Futhark/IR/GPU/Simplify.hs b/src/Futhark/IR/GPU/Simplify.hs --- a/src/Futhark/IR/GPU/Simplify.hs +++ b/src/Futhark/IR/GPU/Simplify.hs @@ -75,7 +75,7 @@ w' <- Engine.simplify w return (SizeOp $ CalcNumGroups w' max_num_groups group_size, mempty) -instance BinderOps (Wise GPU) +instance BuilderOps (Wise GPU) instance HasSegOp (Wise GPU) where type SegOpLevel (Wise GPU) = SegLevel 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 @@ -14,20 +14,20 @@ -- * Module re-exports module Futhark.IR.Mem, - module Futhark.IR.GPU.Kernel, + module Futhark.IR.GPU.Op, ) where import Futhark.Analysis.PrimExp.Convert import qualified Futhark.Analysis.UsageTable as UT -import Futhark.IR.GPU.Kernel +import Futhark.IR.GPU.Op import Futhark.IR.GPU.Simplify (simplifyKernelOp) import Futhark.IR.Mem import Futhark.IR.Mem.Simplify import Futhark.MonadFreshNames import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Pass -import Futhark.Pass.ExplicitAllocations (BinderOps (..), mkLetNamesB', mkLetNamesB'') +import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'') import qualified Futhark.TypeCheck as TC data GPUMem @@ -41,14 +41,16 @@ type Op GPUMem = MemOp (HostOp GPUMem ()) instance ASTRep GPUMem where - expTypesFromPattern = return . map snd . snd . bodyReturnsFromPattern + expTypesFromPat = return . map snd . bodyReturnsFromPat -instance OpReturns GPUMem where - opReturns (Alloc _ space) = - return [MemMem space] - opReturns (Inner (SegOp op)) = segOpReturns op +instance OpReturns (HostOp GPUMem ()) where + opReturns (SegOp op) = segOpReturns op opReturns k = extReturns <$> opType k +instance OpReturns (HostOp (Engine.Wise GPUMem) ()) where + opReturns (SegOp op) = segOpReturns op + opReturns k = extReturns <$> opType k + instance PrettyRep GPUMem instance TC.CheckableOp GPUMem where @@ -65,17 +67,17 @@ checkLetBoundDec = checkMemInfo checkRetType = mapM_ $ TC.checkExtType . declExtTypeOf primFParam name t = return $ Param name (MemPrim t) - matchPattern = matchPatternToExp + matchPat = matchPatToExp matchReturnType = matchFunctionReturnType matchBranchType = matchBranchReturnType matchLoopResult = matchLoopResultMem -instance BinderOps GPUMem where +instance BuilderOps GPUMem where mkExpDecB _ _ = return () mkBodyB stms res = return $ Body () stms res mkLetNamesB = mkLetNamesB' () -instance BinderOps (Engine.Wise GPUMem) where +instance BuilderOps (Engine.Wise GPUMem) where mkExpDecB pat e = return $ Engine.mkWiseExpDec pat () e mkBodyB stms res = return $ Engine.mkWiseBody () stms res mkLetNamesB = mkLetNamesB'' diff --git a/src/Futhark/IR/MC.hs b/src/Futhark/IR/MC.hs --- a/src/Futhark/IR/MC.hs +++ b/src/Futhark/IR/MC.hs @@ -20,7 +20,7 @@ ) where -import Futhark.Binder +import Futhark.Builder import Futhark.Construct import Futhark.IR.MC.Op import Futhark.IR.Pretty @@ -42,22 +42,22 @@ type Op MC = MCOp MC (SOAC MC) instance ASTRep MC where - expTypesFromPattern = return . expExtTypesFromPattern + expTypesFromPat = return . expExtTypesFromPat instance TypeCheck.CheckableOp MC where checkOp = typeCheckMCOp typeCheckSOAC instance TypeCheck.Checkable MC -instance Bindable MC where +instance Buildable MC where mkBody = Body () - mkExpPat ctx val _ = basicPattern ctx val + mkExpPat idents _ = basicPat idents mkExpDec _ _ = () mkLetNames = simpleMkLetNames -instance BinderOps MC +instance BuilderOps MC -instance BinderOps (Engine.Wise MC) +instance BuilderOps (Engine.Wise MC) instance PrettyRep MC 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 @@ -24,7 +24,7 @@ import Futhark.IR.SegOp import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Pass -import Futhark.Pass.ExplicitAllocations (BinderOps (..), mkLetNamesB', mkLetNamesB'') +import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'') import qualified Futhark.TypeCheck as TC data MCMem @@ -38,13 +38,16 @@ type Op MCMem = MemOp (MCOp MCMem ()) instance ASTRep MCMem where - expTypesFromPattern = return . map snd . snd . bodyReturnsFromPattern + expTypesFromPat = return . map snd . bodyReturnsFromPat -instance OpReturns MCMem where - opReturns (Alloc _ space) = return [MemMem space] - opReturns (Inner (ParOp _ op)) = segOpReturns op - opReturns (Inner (OtherOp ())) = pure [] +instance OpReturns (MCOp MCMem ()) where + opReturns (ParOp _ op) = segOpReturns op + opReturns (OtherOp ()) = pure [] +instance OpReturns (MCOp (Engine.Wise MCMem) ()) where + opReturns (ParOp _ op) = segOpReturns op + opReturns k = extReturns <$> opType k + instance PrettyRep MCMem instance TC.CheckableOp MCMem where @@ -61,17 +64,17 @@ checkLetBoundDec = checkMemInfo checkRetType = mapM_ (TC.checkExtType . declExtTypeOf) primFParam name t = return $ Param name (MemPrim t) - matchPattern = matchPatternToExp + matchPat = matchPatToExp matchReturnType = matchFunctionReturnType matchBranchType = matchBranchReturnType matchLoopResult = matchLoopResultMem -instance BinderOps MCMem where +instance BuilderOps MCMem where mkExpDecB _ _ = return () mkBodyB stms res = return $ Body () stms res mkLetNamesB = mkLetNamesB' () -instance BinderOps (Engine.Wise MCMem) where +instance BuilderOps (Engine.Wise MCMem) where mkExpDecB pat e = return $ Engine.mkWiseExpDec pat () e mkBodyB stms res = return $ Engine.mkWiseBody () stms res mkLetNamesB = mkLetNamesB'' 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 @@ -75,7 +75,7 @@ noUniquenessReturns, bodyReturnsToExpReturns, Mem, - AllocOp (..), + HasLetDecMem (..), OpReturns (..), varReturns, expReturns, @@ -87,10 +87,10 @@ -- * Type checking parts matchBranchReturnType, - matchPatternToExp, + matchPatToExp, matchFunctionReturnType, matchLoopResultMem, - bodyReturnsFromPattern, + bodyReturnsFromPat, checkMemInfo, -- * Module re-exports @@ -106,11 +106,11 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State -import Data.Foldable (toList, traverse_) +import Data.Foldable (traverse_) +import Data.Function ((&)) import Data.List (elemIndex, find) import qualified Data.Map.Strict as M import Data.Maybe -import qualified Data.Set as S import Futhark.Analysis.Metrics import Futhark.Analysis.PrimExp.Convert import Futhark.Analysis.PrimExp.Simplify @@ -118,7 +118,7 @@ import Futhark.IR.Aliases ( Aliases, removeExpAliases, - removePatternAliases, + removePatAliases, removeScopeAliases, ) import qualified Futhark.IR.Mem.IxFun as IxFun @@ -147,19 +147,26 @@ type BranchTypeMem = BodyReturns --- | The class of ops that have memory allocation. -class AllocOp op where - allocOp :: SubExp -> Space -> op +-- | The class of pattern element decorators that contain memory +-- information. +class HasLetDecMem t where + letDecMem :: t -> LetDecMem -type Mem rep = - ( AllocOp (Op rep), - FParamInfo rep ~ FParamMem, +instance HasLetDecMem LetDecMem where + letDecMem = id + +instance HasLetDecMem b => HasLetDecMem (a, b) where + letDecMem = letDecMem . snd + +type Mem rep inner = + ( FParamInfo rep ~ FParamMem, LParamInfo rep ~ LParamMem, - LetDec rep ~ LetDecMem, + HasLetDecMem (LetDec rep), RetType rep ~ RetTypeMem, BranchType rep ~ BranchTypeMem, ASTRep rep, - OpReturns rep + OpReturns inner, + Op rep ~ MemOp inner ) instance IsRetType FunReturns where @@ -170,15 +177,11 @@ primBodyType = MemPrim data MemOp inner - = -- | Allocate a memory block. This really should not be an - -- expression, but what are you gonna do... + = -- | Allocate a memory block. Alloc SubExp Space | Inner inner deriving (Eq, Ord, Show) -instance AllocOp (MemOp inner) where - allocOp = Alloc - instance FreeIn inner => FreeIn (MemOp inner) where freeIn' (Alloc size _) = freeIn' size freeIn' (Inner k) = freeIn' k @@ -531,24 +534,32 @@ bodyReturnsToExpReturns :: BodyReturns -> ExpReturns bodyReturnsToExpReturns = noUniquenessReturns . maybeReturns +varInfoToExpReturns :: MemInfo SubExp NoUniqueness MemBind -> ExpReturns +varInfoToExpReturns (MemArray et shape u (ArrayIn mem ixfun)) = + MemArray et (fmap Free shape) u $ + Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun +varInfoToExpReturns (MemPrim pt) = MemPrim pt +varInfoToExpReturns (MemAcc acc ispace ts u) = MemAcc acc ispace ts u +varInfoToExpReturns (MemMem space) = MemMem space + matchRetTypeToResult :: - (Mem rep, TC.Checkable rep) => + (Mem rep inner, TC.Checkable rep) => [FunReturns] -> Result -> TC.TypeM rep () matchRetTypeToResult rettype result = do scope <- askScope - result_ts <- runReaderT (mapM subExpMemInfo result) $ removeScopeAliases scope - matchReturnType rettype result result_ts + result_ts <- runReaderT (mapM (subExpMemInfo . resSubExp) result) $ removeScopeAliases scope + matchReturnType rettype (map resSubExp result) result_ts matchFunctionReturnType :: - (Mem rep, TC.Checkable rep) => + (Mem rep inner, TC.Checkable rep) => [FunReturns] -> Result -> TC.TypeM rep () matchFunctionReturnType rettype result = do matchRetTypeToResult rettype result - mapM_ checkResultSubExp result + mapM_ (checkResultSubExp . resSubExp) result where checkResultSubExp Constant {} = return () @@ -569,21 +580,20 @@ ++ pretty ixfun matchLoopResultMem :: - (Mem rep, TC.Checkable rep) => - [FParam (Aliases rep)] -> + (Mem rep inner, TC.Checkable rep) => [FParam (Aliases rep)] -> - [SubExp] -> + Result -> TC.TypeM rep () -matchLoopResultMem ctx val = matchRetTypeToResult rettype +matchLoopResultMem params = matchRetTypeToResult rettype where - ctx_names = map paramName ctx + param_names = map paramName params -- Invent a ReturnType so we can pretend that the loop body is -- actually returning from a function. - rettype = map (toRet . paramDec) val + rettype = map (toRet . paramDec) params toExtV v - | Just i <- v `elemIndex` ctx_names = Ext i + | Just i <- v `elemIndex` param_names = Ext i | otherwise = Free v toExtSE (Var v) = Var <$> toExtV v @@ -596,24 +606,24 @@ toRet (MemAcc acc ispace ts u) = MemAcc acc ispace ts u toRet (MemArray pt shape u (ArrayIn mem ixfun)) - | Just i <- mem `elemIndex` ctx_names, - Param _ (MemMem space) : _ <- drop i ctx = + | Just i <- mem `elemIndex` param_names, + Param _ (MemMem space) : _ <- drop i params = MemArray pt shape' u $ ReturnsNewBlock space i ixfun' | otherwise = MemArray pt shape' u $ ReturnsInBlock mem ixfun' where shape' = fmap toExtSE shape - ixfun' = existentialiseIxFun ctx_names ixfun + ixfun' = existentialiseIxFun param_names ixfun matchBranchReturnType :: - (Mem rep, TC.Checkable rep) => + (Mem rep inner, TC.Checkable rep) => [BodyReturns] -> Body (Aliases rep) -> TC.TypeM rep () matchBranchReturnType rettype (Body _ stms res) = do scope <- askScope - ts <- runReaderT (mapM subExpMemInfo res) $ removeScopeAliases (scope <> scopeOf stms) - matchReturnType rettype res ts + ts <- runReaderT (mapM (subExpMemInfo . resSubExp) res) $ removeScopeAliases (scope <> scopeOf stms) + matchReturnType rettype (map resSubExp res) ts -- | Helper function for index function unification. -- @@ -650,19 +660,14 @@ [MemInfo SubExp NoUniqueness MemBind] -> TC.TypeM rep () matchReturnType rettype res ts = do - let (ctx_ts, val_ts) = splitFromEnd (length rettype) ts - (ctx_res, _val_res) = splitFromEnd (length rettype) res + let (ctx_res, _val_res) = splitFromEnd (length rettype) res existentialiseIxFun0 :: IxFun -> ExtIxFun existentialiseIxFun0 = fmap $ fmap Free - fetchCtx i = case maybeNth i $ zip ctx_res ctx_ts of + fetchCtx i = case maybeNth i $ zip res ts of Nothing -> - throwError $ - "Cannot find context variable " - ++ show i - ++ " in context results: " - ++ pretty ctx_res + throwError $ "Cannot find variable #" ++ show i ++ " in results: " ++ pretty res Just (se, t) -> return (se, t) checkReturn (MemPrim x) (MemPrim y) @@ -685,88 +690,56 @@ checkDim (Free x) y | x == y = return () | otherwise = - throwError $ - unwords - [ "Expected dim", - pretty x, - "but got", - pretty y - ] + throwError $ unwords ["Expected dim", pretty x, "but got", pretty y] checkDim (Ext i) y = do (x, _) <- fetchCtx i - unless (x == y) $ - throwError $ - unwords - [ "Expected ext dim", - pretty i, - "=>", - pretty x, - "but got", - pretty y - ] - - extsInMemInfo :: MemInfo ExtSize u MemReturn -> S.Set Int - extsInMemInfo (MemArray _ shp _ ret) = - extInShape shp <> extInMemReturn ret - extsInMemInfo _ = S.empty + unless (x == y) . throwError . unwords $ + ["Expected ext dim", pretty i, "=>", pretty x, "but got", pretty y] checkMemReturn (ReturnsInBlock x_mem x_ixfun) (ArrayIn y_mem y_ixfun) | x_mem == y_mem = unless (IxFun.closeEnough x_ixfun $ existentialiseIxFun0 y_ixfun) $ - throwError $ - unwords - [ "Index function unification failed (ReturnsInBlock)", - "\nixfun of body result: ", - pretty y_ixfun, - "\nixfun of return type: ", - pretty x_ixfun, - "\nand context elements: ", - pretty ctx_res - ] + throwError . unwords $ + [ "Index function unification failed (ReturnsInBlock)", + "\nixfun of body result: ", + pretty y_ixfun, + "\nixfun of return type: ", + pretty x_ixfun, + "\nand context elements: ", + pretty ctx_res + ] checkMemReturn (ReturnsNewBlock x_space x_ext x_ixfun) (ArrayIn y_mem y_ixfun) = do (x_mem, x_mem_type) <- fetchCtx x_ext unless (IxFun.closeEnough x_ixfun $ existentialiseIxFun0 y_ixfun) $ - throwError $ - pretty $ - "Index function unification failed (ReturnsNewBlock)" - "Ixfun of body result:" - indent 2 (ppr y_ixfun) - "Ixfun of return type:" - indent 2 (ppr x_ixfun) - "Context elements: " - indent 2 (ppr ctx_res) + throwError . pretty $ + "Index function unification failed (ReturnsNewBlock)" + "Ixfun of body result:" + indent 2 (ppr y_ixfun) + "Ixfun of return type:" + indent 2 (ppr x_ixfun) + "Context elements: " + indent 2 (ppr ctx_res) case x_mem_type of MemMem y_space -> - unless (x_space == y_space) $ - throwError $ - unwords - [ "Expected memory", - pretty y_mem, - "in space", - pretty x_space, - "but actually in space", - pretty y_space - ] + unless (x_space == y_space) . throwError . unwords $ + [ "Expected memory", + pretty y_mem, + "in space", + pretty x_space, + "but actually in space", + pretty y_space + ] t -> - throwError $ - unwords - [ "Expected memory", - pretty x_ext, - "=>", - pretty x_mem, - "but but has type", - pretty t - ] + throwError . unwords $ + ["Expected memory", pretty x_ext, "=>", pretty x_mem, "but but has type", pretty t] checkMemReturn x y = - throwError $ - unwords - [ "Expected array in", - pretty x, - "but array returned in", - pretty y - ] + throwError . pretty $ + "Expected array in" + indent 2 (ppr x) + "but array returned in" + indent 2 (ppr y) bad :: String -> TC.TypeM rep a bad s = @@ -779,46 +752,29 @@ indent 2 (ppTuple' ts) text s - unless (length (S.unions $ map extsInMemInfo rettype) == length ctx_res) $ - TC.bad $ - TC.TypeError $ - "Too many context parameters for the number of " - ++ "existentials in the return type! type:\n " - ++ prettyTuple rettype - ++ "\ncannot match context parameters:\n " - ++ prettyTuple ctx_res - - either bad return =<< runExceptT (zipWithM_ checkReturn rettype val_ts) + either bad return =<< runExceptT (zipWithM_ checkReturn rettype ts) -matchPatternToExp :: - (Mem rep, TC.Checkable rep) => - Pattern (Aliases rep) -> +matchPatToExp :: + (Mem rep inner, LetDec rep ~ LetDecMem, TC.Checkable rep) => + Pat (Aliases rep) -> Exp (Aliases rep) -> TC.TypeM rep () -matchPatternToExp pat e = do +matchPatToExp pat e = do scope <- asksScope removeScopeAliases rt <- runReaderT (expReturns $ removeExpAliases e) scope - let (ctxs, vals) = bodyReturnsFromPattern $ removePatternAliases pat - (ctx_ids, _ctx_ts) = unzip ctxs - (_val_ids, val_ts) = unzip vals - (ctx_map_ids, ctx_map_exts) = - getExtMaps $ zip ctx_ids [0 .. length ctx_ids - 1] - - let rt_exts = foldMap extInExpReturns rt + let (ctx_ids, val_ts) = unzip $ bodyReturnsFromPat $ removePatAliases pat + (ctx_map_ids, ctx_map_exts) = getExtMaps $ zip ctx_ids [0 .. 1] unless ( length val_ts == length rt && and (zipWith (matches ctx_map_ids ctx_map_exts) val_ts rt) - && M.keysSet ctx_map_exts `S.isSubsetOf` S.map Ext rt_exts ) $ TC.bad $ TC.TypeError $ "Expression type:\n " ++ prettyTuple rt ++ "\ncannot match pattern type:\n " ++ prettyTuple val_ts - ++ "\nwith context elements: " - ++ pretty ctx_ids where matches _ _ (MemPrim x) (MemPrim y) = x == y matches _ _ (MemMem x_space) (MemMem y_space) = @@ -848,58 +804,42 @@ _ -> False matches _ _ _ _ = False - extInExpReturns :: ExpReturns -> S.Set Int - extInExpReturns (MemArray _ shape _ mem_return) = - extInShape shape <> maybe S.empty extInMemReturn mem_return - extInExpReturns _ = mempty - -extInShape :: ShapeBase (Ext SubExp) -> S.Set Int -extInShape shape = S.fromList $ mapMaybe isExt $ shapeDims shape - -extInMemReturn :: MemReturn -> S.Set Int -extInMemReturn (ReturnsInBlock _ extixfn) = extInIxFn extixfn -extInMemReturn (ReturnsNewBlock _ i extixfn) = - S.singleton i <> extInIxFn extixfn - -extInIxFn :: ExtIxFun -> S.Set Int -extInIxFn ixfun = S.fromList $ concatMap (mapMaybe isExt . toList) ixfun - varMemInfo :: - Mem rep => + Mem rep inner => VName -> TC.TypeM rep (MemInfo SubExp NoUniqueness MemBind) varMemInfo name = do dec <- TC.lookupVar name case dec of - LetName (_, summary) -> return summary - FParamName summary -> return $ noUniquenessReturns summary - LParamName summary -> return summary - IndexName it -> return $ MemPrim $ IntType it + LetName (_, summary) -> pure $ letDecMem summary + FParamName summary -> pure $ noUniquenessReturns summary + LParamName summary -> pure summary + IndexName it -> pure $ MemPrim $ IntType it -nameInfoToMemInfo :: Mem rep => NameInfo rep -> MemBound NoUniqueness +nameInfoToMemInfo :: Mem rep inner => NameInfo rep -> MemBound NoUniqueness nameInfoToMemInfo info = case info of FParamName summary -> noUniquenessReturns summary LParamName summary -> summary - LetName summary -> summary + LetName summary -> letDecMem summary IndexName it -> MemPrim $ IntType it lookupMemInfo :: - (HasScope rep m, Mem rep) => + (HasScope rep m, Mem rep inner) => VName -> m (MemInfo SubExp NoUniqueness MemBind) lookupMemInfo = fmap nameInfoToMemInfo . lookupInfo subExpMemInfo :: - (HasScope rep m, Monad m, Mem rep) => + (HasScope rep m, Monad m, Mem rep inner) => SubExp -> m (MemInfo SubExp NoUniqueness MemBind) subExpMemInfo (Var v) = lookupMemInfo v subExpMemInfo (Constant v) = return $ MemPrim $ primValueType v lookupArraySummary :: - (Mem rep, HasScope rep m, Monad m) => + (Mem rep inner, HasScope rep m, Monad m) => VName -> m (VName, IxFun.IxFun (TPrimExp Int64 VName)) lookupArraySummary name = do @@ -908,7 +848,9 @@ MemArray _ _ _ (ArrayIn mem ixfun) -> return (mem, ixfun) _ -> - error $ "Variable " ++ pretty name ++ " does not look like an array." + error $ + "Expected " ++ pretty name ++ " to be array but bound to:\n" + ++ pretty summary checkMemInfo :: TC.Checkable rep => @@ -947,15 +889,12 @@ ++ show ident_rank ++ ")" -bodyReturnsFromPattern :: - PatternT (MemBound NoUniqueness) -> - ([(VName, BodyReturns)], [(VName, BodyReturns)]) -bodyReturnsFromPattern pat = - ( map asReturns $ patternContextElements pat, - map asReturns $ patternValueElements pat - ) +bodyReturnsFromPat :: + PatT (MemBound NoUniqueness) -> [(VName, BodyReturns)] +bodyReturnsFromPat pat = + map asReturns $ patElems pat where - ctx = patternContextElements pat + ctx = patElems pat ext (Var v) | Just (i, _) <- find ((== v) . patElemName . snd) $ zip [0 ..] ctx = @@ -1001,7 +940,7 @@ convert (Free v) = Free <$> pe64 v arrayVarReturns :: - (HasScope rep m, Monad m, Mem rep) => + (HasScope rep m, Monad m, Mem rep inner) => VName -> m (PrimType, Shape, VName, IxFun) arrayVarReturns v = do @@ -1013,7 +952,7 @@ error $ "arrayVarReturns: " ++ pretty v ++ " is not an array." varReturns :: - (HasScope rep m, Monad m, Mem rep) => + (HasScope rep m, Monad m, Mem rep inner) => VName -> m ExpReturns varReturns v = do @@ -1030,7 +969,7 @@ MemAcc acc ispace ts u -> return $ MemAcc acc ispace ts u -subExpReturns :: (HasScope rep m, Monad m, Mem rep) => SubExp -> m ExpReturns +subExpReturns :: (HasScope rep m, Monad m, Mem rep inner) => SubExp -> m ExpReturns subExpReturns (Var v) = varReturns v subExpReturns (Constant v) = @@ -1041,13 +980,13 @@ expReturns :: ( Monad m, LocalScope rep m, - Mem rep + Mem rep inner ) => Exp rep -> m [ExpReturns] expReturns (BasicOp (SubExp se)) = pure <$> subExpReturns se -expReturns (BasicOp (Opaque (Var v))) = +expReturns (BasicOp (Opaque _ (Var v))) = pure <$> varReturns v expReturns (BasicOp (Reshape newshape v)) = do (et, _, mem, ixfun) <- arrayVarReturns v @@ -1075,23 +1014,18 @@ Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun' ] expReturns (BasicOp (Index v slice)) = do - info <- sliceInfo v slice - case info of - MemArray et shape u (ArrayIn mem ixfun) -> - return - [ MemArray et (fmap Free shape) u $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun - ] - MemPrim pt -> return [MemPrim pt] - MemAcc acc ispace ts u -> return [MemAcc acc ispace ts u] - MemMem space -> return [MemMem space] -expReturns (BasicOp (Update v _ _)) = + pure . varInfoToExpReturns <$> sliceInfo v slice +expReturns (BasicOp (Update _ v _ _)) = pure <$> varReturns v +expReturns (BasicOp (FlatIndex v slice)) = do + pure . varInfoToExpReturns <$> flatSliceInfo v slice +expReturns (BasicOp (FlatUpdate v _ _)) = + pure <$> varReturns v expReturns (BasicOp op) = - extReturns . staticShapes <$> primOpType op -expReturns e@(DoLoop ctx val _ _) = do + extReturns . staticShapes <$> basicOpType op +expReturns e@(DoLoop merge _ _) = do t <- expExtType e - zipWithM typeWithDec t $ map fst val + zipWithM typeWithDec t $ map fst merge where typeWithDec t p = case (t, paramDec p) of @@ -1102,10 +1036,7 @@ Mem space <- paramType mem_p -> return $ MemArray pt shape u $ Just $ ReturnsNewBlock space i ixfun' | otherwise -> - return - ( MemArray pt shape u $ - Just $ ReturnsInBlock mem ixfun' - ) + return $ MemArray pt shape u $ Just $ ReturnsInBlock mem ixfun' where ixfun' = existentialiseIxFun (map paramName mergevars) ixfun (Array {}, _) -> @@ -1114,10 +1045,10 @@ return $ MemAcc acc ispace ts u (Prim pt, _) -> return $ MemPrim pt - (Mem {}, _) -> - error "expReturns: loop returns memory block explicitly." + (Mem space, _) -> + pure $ MemMem space isMergeVar v = find ((== v) . paramName . snd) $ zip [0 ..] mergevars - mergevars = map fst $ ctx ++ val + mergevars = map fst merge expReturns (Apply _ _ ret _) = return $ map funReturnsToExpReturns ret expReturns (If _ _ _ (IfDec ret _)) = @@ -1136,7 +1067,7 @@ num_accs = length inputs sliceInfo :: - (Monad m, HasScope rep m, Mem rep) => + (Monad m, HasScope rep m, Mem rep inner) => VName -> Slice SubExp -> m (MemInfo SubExp NoUniqueness MemBind) @@ -1146,18 +1077,33 @@ [] -> return $ MemPrim et dims -> return $ - MemArray et (Shape dims) NoUniqueness $ - ArrayIn mem $ - IxFun.slice - ixfun - (map (fmap (isInt64 . primExpFromSubExp int64)) slice) + MemArray et (Shape dims) NoUniqueness . ArrayIn mem $ + IxFun.slice ixfun (fmap pe64 slice) -class TypedOp (Op rep) => OpReturns rep where - opReturns :: - (Monad m, HasScope rep m) => - Op rep -> - m [ExpReturns] +flatSliceInfo :: + (Monad m, HasScope rep m, Mem rep inner) => + VName -> + FlatSlice SubExp -> + 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 + & ArrayIn mem + & MemArray et (Shape (flatSliceDims slice)) NoUniqueness + & pure + +class TypedOp op => OpReturns op where + opReturns :: (Mem rep inner, Monad m, HasScope rep m) => op -> m [ExpReturns] opReturns op = extReturns <$> opType op + +instance OpReturns inner => OpReturns (MemOp inner) where + opReturns (Alloc _ space) = pure [MemMem space] + opReturns (Inner op) = opReturns op + +instance OpReturns () where + opReturns () = pure [] applyFunReturns :: Typed dec => 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 @@ -15,6 +15,7 @@ rotate, reshape, slice, + flatSlice, rebase, shape, rank, @@ -33,7 +34,7 @@ import Control.Monad.Identity import Control.Monad.State import Control.Monad.Writer -import Data.Function (on) +import Data.Function (on, (&)) import Data.List (sort, sortBy, zip4, zip5, zipWith5) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE @@ -51,9 +52,13 @@ import Futhark.IR.Syntax ( DimChange (..), DimIndex (..), + FlatDimIndex (..), + FlatSlice (..), ShapeChange, - Slice, + Slice (..), dimFix, + flatSliceDims, + flatSliceStrides, unitSlice, ) import Futhark.IR.Syntax.Core (Ext (..)) @@ -369,11 +374,11 @@ IxFun num -> Slice num -> Maybe (IxFun num) -sliceOneLMAD (IxFun (lmad@(LMAD _ ldims) :| lmads) oshp cg) is = do +sliceOneLMAD (IxFun (lmad@(LMAD _ ldims) :| lmads) oshp cg) (Slice is) = do let perm = lmadPermutation lmad is' = permuteInv perm is - cg' = cg && slicePreservesContiguous lmad is' - guard $ harmlessRotation lmad is' + cg' = cg && slicePreservesContiguous lmad (Slice is') + guard $ harmlessRotation lmad (Slice is') let lmad' = foldl sliceOne (LMAD (lmadOffset lmad) []) $ zip is' ldims -- need to remove the fixed dims from the permutation perm' = @@ -414,7 +419,7 @@ LMAD num -> Slice num -> Bool - harmlessRotation (LMAD _ dims) iss = + harmlessRotation (LMAD _ dims) (Slice iss) = and $ zipWith harmlessRotation' dims iss -- XXX: TODO: what happens to r on a negative-stride slice; is there @@ -450,7 +455,7 @@ LMAD num -> Slice num -> Bool - slicePreservesContiguous (LMAD _ dims) slc = + slicePreservesContiguous (LMAD _ dims) (Slice slc) = -- remove from the slice the LMAD dimensions that have stride 0. -- If the LMAD was contiguous in mem, then these dims will not -- influence the contiguousness of the result. @@ -497,10 +502,9 @@ IxFun num -> Slice num -> IxFun num -slice _ [] = error "slice: empty slice" slice ixfun@(IxFun (lmad@(LMAD _ _) :| lmads) oshp cg) dim_slices -- Avoid identity slicing. - | dim_slices == map (unitSlice 0) (shape ixfun) = ixfun + | unSlice dim_slices == map (unitSlice 0) (shape ixfun) = ixfun | Just ixfun' <- sliceOneLMAD ixfun dim_slices = ixfun' | otherwise = case sliceOneLMAD (iota (lmadShape lmad)) dim_slices of @@ -508,6 +512,36 @@ IxFun (lmad' :| lmad : lmads) oshp (cg && cg') _ -> error "slice: reached impossible case" +-- | Flat-slice an index function. +flatSlice :: + (Eq num, IntegralExp num) => + IxFun num -> + FlatSlice num -> + IxFun num +flatSlice ixfun@(IxFun (LMAD offset (dim : dims) :| lmads) oshp cg) (FlatSlice new_offset is) + | hasContiguousPerm ixfun, + ldRotate dim == 0 = + let lmad = + LMAD + (offset + new_offset * ldStride dim) + ( map (helper $ ldStride dim) is + <> dims + ) + & setLMADPermutation [0 ..] + in IxFun (lmad :| lmads) oshp cg + where + helper s0 (FlatDimIndex n s) = LMADDim (s0 * s) 0 n 0 Unknown +flatSlice (IxFun (lmad :| lmads) oshp cg) s@(FlatSlice new_offset _) = + IxFun (LMAD (new_offset * base_stride) (new_dims <> tail_dims) :| lmad : lmads) oshp cg + where + tail_shapes = tail $ lmadShape lmad + base_stride = product tail_shapes + tail_strides = tail $ scanr (*) 1 tail_shapes + tail_dims = zipWith5 LMADDim tail_strides (repeat 0) tail_shapes [length new_shapes ..] (repeat Inc) + new_shapes = flatSliceDims s + new_strides = map (* base_stride) $ flatSliceStrides s + new_dims = zipWith5 LMADDim new_strides (repeat 0) new_shapes [0 ..] (repeat Inc) + -- | Handle the simple case where all reshape dimensions are coercions. reshapeCoercion :: (Eq num, IntegralExp num) => @@ -853,11 +887,13 @@ | r == 0 = i * s | otherwise = ((i + r) `mod` n) * s --- | Generalised iota with user-specified offset and strides. +-- | Generalised iota with user-specified offset and rotates. makeRotIota :: IntegralExp num => Monotonicity -> + -- | Offset num -> + -- | Pairs of shape and rotation [(num, num)] -> LMAD num makeRotIota mon off support 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 @@ -19,7 +19,6 @@ import Futhark.Construct import Futhark.IR.Mem import qualified Futhark.IR.Mem.IxFun as IxFun -import qualified Futhark.IR.Syntax as AST import qualified Futhark.Optimise.Simplify as Simplify import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Optimise.Simplify.Rep @@ -30,14 +29,14 @@ import Futhark.Util simpleGeneric :: - (SimplifyMemory rep, Op rep ~ MemOp inner) => + (SimplifyMemory rep inner) => (OpWithWisdom inner -> UT.UsageTable) -> Simplify.SimplifyOp rep inner -> Simplify.SimpleOps rep simpleGeneric = simplifiable simplifyProgGeneric :: - (SimplifyMemory rep, Op rep ~ MemOp inner) => + (SimplifyMemory rep inner) => Simplify.SimpleOps rep -> Prog rep -> PassM (Prog rep) @@ -56,13 +55,12 @@ -- corruption. At this point in the compiler we have probably -- already moved all the array creations that matter. blockAllocs _ _ (Let pat _ _) = - not $ all primType $ patternTypes pat + not $ all primType $ patTypes pat simplifyStmsGeneric :: ( HasScope rep m, MonadFreshNames m, - SimplifyMemory rep, - Op rep ~ MemOp inner + SimplifyMemory rep inner ) => Simplify.SimpleOps rep -> Stms rep -> @@ -77,8 +75,8 @@ stms isResultAlloc :: Op rep ~ MemOp op => Engine.BlockPred rep -isResultAlloc _ usage (Let (AST.Pattern [] [bindee]) _ (Op Alloc {})) = - UT.isInResult (patElemName bindee) usage +isResultAlloc _ usage (Let (Pat [pe]) _ (Op Alloc {})) = + UT.isInResult (patElemName pe) usage isResultAlloc _ _ _ = False isAlloc :: Op rep ~ MemOp op => Engine.BlockPred rep @@ -96,17 +94,17 @@ } -- | Some constraints that must hold for the simplification rules to work. -type SimplifyMemory rep = +type SimplifyMemory rep inner = ( Simplify.SimplifiableRep rep, + LetDec rep ~ LetDecMem, ExpDec rep ~ (), BodyDec rep ~ (), - AllocOp (Op (Wise rep)), CanBeWise (Op rep), - BinderOps (Wise rep), - Mem rep + BuilderOps (Wise rep), + Mem rep inner ) -callKernelRules :: SimplifyMemory rep => RuleBook (Wise rep) +callKernelRules :: SimplifyMemory rep inner => RuleBook (Wise rep) callKernelRules = standardRules <> ruleBook @@ -121,10 +119,10 @@ -- 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 => TopDownRuleIf (Wise rep) +unExistentialiseMemory :: SimplifyMemory rep inner => TopDownRuleIf (Wise rep) unExistentialiseMemory vtable pat _ (cond, tbranch, fbranch, ifdec) | ST.simplifyMemory vtable, - fixable <- foldl hasConcretisableMemory mempty $ patternElements pat, + fixable <- foldl hasConcretisableMemory mempty $ patElems pat, not $ null fixable = Simplify $ do -- Create non-existential memory blocks big enough to hold the -- arrays. @@ -132,28 +130,24 @@ fmap unzip $ forM fixable $ \(arr_pe, mem_size, oldmem, space) -> do size <- toSubExp "size" mem_size - mem <- letExp "mem" $ Op $ allocOp size space + mem <- letExp "mem" $ Op $ Alloc size space return ((patElemName arr_pe, mem), (oldmem, mem)) -- Update the branches to contain Copy expressions putting the -- arrays where they are expected. let updateBody body = buildBody_ $ do res <- bodyBind body - zipWithM updateResult (patternElements pat) res - updateResult pat_elem (Var v) + zipWithM updateResult (patElems pat) res + updateResult pat_elem (SubExpRes cs (Var v)) | Just mem <- lookup (patElemName pat_elem) arr_to_mem, (_, MemArray pt shape u (ArrayIn _ ixfun)) <- patElemDec pat_elem = do v_copy <- newVName $ baseString v <> "_nonext_copy" let v_pat = - Pattern - [] - [ PatElem v_copy $ - MemArray pt shape u $ ArrayIn mem ixfun - ] + Pat [PatElem v_copy $ MemArray pt shape u $ ArrayIn mem ixfun] addStm $ mkWiseLetStm v_pat (defAux ()) $ BasicOp (Copy v) - return $ Var v_copy + return $ SubExpRes cs $ Var v_copy | Just mem <- lookup (patElemName pat_elem) oldmem_to_mem = - return $ Var mem + return $ SubExpRes cs $ Var mem updateResult _ se = return se tbranch' <- updateBody tbranch @@ -161,13 +155,11 @@ letBind pat $ If cond tbranch' fbranch' ifdec where onlyUsedIn name here = - not $ - any ((name `nameIn`) . freeIn) $ - filter ((/= here) . patElemName) $ - patternValueElements pat + not . any ((name `nameIn`) . freeIn) . filter ((/= here) . patElemName) $ + patElems pat knownSize Constant {} = True knownSize (Var v) = not $ inContext v - inContext = (`elem` patternContextNames pat) + inContext = (`elem` patNames pat) hasConcretisableMemory fixable pat_elem | (_, MemArray pt shape _ (ArrayIn mem ixfun)) <- patElemDec pat_elem, @@ -175,12 +167,12 @@ fmap patElemType <$> find ((mem ==) . patElemName . snd) - (zip [(0 :: Int) ..] $ patternElements pat), + (zip [(0 :: Int) ..] $ patElems pat), Just tse <- maybeNth j $ bodyResult tbranch, Just fse <- maybeNth j $ bodyResult fbranch, mem `onlyUsedIn` patElemName pat_elem, all knownSize (shapeDims shape), - not $ freeIn ixfun `namesIntersect` namesFromList (patternNames pat), + not $ freeIn ixfun `namesIntersect` namesFromList (patNames pat), fse /= tse = let mem_size = untyped $ product $ primByteSize pt : map sExt64 (IxFun.base ixfun) @@ -192,11 +184,11 @@ -- | If we are copying something that is itself a copy, just copy the -- original one instead. copyCopyToCopy :: - ( BinderOps rep, + ( BuilderOps rep, LetDec rep ~ (VarWisdom, MemBound u) ) => TopDownRuleBasicOp rep -copyCopyToCopy vtable pat@(Pattern [] [pat_elem]) _ (Copy v1) +copyCopyToCopy vtable pat@(Pat [pat_elem]) _ (Copy v1) | Just (BasicOp (Copy v2), v1_cs) <- ST.lookupExp v1 vtable, Just (_, MemArray _ _ _ (ArrayIn srcmem src_ixfun)) <- ST.entryLetBoundDec =<< ST.lookup v1 vtable, @@ -218,11 +210,11 @@ -- | If the destination of a copy is the same as the source, just -- remove it. removeIdentityCopy :: - ( BinderOps rep, + ( BuilderOps rep, LetDec rep ~ (VarWisdom, MemBound u) ) => TopDownRuleBasicOp rep -removeIdentityCopy vtable pat@(Pattern [] [pe]) _ (Copy v) +removeIdentityCopy vtable pat@(Pat [pe]) _ (Copy v) | (_, MemArray _ _ _ (ArrayIn dest_mem dest_ixfun)) <- patElemDec pe, Just (_, MemArray _ _ _ (ArrayIn src_mem src_ixfun)) <- ST.entryLetBoundDec =<< ST.lookup v vtable, @@ -234,10 +226,10 @@ -- 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 => TopDownRuleOp (Wise rep) +decertifySafeAlloc :: SimplifyMemory rep inner => TopDownRuleOp (Wise rep) decertifySafeAlloc _ pat (StmAux cs attrs _) op | cs /= mempty, - [Mem _] <- patternTypes pat, + [Mem _] <- patTypes pat, safeOp op = Simplify $ attributing attrs $ letBind pat $ Op op decertifySafeAlloc _ _ _ _ = Skip 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 @@ -24,7 +24,7 @@ import Futhark.Analysis.PrimExp.Parse import Futhark.IR import Futhark.IR.GPU (GPU) -import qualified Futhark.IR.GPU.Kernel as Kernel +import qualified Futhark.IR.GPU.Op as GPU import Futhark.IR.GPUMem (GPUMem) import Futhark.IR.MC (MC) import qualified Futhark.IR.MC.Op as MC @@ -157,14 +157,6 @@ pVNames :: Parser [VName] pVNames = braces (pVName `sepBy` pComma) -pPatternLike :: Parser a -> Parser ([a], [a]) -pPatternLike p = braces $ do - xs <- p `sepBy` pComma - choice - [ pSemi *> ((xs,) <$> (p `sepBy` pComma)), - pure (mempty, xs) - ] - pConvOp :: T.Text -> (t1 -> t2 -> ConvOp) -> Parser t1 -> Parser t2 -> Parser BasicOp pConvOp s op t1 t2 = @@ -202,20 +194,27 @@ ] pSlice :: Parser (Slice SubExp) -pSlice = brackets $ pDimIndex `sepBy` pComma +pSlice = Slice <$> brackets (pDimIndex `sepBy` pComma) pIndex :: Parser BasicOp pIndex = try $ Index <$> pVName <*> pSlice +pFlatDimIndex :: Parser (FlatDimIndex SubExp) +pFlatDimIndex = + FlatDimIndex <$> pSubExp <* lexeme ":" <*> pSubExp + +pFlatSlice :: Parser (FlatSlice SubExp) +pFlatSlice = + brackets $ FlatSlice <$> pSubExp <* pSemi <*> (pFlatDimIndex `sepBy` pComma) + +pFlatIndex :: Parser BasicOp +pFlatIndex = try $ FlatIndex <$> pVName <*> pFlatSlice + pErrorMsgPart :: Parser (ErrorMsgPart SubExp) pErrorMsgPart = choice [ ErrorString <$> pStringLiteral, - flip ($) <$> (pSubExp <* pColon) - <*> choice - [ keyword "i32" $> ErrorInt32, - keyword "i64" $> ErrorInt64 - ] + flip ErrorVal <$> (pSubExp <* pColon) <*> pPrimType ] pErrorMsg :: Parser (ErrorMsg SubExp) @@ -253,7 +252,9 @@ pBasicOp :: Parser BasicOp pBasicOp = choice - [ keyword "opaque" $> Opaque <*> parens pSubExp, + [ keyword "opaque" $> Opaque OpaqueNil <*> parens pSubExp, + keyword "trace" $> uncurry (Opaque . OpaqueTrace) + <*> parens ((,) <$> lexeme pStringLiteral <* pComma <*> pSubExp), keyword "copy" $> Copy <*> parens pVName, keyword "assert" *> parens @@ -283,10 +284,16 @@ Concat d <$> pVName <*> many (pComma *> pVName) <*> pure w, pIota, try $ - Update + flip Update <$> pVName <* keyword "with" + <*> choice [lexeme "?" $> Safe, pure Unsafe] <*> pSlice <* lexeme "=" <*> pSubExp, + try $ + FlatUpdate + <$> pVName <* keyword "with" + <*> pFlatSlice <* lexeme "=" + <*> pVName, ArrayLit <$> brackets (pSubExp `sepBy` pComma) <*> (lexeme ":" *> "[]" *> pType), @@ -305,6 +312,7 @@ pConvOp "btoi" (const BToI) (keyword "bool") pIntType, -- pIndex, + pFlatIndex, pBinOp, pCmpOp, pUnOp, @@ -371,9 +379,12 @@ pPatElem pr = (PatElem <$> pVName <*> (pColon *> pLetDec pr)) "pattern element" -pPattern :: PR rep -> Parser (Pattern rep) -pPattern pr = uncurry Pattern <$> pPatternLike (pPatElem pr) +pPat :: PR rep -> Parser (Pat rep) +pPat pr = Pat <$> braces (pPatElem pr `sepBy` pComma) +pResult :: Parser Result +pResult = braces $ pSubExpRes `sepBy` pComma + pIf :: PR rep -> Parser (Exp rep) pIf pr = keyword "if" $> f <*> pSort <*> pSubExp @@ -391,7 +402,7 @@ If cond tbranch fbranch $ IfDec t sort pBranchBody = choice - [ try $ braces $ Body (pBodyDec pr) mempty <$> pSubExp `sepBy` pComma, + [ try $ Body (pBodyDec pr) mempty <$> pResult, braces (pBody pr) ] @@ -414,17 +425,16 @@ pLoop :: PR rep -> Parser (Exp rep) pLoop pr = - keyword "loop" $> uncurry DoLoop + keyword "loop" $> DoLoop <*> pLoopParams <*> pLoopForm <* keyword "do" <*> braces (pBody pr) where pLoopParams = do - (ctx, val) <- pPatternLike (pFParam pr) + params <- braces $ pFParam pr `sepBy` pComma void $ lexeme "=" - (ctx_init, val_init) <- - splitAt (length ctx) <$> braces (pSubExp `sepBy` pComma) - pure (zip ctx ctx_init, zip val val_init) + args <- braces (pSubExp `sepBy` pComma) + pure (zip params args) pLoopForm = choice @@ -487,17 +497,22 @@ BasicOp <$> pBasicOp ] +pCerts :: Parser Certs +pCerts = + choice + [ lexeme "#" *> braces (Certs <$> pVName `sepBy` pComma) + "certificates", + pure mempty + ] + +pSubExpRes :: Parser SubExpRes +pSubExpRes = SubExpRes <$> pCerts <*> pSubExp + pStm :: PR rep -> Parser (Stm rep) pStm pr = - keyword "let" $> Let <*> pPattern pr <* pEqual <*> pStmAux <*> pExp pr + keyword "let" $> Let <*> pPat pr <* pEqual <*> pStmAux <*> pExp pr where pStmAux = flip StmAux <$> pAttrs <*> pCerts <*> pure (pExpDec pr) - pCerts = - choice - [ lexeme "#" *> braces (Certificates <$> pVName `sepBy` pComma) - "certificates", - pure mempty - ] pStms :: PR rep -> Parser (Stms rep) pStms pr = stmsFromList <$> many (pStm pr) @@ -508,8 +523,6 @@ [ Body (pBodyDec pr) <$> pStms pr <* keyword "in" <*> pResult, Body (pBodyDec pr) mempty <$> pResult ] - where - pResult = braces $ pSubExp `sepBy` pComma pEntry :: Parser EntryPoint pEntry = @@ -633,23 +646,23 @@ <*> braces (pSubExp `sepBy` pComma) <* pComma <*> pLambda pr -pSizeClass :: Parser Kernel.SizeClass +pSizeClass :: Parser GPU.SizeClass pSizeClass = choice - [ keyword "group_size" $> Kernel.SizeGroup, - keyword "num_groups" $> Kernel.SizeNumGroups, - keyword "num_groups" $> Kernel.SizeNumGroups, - keyword "tile_size" $> Kernel.SizeTile, - keyword "reg_tile_size" $> Kernel.SizeRegTile, - keyword "local_memory" $> Kernel.SizeLocalMemory, + [ keyword "group_size" $> GPU.SizeGroup, + keyword "num_groups" $> GPU.SizeNumGroups, + keyword "num_groups" $> GPU.SizeNumGroups, + keyword "tile_size" $> GPU.SizeTile, + keyword "reg_tile_size" $> GPU.SizeRegTile, + keyword "local_memory" $> GPU.SizeLocalMemory, keyword "threshold" *> parens - ( flip Kernel.SizeThreshold + ( flip GPU.SizeThreshold <$> choice [Just <$> pInt64, "def" $> Nothing] <* pComma <*> pKernelPath ), keyword "bespoke" - *> parens (Kernel.SizeBespoke <$> pName <* pComma <*> pInt64) + *> parens (GPU.SizeBespoke <$> pName <* pComma <*> pInt64) ] where pKernelPath = many pStep @@ -659,33 +672,33 @@ (,) <$> pName <*> pure True ] -pSizeOp :: Parser Kernel.SizeOp +pSizeOp :: Parser GPU.SizeOp pSizeOp = choice [ keyword "get_size" - *> parens (Kernel.GetSize <$> pName <* pComma <*> pSizeClass), + *> parens (GPU.GetSize <$> pName <* pComma <*> pSizeClass), keyword "get_size_max" - *> parens (Kernel.GetSizeMax <$> pSizeClass), + *> parens (GPU.GetSizeMax <$> pSizeClass), keyword "cmp_size" - *> ( parens (Kernel.CmpSizeLe <$> pName <* pComma <*> pSizeClass) + *> ( parens (GPU.CmpSizeLe <$> pName <* pComma <*> pSizeClass) <*> (lexeme "<=" *> pSubExp) ), keyword "calc_num_groups" *> parens - ( Kernel.CalcNumGroups + ( GPU.CalcNumGroups <$> pSubExp <* pComma <*> pName <* pComma <*> pSubExp ), keyword "split_space" *> parens - ( Kernel.SplitSpace Kernel.SplitContiguous + ( GPU.SplitSpace GPU.SplitContiguous <$> pSubExp <* pComma <*> pSubExp <* pComma <*> pSubExp ), keyword "split_space_strided" *> parens - ( Kernel.SplitSpace - <$> (Kernel.SplitStrided <$> pSubExp) <* pComma + ( GPU.SplitSpace + <$> (GPU.SplitStrided <$> pSubExp) <* pComma <*> pSubExp <* pComma <*> pSubExp <* pComma <*> pSubExp @@ -701,7 +714,8 @@ pDim = (,) <$> pVName <* lexeme "<" <*> pSubExp pKernelResult :: Parser SegOp.KernelResult -pKernelResult = +pKernelResult = do + cs <- pCerts choice [ keyword "returns" $> SegOp.Returns <*> choice @@ -709,26 +723,27 @@ keyword "(private)" $> SegOp.ResultPrivate, pure SegOp.ResultMaySimplify ] + <*> pure cs <*> pSubExp, try $ - flip SegOp.WriteReturns + flip (SegOp.WriteReturns cs) <$> pVName <* pColon <*> pShape <* keyword "with" <*> parens (pWrite `sepBy` pComma), try "tile" - *> parens (SegOp.TileReturns <$> (pTile `sepBy` pComma)) <*> pVName, + *> parens (SegOp.TileReturns cs <$> (pTile `sepBy` pComma)) <*> pVName, try "blkreg_tile" - *> parens (SegOp.RegTileReturns <$> (pRegTile `sepBy` pComma)) <*> pVName, + *> parens (SegOp.RegTileReturns cs <$> (pRegTile `sepBy` pComma)) <*> pVName, keyword "concat" *> parens - ( SegOp.ConcatReturns SegOp.SplitContiguous + ( SegOp.ConcatReturns cs SegOp.SplitContiguous <$> pSubExp <* pComma <*> pSubExp ) <*> pVName, keyword "concat_strided" *> parens - ( SegOp.ConcatReturns + ( SegOp.ConcatReturns cs <$> (SegOp.SplitStrided <$> pSubExp) <* pComma <*> pSubExp <* pComma <*> pSubExp @@ -790,15 +805,15 @@ pSegScan = pSegOp' SegOp.SegScan pSegBinOp pSegHist = pSegOp' SegOp.SegHist pHistOp -pSegLevel :: Parser Kernel.SegLevel +pSegLevel :: Parser GPU.SegLevel pSegLevel = parens $ choice - [ keyword "thread" $> Kernel.SegThread, - keyword "group" $> Kernel.SegGroup + [ keyword "thread" $> GPU.SegThread, + keyword "group" $> GPU.SegGroup ] - <*> (pSemi *> lexeme "#groups=" $> Kernel.Count <*> pSubExp) - <*> (pSemi *> lexeme "groupsize=" $> Kernel.Count <*> pSubExp) + <*> (pSemi *> lexeme "#groups=" $> GPU.Count <*> pSubExp) + <*> (pSemi *> lexeme "groupsize=" $> GPU.Count <*> pSubExp) <*> choice [ pSemi *> choice @@ -808,12 +823,12 @@ pure SegOp.SegNoVirt ] -pHostOp :: PR rep -> Parser op -> Parser (Kernel.HostOp rep op) +pHostOp :: PR rep -> Parser op -> Parser (GPU.HostOp rep op) pHostOp pr pOther = choice - [ Kernel.SegOp <$> pSegOp pr pSegLevel, - Kernel.SizeOp <$> pSizeOp, - Kernel.OtherOp <$> pOther + [ GPU.SegOp <$> pSegOp pr pSegLevel, + GPU.SizeOp <$> pSizeOp, + GPU.OtherOp <$> pOther ] pMCOp :: PR rep -> Parser op -> Parser (MC.MCOp rep op) 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 @@ -92,13 +92,16 @@ ppr (Var v) = ppr v ppr (Constant v) = ppr v -instance Pretty Certificates where - ppr (Certificates []) = empty - ppr (Certificates cs) = text "#" <> braces (commasep (map ppr cs)) +instance Pretty Certs where + ppr (Certs []) = empty + ppr (Certs cs) = text "#" <> braces (commasep (map ppr cs)) instance PrettyRep rep => Pretty (Stms rep) where ppr = stack . map ppr . stmsToList +instance Pretty SubExpRes where + ppr (SubExpRes cs se) = spread $ certAnnots cs ++ [ppr se] + instance PrettyRep rep => Pretty (Body rep) where ppr (Body _ stms res) | null stms = braces (commasep $ map ppr res) @@ -118,7 +121,7 @@ stmAttrAnnots :: Stm rep -> [Doc] stmAttrAnnots = attrAnnots . stmAuxAttrs . stmAux -certAnnots :: Certificates -> [Doc] +certAnnots :: Certs -> [Doc] certAnnots cs | cs == mempty = [] | otherwise = [ppr cs] @@ -126,9 +129,12 @@ stmCertAnnots :: Stm rep -> [Doc] stmCertAnnots = certAnnots . stmAuxCerts . stmAux -instance Pretty (PatElemT dec) => Pretty (PatternT dec) where - ppr pat = ppPattern (patternContextElements pat) (patternValueElements pat) +instance Pretty Attrs where + ppr = spread . attrAnnots +instance Pretty (PatElemT dec) => Pretty (PatT dec) where + ppr (Pat xs) = braces $ commastack $ map ppr xs + instance Pretty t => Pretty (PatElemT t) where ppr (PatElem name t) = ppr name <+> colon <+> align (ppr t) @@ -159,9 +165,19 @@ stmCertAnnots bnd ] +instance Pretty a => Pretty (Slice a) where + ppr (Slice xs) = brackets (commasep (map ppr xs)) + +instance Pretty d => Pretty (FlatDimIndex d) where + ppr (FlatDimIndex n s) = ppr n <+> text ":" <+> ppr s + +instance Pretty a => Pretty (FlatSlice a) where + ppr (FlatSlice offset xs) = brackets (ppr offset <> text ";" <+> commasep (map ppr xs)) + instance Pretty BasicOp where ppr (SubExp se) = ppr se - ppr (Opaque e) = text "opaque" <> apply [ppr e] + ppr (Opaque OpaqueNil e) = text "opaque" <> apply [ppr e] + ppr (Opaque (OpaqueTrace s) e) = text "trace" <> apply [ppr (show s), ppr e] ppr (ArrayLit es rt) = case rt of Array {} -> brackets $ commastack $ map ppr es @@ -175,12 +191,16 @@ where (fromtype, totype) = convOpType conv ppr (UnOp op e) = ppr op <+> pprPrec 9 e - ppr (Index v idxs) = - ppr v <> brackets (commasep (map ppr idxs)) - ppr (Update src idxs se) = - ppr src <+> text "with" <+> brackets (commasep (map ppr idxs)) - <+> text "=" - <+> ppr se + ppr (Index v slice) = ppr v <> ppr slice + ppr (Update safety src slice se) = + ppr src <+> with <+> ppr slice <+> text "=" <+> ppr se + where + with = case safety of + Unsafe -> text "with" + Safe -> text "with?" + ppr (FlatIndex v slice) = ppr v <> ppr slice + ppr (FlatUpdate src slice se) = + ppr src <+> text "with" <+> ppr slice <+> text "=" <+> ppr se ppr (Iota e x s et) = text "iota" <> et' <> apply [ppr e, ppr x, ppr s] where et' = text $ show $ primBitSize $ IntType et @@ -207,8 +227,7 @@ ppr (ErrorMsg parts) = braces $ align $ commasep $ map p parts where p (ErrorString s) = text $ show s - p (ErrorInt32 x) = ppr x <+> colon <+> text "i32" - p (ErrorInt64 x) = ppr x <+> colon <+> text "i64" + p (ErrorVal t x) = ppr x <+> colon <+> ppr t instance PrettyRep rep => Pretty (Exp rep) where ppr (If c t f (IfDec ret ifsort)) = @@ -217,8 +236,8 @@ <+> maybeNest t <+> text "else" <+> maybeNest f - <+> colon - <+> braces (commasep $ map ppr ret) + colon + <+> ppTuple' ret where info' = case ifsort of IfNormal -> mempty @@ -241,10 +260,10 @@ Unsafe -> text "apply " Safe -> text "apply" ppr (Op op) = ppr op - ppr (DoLoop ctx val form loopbody) = - text "loop" <+> ppPattern ctxparams valparams + ppr (DoLoop merge form loopbody) = + text "loop" <+> braces (commastack $ map ppr params) <+> equals - <+> ppTuple' (ctxinit ++ valinit) + <+> ppTuple' args ( case form of ForLoop i it bound [] -> text "for" @@ -267,8 +286,7 @@ <+> text "do" <+> nestedBlock "{" "}" (ppr loopbody) where - (ctxparams, ctxinit) = unzip ctx - (valparams, valinit) = unzip val + (params, args) = unzip merge pprLoopVar (p, a) = ppr p <+> text "in" <+> ppr a ppr (WithAcc inputs lam) = text "with_acc" @@ -327,10 +345,6 @@ ppr (DimFix i) = ppr i ppr (DimSlice i n s) = ppr i <+> text ":+" <+> ppr n <+> text "*" <+> ppr s -ppPattern :: (Pretty a, Pretty b) => [a] -> [b] -> Doc -ppPattern [] bs = braces $ commastack $ map ppr bs -ppPattern as bs = braces $ commastack (map ppr as) <> semi commasep (map ppr bs) - -- | Like 'prettyTuple', but produces a 'Doc'. ppTuple' :: Pretty a => [a] -> Doc -ppTuple' ets = braces $ commasep $ map ppr ets +ppTuple' ets = braces $ commasep $ map (align . ppr) ets diff --git a/src/Futhark/IR/Primitive.hs b/src/Futhark/IR/Primitive.hs --- a/src/Futhark/IR/Primitive.hs +++ b/src/Futhark/IR/Primitive.hs @@ -17,6 +17,7 @@ PrimType (..), allPrimTypes, module Data.Int, + Half, -- * Values IntValue (..), @@ -116,9 +117,11 @@ import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.Map as M import Data.Word +import Foreign.C.Types (CUShort (..)) import Futhark.Util ( ceilDouble, ceilFloat, + convFloat, floorDouble, floorFloat, hypot, @@ -131,6 +134,7 @@ tgammaf, ) import Futhark.Util.Pretty +import Numeric.Half import Prelude hiding (id, (.)) -- | An integer type, ordered by size. Note that signedness is not a @@ -155,11 +159,13 @@ -- | A floating point type. data FloatType - = Float32 + = Float16 + | Float32 | Float64 deriving (Eq, Ord, Show, Enum, Bounded) instance Pretty FloatType where + ppr Float16 = text "f16" ppr Float32 = text "f32" ppr Float64 = text "f64" @@ -181,19 +187,21 @@ toEnum 1 = IntType Int16 toEnum 2 = IntType Int32 toEnum 3 = IntType Int64 - toEnum 4 = FloatType Float32 - toEnum 5 = FloatType Float64 - toEnum 6 = Bool + toEnum 4 = FloatType Float16 + toEnum 5 = FloatType Float32 + toEnum 6 = FloatType Float64 + toEnum 7 = Bool toEnum _ = Unit fromEnum (IntType Int8) = 0 fromEnum (IntType Int16) = 1 fromEnum (IntType Int32) = 2 fromEnum (IntType Int64) = 3 - fromEnum (FloatType Float32) = 4 - fromEnum (FloatType Float64) = 5 - fromEnum Bool = 6 - fromEnum Unit = 7 + fromEnum (FloatType Float16) = 4 + fromEnum (FloatType Float32) = 5 + fromEnum (FloatType Float64) = 6 + fromEnum Bool = 7 + fromEnum Unit = 8 instance Bounded PrimType where minBound = IntType Int8 @@ -249,32 +257,48 @@ -- | A floating-point value. data FloatValue - = Float32Value !Float + = Float16Value !Half + | Float32Value !Float | Float64Value !Double deriving (Show) instance Eq FloatValue where + Float16Value x == Float16Value y = isNaN x && isNaN y || x == y Float32Value x == Float32Value y = isNaN x && isNaN y || x == y Float64Value x == Float64Value y = isNaN x && isNaN y || x == y - Float32Value _ == Float64Value _ = False - Float64Value _ == Float32Value _ = False + _ == _ = False -- The derived Ord instance does not handle NaNs correctly. instance Ord FloatValue where + Float16Value x <= Float16Value y = x <= y Float32Value x <= Float32Value y = x <= y Float64Value x <= Float64Value y = x <= y + Float16Value _ <= Float32Value _ = True + Float16Value _ <= Float64Value _ = True + Float32Value _ <= Float16Value _ = False Float32Value _ <= Float64Value _ = True + Float64Value _ <= Float16Value _ = False Float64Value _ <= Float32Value _ = False + Float16Value x < Float16Value y = x < y Float32Value x < Float32Value y = x < y Float64Value x < Float64Value y = x < y + Float16Value _ < Float32Value _ = True + Float16Value _ < Float64Value _ = True + Float32Value _ < Float16Value _ = False Float32Value _ < Float64Value _ = True + Float64Value _ < Float16Value _ = False Float64Value _ < Float32Value _ = False (>) = flip (<) (>=) = flip (<=) instance Pretty FloatValue where + ppr (Float16Value v) + | isInfinite v, v >= 0 = text "f16.inf" + | isInfinite v, v < 0 = text "-f16.inf" + | isNaN v = text "f16.nan" + | otherwise = text $ show v ++ "f16" ppr (Float32Value v) | isInfinite v, v >= 0 = text "f32.inf" | isInfinite v, v < 0 = text "-f32.inf" @@ -288,11 +312,13 @@ -- | Create a t'FloatValue' from a type and a 'Rational'. floatValue :: Real num => FloatType -> num -> FloatValue +floatValue Float16 = Float16Value . fromRational . toRational floatValue Float32 = Float32Value . fromRational . toRational floatValue Float64 = Float64Value . fromRational . toRational -- | The type of a floating-point value. floatValueType :: FloatValue -> FloatType +floatValueType Float16Value {} = Float16 floatValueType Float32Value {} = Float32 floatValueType Float64Value {} = Float64 @@ -327,6 +353,7 @@ blankPrimValue (IntType Int16) = IntValue $ Int16Value 0 blankPrimValue (IntType Int32) = IntValue $ Int32Value 0 blankPrimValue (IntType Int64) = IntValue $ Int64Value 0 +blankPrimValue (FloatType Float16) = FloatValue $ Float16Value 0.0 blankPrimValue (FloatType Float32) = FloatValue $ Float32Value 0.0 blankPrimValue (FloatType Float64) = FloatValue $ Float64Value 0.0 blankPrimValue Bool = BoolValue False @@ -628,6 +655,7 @@ -- | @abs(-2.0) = 2.0@. doFAbs :: FloatValue -> FloatValue +doFAbs (Float16Value x) = Float16Value $ abs x doFAbs (Float32Value x) = Float32Value $ abs x doFAbs (Float64Value x) = Float64Value $ abs x @@ -641,6 +669,7 @@ -- | @fsignum(-2.0)@ = -1.0. doFSignum :: FloatValue -> FloatValue +doFSignum (Float16Value v) = Float16Value $ signum v doFSignum (Float32Value v) = Float32Value $ signum v doFSignum (Float64Value v) = Float64Value $ signum v @@ -649,27 +678,27 @@ -- zero). doBinOp :: BinOp -> PrimValue -> PrimValue -> Maybe PrimValue doBinOp Add {} = doIntBinOp doAdd -doBinOp FAdd {} = doFloatBinOp (+) (+) +doBinOp FAdd {} = doFloatBinOp (+) (+) (+) doBinOp Sub {} = doIntBinOp doSub -doBinOp FSub {} = doFloatBinOp (-) (-) +doBinOp FSub {} = doFloatBinOp (-) (-) (-) doBinOp Mul {} = doIntBinOp doMul -doBinOp FMul {} = doFloatBinOp (*) (*) +doBinOp FMul {} = doFloatBinOp (*) (*) (*) doBinOp UDiv {} = doRiskyIntBinOp doUDiv doBinOp UDivUp {} = doRiskyIntBinOp doUDivUp doBinOp SDiv {} = doRiskyIntBinOp doSDiv doBinOp SDivUp {} = doRiskyIntBinOp doSDivUp -doBinOp FDiv {} = doFloatBinOp (/) (/) -doBinOp FMod {} = doFloatBinOp mod' mod' +doBinOp FDiv {} = doFloatBinOp (/) (/) (/) +doBinOp FMod {} = doFloatBinOp mod' mod' mod' doBinOp UMod {} = doRiskyIntBinOp doUMod doBinOp SMod {} = doRiskyIntBinOp doSMod doBinOp SQuot {} = doRiskyIntBinOp doSQuot doBinOp SRem {} = doRiskyIntBinOp doSRem doBinOp SMin {} = doIntBinOp doSMin doBinOp UMin {} = doIntBinOp doUMin -doBinOp FMin {} = doFloatBinOp min min +doBinOp FMin {} = doFloatBinOp min min min doBinOp SMax {} = doIntBinOp doSMax doBinOp UMax {} = doIntBinOp doUMax -doBinOp FMax {} = doFloatBinOp max max +doBinOp FMax {} = doFloatBinOp max max max doBinOp Shl {} = doIntBinOp doShl doBinOp LShr {} = doIntBinOp doLShr doBinOp AShr {} = doIntBinOp doAShr @@ -677,7 +706,7 @@ doBinOp Or {} = doIntBinOp doOr doBinOp Xor {} = doIntBinOp doXor doBinOp Pow {} = doRiskyIntBinOp doPow -doBinOp FPow {} = doFloatBinOp (**) (**) +doBinOp FPow {} = doFloatBinOp (**) (**) (**) doBinOp LogAnd {} = doBoolBinOp (&&) doBinOp LogOr {} = doBoolBinOp (||) @@ -700,16 +729,19 @@ doRiskyIntBinOp _ _ _ = Nothing doFloatBinOp :: + (Half -> Half -> Half) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> PrimValue -> PrimValue -> Maybe PrimValue -doFloatBinOp f32 _ (FloatValue (Float32Value v1)) (FloatValue (Float32Value v2)) = +doFloatBinOp f16 _ _ (FloatValue (Float16Value v1)) (FloatValue (Float16Value v2)) = + Just $ FloatValue $ Float16Value $ f16 v1 v2 +doFloatBinOp _ f32 _ (FloatValue (Float32Value v1)) (FloatValue (Float32Value v2)) = Just $ FloatValue $ Float32Value $ f32 v1 v2 -doFloatBinOp _ f64 (FloatValue (Float64Value v1)) (FloatValue (Float64Value v2)) = +doFloatBinOp _ _ f64 (FloatValue (Float64Value v1)) (FloatValue (Float64Value v2)) = Just $ FloatValue $ Float64Value $ f64 v1 v2 -doFloatBinOp _ _ _ _ = Nothing +doFloatBinOp _ _ _ _ _ = Nothing doBoolBinOp :: (Bool -> Bool -> Bool) -> @@ -890,6 +922,7 @@ -- | Convert the former floating-point type to the latter. doFPConv :: FloatValue -> FloatType -> FloatValue +doFPConv v Float16 = Float16Value $ floatToHalf v doFPConv v Float32 = Float32Value $ floatToFloat v doFPConv v Float64 = Float64Value $ floatToDouble v @@ -974,6 +1007,11 @@ intToInt = fromIntegral . intToInt64 floatToDouble :: FloatValue -> Double +floatToDouble (Float16Value v) + | isInfinite v, v > 0 = 1 / 0 + | isInfinite v, v < 0 = -1 / 0 + | isNaN v = 0 / 0 + | otherwise = fromRational $ toRational v floatToDouble (Float32Value v) | isInfinite v, v > 0 = 1 / 0 | isInfinite v, v < 0 = -1 / 0 @@ -982,13 +1020,31 @@ floatToDouble (Float64Value v) = v floatToFloat :: FloatValue -> Float -floatToFloat (Float64Value v) +floatToFloat (Float16Value v) | isInfinite v, v > 0 = 1 / 0 | isInfinite v, v < 0 = -1 / 0 | isNaN v = 0 / 0 | otherwise = fromRational $ toRational v floatToFloat (Float32Value v) = v +floatToFloat (Float64Value v) + | isInfinite v, v > 0 = 1 / 0 + | isInfinite v, v < 0 = -1 / 0 + | isNaN v = 0 / 0 + | otherwise = fromRational $ toRational v +floatToHalf :: FloatValue -> Half +floatToHalf (Float16Value v) = v +floatToHalf (Float32Value v) + | isInfinite v, v > 0 = 1 / 0 + | isInfinite v, v < 0 = -1 / 0 + | isNaN v = 0 / 0 + | otherwise = fromRational $ toRational v +floatToHalf (Float64Value v) + | isInfinite v, v > 0 = 1 / 0 + | isInfinite v, v < 0 = -1 / 0 + | isNaN v = 0 / 0 + | otherwise = fromRational $ toRational v + -- | The result type of a binary operator. binOpType :: BinOp -> PrimType binOpType (Add t _) = IntType t @@ -1058,6 +1114,12 @@ convOpType (IToB from) = (IntType from, Bool) convOpType (BToI to) = (Bool, IntType to) +halfToWord :: Half -> Word16 +halfToWord (Half (CUShort x)) = x + +wordToHalf :: Word16 -> Half +wordToHalf = Half . CUShort + floatToWord :: Float -> Word32 floatToWord = G.runGet G.getWord32le . P.runPut . P.putFloatle @@ -1081,50 +1143,94 @@ ) primFuns = M.fromList - [ f32 "sqrt32" sqrt, + [ f16 "sqrt16" sqrt, + f32 "sqrt32" sqrt, f64 "sqrt64" sqrt, + -- + f16 "log16" log, f32 "log32" log, f64 "log64" log, + -- + f16 "log10_16" (logBase 10), f32 "log10_32" (logBase 10), f64 "log10_64" (logBase 10), + -- + f16 "log2_16" (logBase 2), f32 "log2_32" (logBase 2), f64 "log2_64" (logBase 2), + -- + f16 "exp16" exp, f32 "exp32" exp, f64 "exp64" exp, + -- + f16 "sin16" sin, f32 "sin32" sin, f64 "sin64" sin, + -- + f16 "sinh16" sinh, f32 "sinh32" sinh, f64 "sinh64" sinh, + -- + f16 "cos16" cos, f32 "cos32" cos, f64 "cos64" cos, + -- + f16 "cosh16" cosh, f32 "cosh32" cosh, f64 "cosh64" cosh, + -- + f16 "tan16" tan, f32 "tan32" tan, f64 "tan64" tan, + -- + f16 "tanh16" tanh, f32 "tanh32" tanh, f64 "tanh64" tanh, + -- + f16 "asin16" asin, f32 "asin32" asin, f64 "asin64" asin, + -- + f16 "asinh16" asinh, f32 "asinh32" asinh, f64 "asinh64" asinh, + -- + f16 "acos16" acos, f32 "acos32" acos, f64 "acos64" acos, + -- + f16 "acosh16" acosh, f32 "acosh32" acosh, f64 "acosh64" acosh, + -- + f16 "atan16" atan, f32 "atan32" atan, f64 "atan64" atan, + -- + f16 "atanh16" atanh, f32 "atanh32" atanh, f64 "atanh64" atanh, + -- + f16 "round16" $ convFloat . roundFloat . convFloat, f32 "round32" roundFloat, f64 "round64" roundDouble, + -- + f16 "ceil16" $ convFloat . ceilFloat . convFloat, f32 "ceil32" ceilFloat, f64 "ceil64" ceilDouble, + -- + f16 "floor16" $ convFloat . floorFloat . convFloat, f32 "floor32" floorFloat, f64 "floor64" floorDouble, + -- + f16 "gamma16" $ convFloat . tgammaf . convFloat, f32 "gamma32" tgammaf, f64 "gamma64" tgamma, + -- + f16 "lgamma16" $ convFloat . lgammaf . convFloat, f32 "lgamma32" lgammaf, f64 "lgamma64" lgamma, + -- i8 "clz8" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, i16 "clz16" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, i32 "clz32" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, @@ -1209,6 +1315,16 @@ _ -> Nothing ) ), + -- + ( "atan2_16", + ( [FloatType Float16, FloatType Float16], + FloatType Float16, + \case + [FloatValue (Float16Value x), FloatValue (Float16Value y)] -> + Just $ FloatValue $ Float16Value $ atan2 x y + _ -> Nothing + ) + ), ( "atan2_32", ( [FloatType Float32, FloatType Float32], FloatType Float32, @@ -1227,6 +1343,16 @@ _ -> Nothing ) ), + -- + ( "hypot16", + ( [FloatType Float16, FloatType Float16], + FloatType Float16, + \case + [FloatValue (Float16Value x), FloatValue (Float16Value y)] -> + Just $ FloatValue $ Float16Value $ convFloat $ hypotf (convFloat x) (convFloat y) + _ -> Nothing + ) + ), ( "hypot32", ( [FloatType Float32, FloatType Float32], FloatType Float32, @@ -1245,6 +1371,14 @@ _ -> Nothing ) ), + ( "isinf16", + ( [FloatType Float16], + Bool, + \case + [FloatValue (Float16Value x)] -> Just $ BoolValue $ isInfinite x + _ -> Nothing + ) + ), ( "isinf32", ( [FloatType Float32], Bool, @@ -1261,6 +1395,14 @@ _ -> Nothing ) ), + ( "isnan16", + ( [FloatType Float16], + Bool, + \case + [FloatValue (Float16Value x)] -> Just $ BoolValue $ isNaN x + _ -> Nothing + ) + ), ( "isnan32", ( [FloatType Float32], Bool, @@ -1277,6 +1419,15 @@ _ -> Nothing ) ), + ( "to_bits16", + ( [FloatType Float16], + IntType Int16, + \case + [FloatValue (Float16Value x)] -> + Just $ IntValue $ Int16Value $ fromIntegral $ halfToWord x + _ -> Nothing + ) + ), ( "to_bits32", ( [FloatType Float32], IntType Int32, @@ -1295,6 +1446,15 @@ _ -> Nothing ) ), + ( "from_bits16", + ( [IntType Int16], + FloatType Float16, + \case + [IntValue (Int16Value x)] -> + Just $ FloatValue $ Float16Value $ wordToHalf $ fromIntegral x + _ -> Nothing + ) + ), ( "from_bits32", ( [IntType Int32], FloatType Float32, @@ -1313,10 +1473,13 @@ _ -> Nothing ) ), + f16_3 "lerp16" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), f32_3 "lerp32" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), f64_3 "lerp64" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), + f16_3 "mad16" (\a b c -> a * b + c), f32_3 "mad32" (\a b c -> a * b + c), f64_3 "mad64" (\a b c -> a * b + c), + f16_3 "fma16" (\a b c -> a * b + c), f32_3 "fma32" (\a b c -> a * b + c), f64_3 "fma64" (\a b c -> a * b + c) ] @@ -1325,8 +1488,16 @@ i16 s f = (s, ([IntType Int16], IntType Int32, i16PrimFun f)) i32 s f = (s, ([IntType Int32], IntType Int32, i32PrimFun f)) i64 s f = (s, ([IntType Int64], IntType Int32, i64PrimFun f)) + f16 s f = (s, ([FloatType Float16], FloatType Float16, f16PrimFun f)) f32 s f = (s, ([FloatType Float32], FloatType Float32, f32PrimFun f)) f64 s f = (s, ([FloatType Float64], FloatType Float64, f64PrimFun f)) + f16_3 s f = + ( s, + ( [FloatType Float16, FloatType Float16, FloatType Float16], + FloatType Float16, + f16PrimFun3 f + ) + ) f32_3 s f = ( s, ( [FloatType Float32, FloatType Float32, FloatType Float32], @@ -1358,6 +1529,10 @@ Just $ f x i64PrimFun _ _ = Nothing + f16PrimFun f [FloatValue (Float16Value x)] = + Just $ FloatValue $ Float16Value $ f x + f16PrimFun _ _ = Nothing + f32PrimFun f [FloatValue (Float32Value x)] = Just $ FloatValue $ Float32Value $ f x f32PrimFun _ _ = Nothing @@ -1366,6 +1541,15 @@ Just $ FloatValue $ Float64Value $ f x f64PrimFun _ _ = Nothing + f16PrimFun3 + f + [ FloatValue (Float16Value a), + FloatValue (Float16Value b), + FloatValue (Float16Value c) + ] = + Just $ FloatValue $ Float16Value $ f a b c + f16PrimFun3 _ _ = Nothing + f32PrimFun3 f [ FloatValue (Float32Value a), @@ -1387,6 +1571,7 @@ -- | Is the given value kind of zero? zeroIsh :: PrimValue -> Bool zeroIsh (IntValue k) = zeroIshInt k +zeroIsh (FloatValue (Float16Value k)) = k == 0 zeroIsh (FloatValue (Float32Value k)) = k == 0 zeroIsh (FloatValue (Float64Value k)) = k == 0 zeroIsh (BoolValue False) = True @@ -1395,6 +1580,7 @@ -- | Is the given value kind of one? oneIsh :: PrimValue -> Bool oneIsh (IntValue k) = oneIshInt k +oneIsh (FloatValue (Float16Value k)) = k == 1 oneIsh (FloatValue (Float32Value k)) = k == 1 oneIsh (FloatValue (Float64Value k)) = k == 1 oneIsh (BoolValue True) = True @@ -1403,6 +1589,7 @@ -- | Is the given value kind of negative? negativeIsh :: PrimValue -> Bool negativeIsh (IntValue k) = negativeIshInt k +negativeIsh (FloatValue (Float16Value k)) = k < 0 negativeIsh (FloatValue (Float32Value k)) = k < 0 negativeIsh (FloatValue (Float64Value k)) = k < 0 negativeIsh (BoolValue _) = False @@ -1449,6 +1636,7 @@ -- | The size of a value of a given floating-point type in eight-bit bytes. floatByteSize :: Num a => FloatType -> a +floatByteSize Float16 = 2 floatByteSize Float32 = 4 floatByteSize Float64 = 8 @@ -1563,6 +1751,7 @@ taggedI s Int64 = text $ s ++ "64" taggedF :: String -> FloatType -> Doc +taggedF s Float16 = text $ s ++ "16" taggedF s Float32 = text $ s ++ "32" taggedF s Float64 = text $ s ++ "64" diff --git a/src/Futhark/IR/Primitive/Parse.hs b/src/Futhark/IR/Primitive/Parse.hs --- a/src/Futhark/IR/Primitive/Parse.hs +++ b/src/Futhark/IR/Primitive/Parse.hs @@ -48,6 +48,9 @@ pFloatValue = choice [ pNum, + keyword "f16.nan" $> Float16Value (0 / 0), + keyword "f16.inf" $> Float16Value (1 / 0), + keyword "-f16.inf" $> Float16Value (-1 / 0), keyword "f32.nan" $> Float32Value (0 / 0), keyword "f32.inf" $> Float32Value (1 / 0), keyword "-f32.inf" $> Float32Value (-1 / 0), 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 @@ -33,7 +33,7 @@ defAux, stmCerts, certify, - expExtTypesFromPattern, + expExtTypesFromPat, attrsForAssert, lamIsBinOp, ASTConstraints, @@ -125,7 +125,7 @@ safeBasicOp Replicate {} = True safeBasicOp Copy {} = True safeBasicOp _ = False -safeExp (DoLoop _ _ _ body) = safeBody body +safeExp (DoLoop _ _ body) = safeBody body safeExp (Apply fname _ _ _) = isBuiltInFunction fname safeExp (If _ tbranch fbranch _) = @@ -158,12 +158,14 @@ (xps, yps) = splitAt n2 (lambdaParams lam) okComponent c = isJust $ find (okBinOp c) $ bodyStms body - okBinOp (xp, yp, Var r) (Let (Pattern [] [pe]) _ (BasicOp (BinOp op (Var x) (Var y)))) = - patElemName pe == r - && commutativeBinOp op - && ( (x == paramName xp && y == paramName yp) - || (y == paramName xp && x == paramName yp) - ) + okBinOp + (xp, yp, SubExpRes _ (Var r)) + (Let (Pat [pe]) _ (BasicOp (BinOp op (Var x) (Var y)))) = + patElemName pe == r + && commutativeBinOp op + && ( (x == paramName xp && y == paramName yp) + || (y == paramName xp && x == paramName yp) + ) okBinOp _ _ = False in n2 * 2 == length (lambdaParams lam) && n2 == length (bodyResult body) @@ -178,16 +180,16 @@ entryPointSize (TypeUnsigned _) = 1 entryPointSize (TypeDirect _) = 1 --- | A 'StmAux' with empty 'Certificates'. +-- | A 'StmAux' with empty 'Certs'. defAux :: dec -> StmAux dec defAux = StmAux mempty mempty -- | The certificates associated with a statement. -stmCerts :: Stm rep -> Certificates +stmCerts :: Stm rep -> Certs stmCerts = stmAuxCerts . stmAux -- | Add certificates to a statement. -certify :: Certificates -> Stm rep -> Stm rep +certify :: Certs -> Stm rep -> Stm rep certify cs1 (Let pat (StmAux cs2 attrs dec) e) = Let pat (StmAux (cs2 <> cs1) attrs dec) e @@ -228,17 +230,17 @@ where -- | Given a pattern, construct the type of a body that would match -- it. An implementation for many representations would be - -- 'expExtTypesFromPattern'. - expTypesFromPattern :: + -- 'expExtTypesFromPat'. + expTypesFromPat :: (HasScope rep m, Monad m) => - Pattern rep -> + Pat rep -> m [BranchType rep] -- | Construct the type of an expression that would match the pattern. -expExtTypesFromPattern :: Typed dec => PatternT dec -> [ExtType] -expExtTypesFromPattern pat = - existentialiseExtTypes (patternContextNames pat) $ - staticShapes $ map patElemType $ patternValueElements pat +expExtTypesFromPat :: Typed dec => PatT dec -> [ExtType] +expExtTypesFromPat pat = + existentialiseExtTypes (patNames pat) $ + staticShapes $ map patElemType $ patElems pat -- | Keep only those attributes that are relevant for 'Assert' -- expressions. @@ -253,11 +255,12 @@ lamIsBinOp lam = mapM splitStm $ bodyResult $ lambdaBody lam where n = length $ lambdaReturnType lam - splitStm (Var res) = do - Let (Pattern [] [pe]) _ (BasicOp (BinOp op (Var x) (Var y))) <- - find (([res] ==) . patternNames . stmPattern) $ + splitStm (SubExpRes cs (Var res)) = do + guard $ cs == mempty + Let (Pat [pe]) _ (BasicOp (BinOp op (Var x) (Var y))) <- + find (([res] ==) . patNames . stmPat) $ stmsToList $ bodyStms $ lambdaBody lam - i <- Var res `elemIndex` bodyResult (lambdaBody lam) + i <- Var res `elemIndex` map resSubExp (bodyResult (lambdaBody lam)) xp <- maybeNth i $ lambdaParams lam yp <- maybeNth (n + i) $ lambdaParams lam guard $ paramName xp == x 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 @@ -14,7 +14,7 @@ module Futhark.IR.Prop.Aliases ( subExpAliases, expAliases, - patternAliases, + patAliases, lookupAliases, Aliased (..), AliasesOf (..), @@ -58,7 +58,7 @@ basicOpAliases :: BasicOp -> [Names] basicOpAliases (SubExp se) = [subExpAliases se] -basicOpAliases (Opaque se) = [subExpAliases se] +basicOpAliases (Opaque _ se) = [subExpAliases se] basicOpAliases (ArrayLit _ _) = [mempty] basicOpAliases BinOp {} = [mempty] basicOpAliases ConvOp {} = [mempty] @@ -66,6 +66,8 @@ basicOpAliases UnOp {} = [mempty] basicOpAliases (Index ident _) = [vnameAliases ident] basicOpAliases Update {} = [mempty] +basicOpAliases (FlatIndex ident _) = [vnameAliases ident] +basicOpAliases FlatUpdate {} = [mempty] basicOpAliases Iota {} = [mempty] basicOpAliases Replicate {} = [mempty] basicOpAliases Scratch {} = [mempty] @@ -99,12 +101,11 @@ (bodyAliases tb, consumedInBody tb) (bodyAliases fb, consumedInBody fb) expAliases (BasicOp op) = basicOpAliases op -expAliases (DoLoop ctxmerge valmerge _ loopbody) = - map (`namesSubtract` merge_names) val_aliases +expAliases (DoLoop merge _ loopbody) = + map (`namesSubtract` merge_names) aliases where - (_ctx_aliases, val_aliases) = - splitAt (length ctxmerge) $ bodyAliases loopbody - merge_names = namesFromList $ map (paramName . fst) $ ctxmerge ++ valmerge + aliases = bodyAliases loopbody + merge_names = namesFromList $ map (paramName . fst) merge expAliases (Apply _ args t _) = funcallAliases args $ map declExtTypeOf t expAliases (WithAcc inputs lam) = @@ -126,7 +127,7 @@ returnType' Acc {} = error "returnAliases Acc" returnType' Mem {} = - error "returnAliases Mem" + mconcat $ map (uncurry maskAliases) args maskAliases :: Names -> Diet -> Names maskAliases _ Consume = mempty @@ -146,7 +147,7 @@ consumeArg _ = mempty consumedInExp (If _ tb fb _) = consumedInBody tb <> consumedInBody fb -consumedInExp (DoLoop _ merge form body) = +consumedInExp (DoLoop merge form body) = mconcat ( map (subExpAliases . snd) $ filter (unique . paramDeclType . fst) merge @@ -166,7 +167,8 @@ ) where inputConsumed (_, arrs, _) = namesFromList arrs -consumedInExp (BasicOp (Update src _ _)) = oneName src +consumedInExp (BasicOp (Update _ src _ _)) = oneName src +consumedInExp (BasicOp (FlatUpdate src _ _)) = oneName src consumedInExp (BasicOp (UpdateAcc acc _ _)) = oneName acc consumedInExp (BasicOp _) = mempty consumedInExp (Op op) = consumedInOp op @@ -176,8 +178,8 @@ consumedByLambda = consumedInBody . lambdaBody -- | The aliases of each pattern element (including the context). -patternAliases :: AliasesOf dec => PatternT dec -> [Names] -patternAliases = map (aliasesOf . patElemDec) . patternElements +patAliases :: AliasesOf dec => PatT dec -> [Names] +patAliases = map (aliasesOf . patElemDec) . patElems -- | Something that contains alias information. class AliasesOf a where 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 @@ -265,18 +265,12 @@ ) => FreeIn (Exp rep) where - freeIn' (DoLoop ctxmerge valmerge form loopbody) = - let (ctxparams, ctxinits) = unzip ctxmerge - (valparams, valinits) = unzip valmerge + freeIn' (DoLoop merge form loopbody) = + let (params, args) = unzip merge bound_here = - namesFromList $ - M.keys $ - scopeOf form - <> scopeOfFParams (ctxparams ++ valparams) + namesFromList $ M.keys $ scopeOf form <> scopeOfFParams params in fvBind bound_here $ - freeIn' (ctxinits ++ valinits) <> freeIn' form - <> freeIn' (ctxparams ++ valparams) - <> freeIn' loopbody + freeIn' args <> freeIn' form <> freeIn' params <> freeIn' loopbody freeIn' (WithAcc inputs lam) = freeIn' inputs <> freeIn' lam freeIn' e = execState (walkExpM freeWalker e) mempty @@ -356,14 +350,26 @@ instance FreeIn d => FreeIn (DimIndex d) where freeIn' = Data.Foldable.foldMap freeIn' -instance FreeIn dec => FreeIn (PatternT dec) where - freeIn' (Pattern context values) = - fvBind bound_here $ freeIn' $ context ++ values +instance FreeIn d => FreeIn (Slice d) where + freeIn' = Data.Foldable.foldMap freeIn' + +instance FreeIn d => FreeIn (FlatDimIndex d) where + freeIn' = Data.Foldable.foldMap freeIn' + +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 (PatT dec) where + freeIn' (Pat xs) = + fvBind bound_here $ freeIn' xs where - bound_here = namesFromList $ map patElemName $ context ++ values + bound_here = namesFromList $ map patElemName xs -instance FreeIn Certificates where - freeIn' (Certificates cs) = freeIn' cs +instance FreeIn Certs where + freeIn' (Certs cs) = freeIn' cs instance FreeIn Attrs where freeIn' (Attrs _) = mempty @@ -403,7 +409,7 @@ -- | The names bound by a binding. boundByStm :: Stm rep -> Names -boundByStm = namesFromList . patternNames . stmPattern +boundByStm = namesFromList . patNames . stmPat -- | The names bound by the bindings. boundByStms :: Stms rep -> Names 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 @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} --- | Inspecing and modifying t'Pattern's, function parameters and +-- | Inspecing and modifying t'Pat's, function parameters and -- pattern elements. module Futhark.IR.Prop.Patterns ( -- * Function parameters @@ -9,23 +9,17 @@ paramType, paramDeclType, - -- * Pattern elements + -- * Pat elements patElemIdent, patElemType, setPatElemDec, - patternElements, - patternIdents, - patternContextIdents, - patternValueIdents, - patternNames, - patternValueNames, - patternContextNames, - patternTypes, - patternValueTypes, - patternSize, + patIdents, + patNames, + patTypes, + patSize, - -- * Pattern construction - basicPattern, + -- * Pat construction + basicPat, ) where @@ -56,49 +50,25 @@ setPatElemDec :: PatElemT oldattr -> newattr -> PatElemT newattr setPatElemDec pe x = fmap (const x) pe --- | All pattern elements in the pattern - context first, then values. -patternElements :: PatternT dec -> [PatElemT dec] -patternElements pat = patternContextElements pat ++ patternValueElements pat - --- | Return a list of the 'Ident's bound by the t'Pattern'. -patternIdents :: Typed dec => PatternT dec -> [Ident] -patternIdents pat = patternContextIdents pat ++ patternValueIdents pat - --- | Return a list of the context 'Ident's bound by the t'Pattern'. -patternContextIdents :: Typed dec => PatternT dec -> [Ident] -patternContextIdents = map patElemIdent . patternContextElements - --- | Return a list of the value 'Ident's bound by the t'Pattern'. -patternValueIdents :: Typed dec => PatternT dec -> [Ident] -patternValueIdents = map patElemIdent . patternValueElements - --- | Return a list of the 'Name's bound by the t'Pattern'. -patternNames :: PatternT dec -> [VName] -patternNames = map patElemName . patternElements - --- | Return a list of the 'Name's bound by the context part of the t'Pattern'. -patternContextNames :: PatternT dec -> [VName] -patternContextNames = map patElemName . patternContextElements +-- | Return a list of the 'Ident's bound by the t'Pat'. +patIdents :: Typed dec => PatT dec -> [Ident] +patIdents = map patElemIdent . patElems --- | Return a list of the 'Name's bound by the value part of the t'Pattern'. -patternValueNames :: PatternT dec -> [VName] -patternValueNames = map patElemName . patternValueElements +-- | Return a list of the 'Name's bound by the t'Pat'. +patNames :: PatT dec -> [VName] +patNames = map patElemName . patElems -- | Return a list of the typess bound by the pattern. -patternTypes :: Typed dec => PatternT dec -> [Type] -patternTypes = map identType . patternIdents - --- | Return a list of the typess bound by the value part of the pattern. -patternValueTypes :: Typed dec => PatternT dec -> [Type] -patternValueTypes = map identType . patternValueIdents +patTypes :: Typed dec => PatT dec -> [Type] +patTypes = map identType . patIdents -- | Return the number of names bound by the pattern. -patternSize :: PatternT dec -> Int -patternSize (Pattern context values) = length context + length values +patSize :: PatT dec -> Int +patSize (Pat xs) = length xs -- | Create a pattern using 'Type' as the attribute. -basicPattern :: [Ident] -> [Ident] -> PatternT Type -basicPattern context values = - Pattern (map patElem context) (map patElem values) +basicPat :: [Ident] -> PatT Type +basicPat values = + Pat $ map patElem values where patElem (Ident name t) = PatElem name t 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 @@ -25,7 +25,7 @@ inScopeOf, scopeOfLParams, scopeOfFParams, - scopeOfPattern, + scopeOfPat, scopeOfPatElem, SameScope, castScope, @@ -42,7 +42,6 @@ import Control.Monad.Reader import qualified Data.Map.Strict as M import Futhark.IR.Pretty () -import Futhark.IR.Prop.Patterns import Futhark.IR.Prop.Types import Futhark.IR.Rep import Futhark.IR.Syntax @@ -165,7 +164,7 @@ scopeOf = foldMap scopeOf instance Scoped rep (Stm rep) where - scopeOf = scopeOfPattern . stmPattern + scopeOf = scopeOfPat . stmPat instance Scoped rep (FunDef rep) where scopeOf = scopeOfFParams . funDefParams @@ -179,9 +178,9 @@ M.insert i (IndexName it) $ scopeOfLParams (map fst xs) -- | The scope of a pattern. -scopeOfPattern :: LetDec rep ~ dec => PatternT dec -> Scope rep -scopeOfPattern = - mconcat . map scopeOfPatElem . patternElements +scopeOfPat :: LetDec rep ~ dec => PatT dec -> Scope rep +scopeOfPat = + mconcat . map scopeOfPatElem . patElems -- | The scope of a pattern element. scopeOfPatElem :: LetDec rep ~ dec => PatElemT dec -> Scope rep 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 @@ -20,7 +20,8 @@ ( expExtType, expExtTypeSize, subExpType, - primOpType, + subExpResType, + basicOpType, mapType, -- * Return type @@ -34,9 +35,7 @@ ) where -import Data.Maybe import Futhark.IR.Prop.Constants -import Futhark.IR.Prop.Patterns import Futhark.IR.Prop.Reshape import Futhark.IR.Prop.Scope import Futhark.IR.Prop.Types @@ -48,6 +47,11 @@ 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 = subExpType . resSubExp + -- | @mapType f arrts@ wraps each element in the return type of @f@ in -- an array with size equal to the outermost dimension of the first -- element of @arrts@. @@ -58,65 +62,70 @@ ] -- | The type of a primitive operation. -primOpType :: HasScope rep m => BasicOp -> m [Type] -primOpType (SubExp se) = +basicOpType :: HasScope rep m => BasicOp -> m [Type] +basicOpType (SubExp se) = pure <$> subExpType se -primOpType (Opaque se) = +basicOpType (Opaque _ se) = pure <$> subExpType se -primOpType (ArrayLit es rt) = +basicOpType (ArrayLit es rt) = pure [arrayOf rt (Shape [n]) NoUniqueness] where n = intConst Int64 $ toInteger $ length es -primOpType (BinOp bop _ _) = +basicOpType (BinOp bop _ _) = pure [Prim $ binOpType bop] -primOpType (UnOp _ x) = +basicOpType (UnOp _ x) = pure <$> subExpType x -primOpType CmpOp {} = +basicOpType CmpOp {} = pure [Prim Bool] -primOpType (ConvOp conv _) = +basicOpType (ConvOp conv _) = pure [Prim $ snd $ convOpType conv] -primOpType (Index ident slice) = +basicOpType (Index ident slice) = result <$> lookupType ident where result t = [Prim (elemType t) `arrayOfShape` shape] - shape = Shape $ mapMaybe dimSize slice - dimSize (DimSlice _ d _) = Just d - dimSize DimFix {} = Nothing -primOpType (Update src _ _) = + shape = Shape $ sliceDims slice +basicOpType (Update _ src _ _) = pure <$> lookupType src -primOpType (Iota n _ _ et) = +basicOpType (FlatIndex ident slice) = + result <$> lookupType ident + where + result t = [Prim (elemType t) `arrayOfShape` shape] + shape = Shape $ flatSliceDims slice +basicOpType (FlatUpdate src _ _) = + pure <$> lookupType src +basicOpType (Iota n _ _ et) = pure [arrayOf (Prim (IntType et)) (Shape [n]) NoUniqueness] -primOpType (Replicate (Shape []) e) = +basicOpType (Replicate (Shape []) e) = pure <$> subExpType e -primOpType (Replicate shape e) = +basicOpType (Replicate shape e) = pure . flip arrayOfShape shape <$> subExpType e -primOpType (Scratch t shape) = +basicOpType (Scratch t shape) = pure [arrayOf (Prim t) (Shape shape) NoUniqueness] -primOpType (Reshape [] e) = +basicOpType (Reshape [] e) = result <$> lookupType e where result t = [Prim $ elemType t] -primOpType (Reshape shape e) = +basicOpType (Reshape shape e) = result <$> lookupType e where result t = [t `setArrayShape` newShape shape] -primOpType (Rearrange perm e) = +basicOpType (Rearrange perm e) = result <$> lookupType e where result t = [rearrangeType perm t] -primOpType (Rotate _ e) = +basicOpType (Rotate _ e) = pure <$> lookupType e -primOpType (Concat i x _ ressize) = +basicOpType (Concat i x _ ressize) = result <$> lookupType x where result xt = [setDimSize i xt ressize] -primOpType (Copy v) = +basicOpType (Copy v) = pure <$> lookupType v -primOpType (Manifest _ v) = +basicOpType (Manifest _ v) = pure <$> lookupType v -primOpType Assert {} = +basicOpType Assert {} = pure [Prim Unit] -primOpType (UpdateAcc v _ _) = +basicOpType (UpdateAcc v _ _) = pure <$> lookupType v -- | The type of an expression. @@ -126,9 +135,9 @@ m [ExtType] expExtType (Apply _ _ rt _) = pure $ map (fromDecl . declExtTypeOf) rt expExtType (If _ _ _ rt) = pure $ map extTypeOf $ ifReturns rt -expExtType (DoLoop ctxmerge valmerge _ _) = - pure $ loopExtType (map (paramIdent . fst) ctxmerge) (map (paramIdent . fst) valmerge) -expExtType (BasicOp op) = staticShapes <$> primOpType op +expExtType (DoLoop merge _ _) = + pure $ loopExtType $ map fst merge +expExtType (BasicOp op) = staticShapes <$> basicOpType op expExtType (WithAcc inputs lam) = fmap staticShapes $ (<>) @@ -160,13 +169,12 @@ lookupType = const $ pure $ Prim $ IntType Int64 askScope = pure mempty --- | Given the context and value merge parameters of a Futhark @loop@, --- produce the return type. -loopExtType :: [Ident] -> [Ident] -> [ExtType] -loopExtType ctx val = - existentialiseExtTypes inaccessible $ staticShapes $ map identType val +-- | Given the parameters of a loop, produce the return type. +loopExtType :: Typed dec => [Param dec] -> [ExtType] +loopExtType params = + existentialiseExtTypes inaccessible $ staticShapes $ map typeOf params where - inaccessible = map identName ctx + inaccessible = map paramName params -- | Any operation must define an instance of this class, which -- describes the type of the operation (at the value level). 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 @@ -434,12 +434,9 @@ return $ Just v extract' (Free _) _ = return Nothing --- | The set of identifiers used for the shape context in the given --- 'ExtType's. +-- | The 'Ext' integers used for existential sizes in the given types. shapeContext :: [TypeBase ExtShape u] -> S.Set Int -shapeContext = - S.fromList - . concatMap (mapMaybe ext . shapeDims . arrayShape) +shapeContext = S.fromList . concatMap (mapMaybe ext . shapeDims . arrayShape) where ext (Ext x) = Just x ext (Free _) = Nothing @@ -475,11 +472,7 @@ put (n + 1, m) return $ Ext n unifyExtDims (Ext x) (Ext y) - | x == y = - Ext - <$> ( maybe (new x) return - =<< gets (M.lookup x . snd) - ) + | x == y = Ext <$> (maybe (new x) return =<< gets (M.lookup x . snd)) unifyExtDims (Ext x) _ = Ext <$> new x unifyExtDims _ (Ext x) = Ext <$> new x new x = do 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 @@ -43,8 +43,8 @@ [(SubExp, Type)] -> Maybe [rt] --- | Given shape parameter names and value parameter types, produce the --- types of arguments accepted. +-- | Given shape parameter names and types, produce the types of +-- arguments accepted. expectedTypes :: Typed t => [VName] -> [t] -> [SubExp] -> [Type] expectedTypes shapes value_ts args = map (correctDims . typeOf) value_ts where 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 @@ -8,7 +8,7 @@ -- * Syntax types Body, Stm, - Pattern, + Pat, Exp, Lambda, FParam, @@ -24,12 +24,12 @@ module Futhark.IR.SOACS.SOAC, AST.LambdaT (Lambda), AST.BodyT (Body), - AST.PatternT (Pattern), + AST.PatT (Pat), AST.PatElemT (PatElem), ) where -import Futhark.Binder +import Futhark.Builder import Futhark.Construct import Futhark.IR.Pretty import Futhark.IR.Prop @@ -40,8 +40,8 @@ FParam, LParam, Lambda, + Pat, PatElem, - Pattern, RetType, Stm, ) @@ -60,7 +60,7 @@ type Op SOACS = SOAC SOACS instance ASTRep SOACS where - expTypesFromPattern = return . expExtTypesFromPattern + expTypesFromPat = return . expExtTypesFromPat type Exp = AST.Exp SOACS @@ -68,7 +68,7 @@ type Stm = AST.Stm SOACS -type Pattern = AST.Pattern SOACS +type Pat = AST.Pat SOACS type Lambda = AST.Lambda SOACS @@ -85,12 +85,12 @@ instance TypeCheck.Checkable SOACS -instance Bindable SOACS where +instance Buildable SOACS where mkBody = AST.Body () - mkExpPat ctx val _ = basicPattern ctx val + mkExpPat merge _ = basicPat merge mkExpDec _ _ = () mkLetNames = simpleMkLetNames -instance BinderOps SOACS +instance BuilderOps SOACS instance PrettyRep SOACS 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 @@ -161,7 +161,7 @@ (Lambda rep) deriving (Eq, Ord, Show) -singleBinOp :: Bindable rep => [Lambda rep] -> Lambda rep +singleBinOp :: Buildable rep => [Lambda rep] -> Lambda rep singleBinOp lams = Lambda { lambdaParams = concatMap xParams lams ++ concatMap yParams lams, @@ -187,7 +187,7 @@ scanResults = sum . map (length . scanNeutral) -- | Combine multiple scan operators to a single operator. -singleScan :: Bindable 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 @@ -206,7 +206,7 @@ redResults = sum . map (length . redNeutral) -- | Combine multiple reduction operators to a single operator. -singleReduce :: Bindable 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 @@ -227,7 +227,7 @@ -- | Construct a lambda that takes parameters of the given types and -- simply returns them unchanged. mkIdentityLambda :: - (Bindable rep, MonadFreshNames m) => + (Buildable rep, MonadFreshNames m) => [Type] -> m (Lambda rep) mkIdentityLambda ts = do @@ -235,18 +235,18 @@ return Lambda { lambdaParams = params, - lambdaBody = mkBody mempty $ map (Var . paramName) params, + lambdaBody = mkBody mempty $ varsRes $ map paramName params, lambdaReturnType = ts } -- | Is the given lambda an identity lambda? isIdentityLambda :: Lambda rep -> Bool isIdentityLambda lam = - bodyResult (lambdaBody lam) + map resSubExp (bodyResult (lambdaBody lam)) == map (Var . paramName) (lambdaParams lam) -- | A lambda with no parameters that returns no values. -nilFn :: Bindable rep => Lambda rep +nilFn :: Buildable rep => Lambda rep nilFn = Lambda mempty (mkBody mempty mempty) mempty -- | Construct a Screma with possibly multiple scans, and @@ -262,7 +262,7 @@ -- | Construct a Screma with possibly multiple scans, and identity map -- function. scanSOAC :: - (Bindable rep, MonadFreshNames m) => + (Buildable rep, MonadFreshNames m) => [Scan rep] -> m (ScremaForm rep) scanSOAC scans = scanomapSOAC scans <$> mkIdentityLambda ts @@ -272,7 +272,7 @@ -- | Construct a Screma with possibly multiple reductions, and -- identity map function. reduceSOAC :: - (Bindable rep, MonadFreshNames m) => + (Buildable rep, MonadFreshNames m) => [Reduce rep] -> m (ScremaForm rep) reduceSOAC reds = redomapSOAC reds <$> mkIdentityLambda ts @@ -327,7 +327,7 @@ -- This function is used for extracting and grouping the results of a -- scatter. In the SOAC representation, the lambda inside a 'Scatter' returns -- all indices and values as one big list. This function groups each value with --- its corresponding indices (as determined by the 'Shape' of the output array). +-- its corresponding indices (as determined by the t'Shape' of the output array). -- -- The elements of the resulting list correspond to the shape and name of the -- output parameters, in addition to a list of values written to that output @@ -601,7 +601,7 @@ let arr_indexes = M.fromList $ catMaybes $ zipWith arrIndex arr_params arrs arr_indexes' = foldl expandPrimExpTable arr_indexes $ bodyStms $ lambdaBody lam case se of - Var v -> uncurry (flip ST.Indexed) <$> M.lookup v arr_indexes' + SubExpRes _ (Var v) -> uncurry (flip ST.Indexed) <$> M.lookup v arr_indexes' _ -> Nothing where lambdaAndSubExp (Screma _ arrs (ScremaForm scans reds map_lam)) = @@ -618,10 +618,10 @@ return (paramName p, (pe, cs)) expandPrimExpTable table stm - | [v] <- patternNames $ stmPattern stm, + | [v] <- patNames $ stmPat stm, Just (pe, cs) <- runWriterT $ primExpFromExp (asPrimExp table) $ stmExp stm, - all (`ST.elem` vtable) (unCertificates $ stmCerts stm) = + all (`ST.elem` vtable) (unCerts $ stmCerts stm) = M.insert v (pe, stmCerts stm <> cs) table | otherwise = table 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 @@ -152,15 +152,15 @@ ) <*> pure (mconcat scans_hoisted <> mconcat reds_hoisted <> map_lam_hoisted) -instance BinderOps (Wise SOACS) +instance BuilderOps (Wise SOACS) fixLambdaParams :: - (MonadBinder m, Bindable (Rep m), BinderOps (Rep m)) => + (MonadBuilder m, Buildable (Rep m), BuilderOps (Rep m)) => AST.Lambda (Rep m) -> [Maybe SubExp] -> m (AST.Lambda (Rep m)) fixLambdaParams lam fixes = do - body <- runBodyBinder $ + body <- runBodyBuilder $ localScope (scopeOfLParams $ lambdaParams lam) $ do zipWithM_ maybeFix (lambdaParams lam) fixes' return $ lambdaBody lam @@ -205,7 +205,7 @@ topDownRules :: [TopDownRule (Wise SOACS)] topDownRules = - [ RuleOp hoistCertificates, + [ RuleOp hoistCerts, RuleOp removeReplicateMapping, RuleOp removeReplicateWrite, RuleOp removeUnusedSOACInput, @@ -230,8 +230,8 @@ -- Any certificates attached to a trivial Stm in the body might as -- well be applied to the SOAC itself. -hoistCertificates :: TopDownRuleOp (Wise SOACS) -hoistCertificates vtable pat aux soac +hoistCerts :: TopDownRuleOp (Wise SOACS) +hoistCerts vtable pat aux soac | (soac', hoisted) <- runState (mapSOACM mapper soac) mempty, hoisted /= mempty = Simplify $ auxing aux $ certifying hoisted $ letBind pat $ Op soac' @@ -247,17 +247,17 @@ onStm (Let se_pat se_aux (BasicOp (SubExp se))) = do let (invariant, variant) = partition (`ST.elem` vtable) $ - unCertificates $ stmAuxCerts se_aux - se_aux' = se_aux {stmAuxCerts = Certificates variant} - modify (Certificates invariant <>) + unCerts $ stmAuxCerts se_aux + se_aux' = se_aux {stmAuxCerts = Certs variant} + modify (Certs invariant <>) return $ Let se_pat se_aux' $ BasicOp $ SubExp se onStm stm = return stm -hoistCertificates _ _ _ _ = +hoistCerts _ _ _ _ = Skip liftIdentityMapping :: forall rep. - (Bindable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) => + (Buildable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) => TopDownRuleOp (Wise rep) liftIdentityMapping _ pat aux op | Just (Screma w arrs form :: SOAC (Wise rep)) <- asSOAC op, @@ -270,15 +270,19 @@ freeOrConst (Var v) = v `nameIn` free freeOrConst Constant {} = True - checkInvariance (outId, Var v, _) (invariant, mapresult, rettype') + checkInvariance (outId, SubExpRes _ (Var v), _) (invariant, mapresult, rettype') | Just inp <- M.lookup v inputMap = - ( (Pattern [] [outId], BasicOp (Copy inp)) : invariant, + ( (Pat [outId], e inp) : invariant, mapresult, rettype' ) - checkInvariance (outId, e, t) (invariant, mapresult, rettype') + where + e inp = case patElemType outId of + Acc {} -> BasicOp $ SubExp $ Var inp + _ -> BasicOp (Copy inp) + checkInvariance (outId, SubExpRes _ e, t) (invariant, mapresult, rettype') | freeOrConst e = - ( (Pattern [] [outId], BasicOp $ Replicate (Shape [w]) e) : invariant, + ( (Pat [outId], BasicOp $ Replicate (Shape [w]) e) : invariant, mapresult, rettype' ) @@ -289,13 +293,13 @@ ) case foldr checkInvariance ([], [], []) $ - zip3 (patternElements pat) ses rettype of + zip3 (patElems pat) ses rettype of ([], _, _) -> Skip (invariant, mapresult, rettype') -> Simplify $ do let (pat', ses') = unzip mapresult fun' = fun - { lambdaBody = (lambdaBody fun) {bodyResult = ses'}, + { lambdaBody = (lambdaBody fun) {bodyResult = subExpsRes ses'}, lambdaReturnType = rettype' } mapM_ (uncurry letBind) invariant @@ -304,12 +308,12 @@ liftIdentityMapping _ _ _ _ = Skip liftIdentityStreaming :: BottomUpRuleOp (Wise SOACS) -liftIdentityStreaming _ (Pattern [] pes) aux (Stream w arrs form nes lam) +liftIdentityStreaming _ (Pat pes) aux (Stream w arrs form nes lam) | (variant_map, invariant_map) <- partitionEithers $ map isInvariantRes $ zip3 map_ts map_pes map_res, not $ null invariant_map = Simplify $ do forM_ invariant_map $ \(pe, arr) -> - letBind (Pattern [] [pe]) $ BasicOp $ Copy arr + letBind (Pat [pe]) $ BasicOp $ Copy arr let (variant_map_ts, variant_map_pes, variant_map_res) = unzip3 variant_map lam' = @@ -319,7 +323,7 @@ } auxing aux $ - letBind (Pattern [] $ fold_pes ++ variant_map_pes) $ + letBind (Pat $ fold_pes ++ variant_map_pes) $ Op $ Stream w arrs form nes lam' where num_folds = length nes @@ -329,7 +333,7 @@ (fold_res, map_res) = splitAt num_folds lam_res params_to_arrs = zip (map paramName $ drop (1 + num_folds) $ lambdaParams lam) arrs - isInvariantRes (_, pe, Var v) + isInvariantRes (_, pe, SubExpRes _ (Var v)) | Just arr <- lookup v params_to_arrs = Right (pe, arr) isInvariantRes x = @@ -339,7 +343,7 @@ -- | Remove all arguments to the map that are simply replicates. -- These can be turned into free variables instead. removeReplicateMapping :: - (Bindable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) => + (Buildable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) => TopDownRuleOp (Wise rep) removeReplicateMapping vtable pat aux op | Just (Screma w arrs form) <- asSOAC op, @@ -363,7 +367,7 @@ AST.Lambda rep -> [VName] -> Maybe - ( [([VName], Certificates, AST.Exp rep)], + ( [([VName], Certs, AST.Exp rep)], AST.Lambda rep, [VName] ) @@ -416,26 +420,24 @@ (pat', ses', ts') = unzip3 $ filter isUsed $ - zip3 (patternElements pat) ses $ lambdaReturnType fun + zip3 (patElems pat) ses $ lambdaReturnType fun fun' = fun { lambdaBody = (lambdaBody fun) {bodyResult = ses'}, lambdaReturnType = ts' } - in if pat /= Pattern [] pat' + in if pat /= Pat pat' then - Simplify $ - auxing aux $ - letBind (Pattern [] pat') $ Op $ Screma w arrs $ mapSOAC fun' + Simplify . auxing aux $ + letBind (Pat pat') $ Op $ Screma w arrs $ mapSOAC fun' else Skip removeDeadMapping _ _ _ _ = Skip removeDuplicateMapOutput :: TopDownRuleOp (Wise SOACS) -removeDuplicateMapOutput _ pat aux (Screma w arrs form) +removeDuplicateMapOutput _ (Pat pes) aux (Screma w arrs form) | Just fun <- isMapSOAC form = let ses = bodyResult $ lambdaBody fun ts = lambdaReturnType fun - pes = patternValueElements pat ses_ts_pes = zip3 ses ts pes (ses_ts_pes', copies) = foldl checkForDuplicates (mempty, mempty) ses_ts_pes @@ -443,19 +445,18 @@ then Skip else Simplify $ do let (ses', ts', pes') = unzip3 ses_ts_pes' - pat' = Pattern [] pes' fun' = fun { lambdaBody = (lambdaBody fun) {bodyResult = ses'}, lambdaReturnType = ts' } - auxing aux $ letBind pat' $ Op $ Screma w arrs $ mapSOAC fun' + auxing aux $ letBind (Pat pes') $ Op $ Screma w arrs $ mapSOAC fun' forM_ copies $ \(from, to) -> - letBind (Pattern [] [to]) $ BasicOp $ Copy $ patElemName from + letBind (Pat [to]) $ BasicOp $ Copy $ patElemName from where checkForDuplicates (ses_ts_pes', copies) (se, t, pe) - | Just (_, _, pe') <- find (\(x, _, _) -> x == se) ses_ts_pes' = - -- This subexp has been returned before, producing the + | Just (_, _, pe') <- find (\(x, _, _) -> resSubExp x == resSubExp se) ses_ts_pes' = + -- This result has been returned before, producing the -- array pe'. (ses_ts_pes', (pe', pe) : copies) | otherwise = (ses_ts_pes' ++ [(se, t, pe)], copies) @@ -514,23 +515,23 @@ mapOpToOp _ _ _ _ = Skip isMapWithOp :: - PatternT dec -> + PatT dec -> SOAC (Wise SOACS) -> Maybe ( PatElemT dec, - Certificates, + Certs, SubExp, AST.Exp (Wise SOACS), [Param Type], [VName] ) isMapWithOp pat e - | Pattern [] [map_pe] <- pat, + | Pat [map_pe] <- pat, Screma w arrs form <- e, Just map_lam <- isMapSOAC form, - [Let (Pattern [] [pe]) aux2 e'] <- + [Let (Pat [pe]) aux2 e'] <- stmsToList $ bodyStms $ lambdaBody map_lam, - [Var r] <- bodyResult $ lambdaBody map_lam, + [SubExpRes _ (Var r)] <- bodyResult $ lambdaBody map_lam, r == patElemName pe = Just (map_pe, stmAuxCerts aux2, w, e', lambdaParams map_lam, arrs) | otherwise = Nothing @@ -542,8 +543,8 @@ removeDeadReduction :: BottomUpRuleOp (Wise SOACS) removeDeadReduction (_, used) pat aux (Screma w arrs form) | Just ([Reduce comm redlam nes], maplam) <- isRedomapSOAC form, - not $ all (`UT.used` used) $ patternNames pat, -- Quick/cheap check - let (red_pes, map_pes) = splitAt (length nes) $ patternElements pat, + not $ all (`UT.used` used) $ patNames pat, -- Quick/cheap check + let (red_pes, map_pes) = splitAt (length nes) $ patElems pat, let redlam_deps = dataDependencies $ lambdaBody redlam, let redlam_res = bodyResult $ lambdaBody redlam, let redlam_params = lambdaParams redlam, @@ -554,7 +555,7 @@ let necessary = findNecessaryForReturned (`elem` used_after) - (zip redlam_params $ redlam_res <> redlam_res) + (zip redlam_params $ map resSubExp $ redlam_res <> redlam_res) redlam_deps, let alive_mask = map ((`nameIn` necessary) . paramName) redlam_params, not $ all (== True) alive_mask = Simplify $ do @@ -569,7 +570,7 @@ redlam' <- removeLambdaResults (take (length nes) alive_mask) <$> fixLambdaParams redlam (dead_fix ++ dead_fix) auxing aux $ - letBind (Pattern [] $ used_red_pes ++ map_pes) $ + letBind (Pat $ used_red_pes ++ map_pes) $ Op $ Screma w arrs $ redomapSOAC [Reduce comm redlam' used_nes] maplam' removeDeadReduction _ _ _ _ = Skip @@ -582,17 +583,17 @@ (pat', i_ses', v_ses', i_ts', v_ts', dests') = unzip6 $ filter isUsed $ - zip6 (patternElements pat) i_ses v_ses i_ts v_ts dests + zip6 (patElems pat) i_ses v_ses i_ts v_ts dests fun' = fun { lambdaBody = (lambdaBody fun) {bodyResult = concat i_ses' ++ v_ses'}, lambdaReturnType = concat i_ts' ++ v_ts' } - in if pat /= Pattern [] pat' + in if pat /= Pat pat' then Simplify $ auxing aux $ - letBind (Pattern [] pat') $ Op $ Scatter w fun' arrs dests' + letBind (Pat pat') $ Op $ Scatter w fun' arrs dests' else Skip removeDeadWrite _ _ _ _ = Skip @@ -650,7 +651,7 @@ | Just nes <- concatMap redNeutral . fst <$> isRedomapSOAC form, zeroIsh w = Simplify $ - forM_ (zip (patternNames pat) nes) $ \(v, ne) -> + forM_ (zip (patNames pat) nes) $ \(v, ne) -> letBindNames [v] $ BasicOp $ SubExp ne simplifyClosedFormReduce vtable pat _ (Screma _ arrs form) | Just [Reduce _ red_fun nes] <- isReduceSOAC form = @@ -659,7 +660,7 @@ -- For now we just remove singleton SOACs. simplifyKnownIterationSOAC :: - (Bindable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) => + (Buildable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) => TopDownRuleOp (Wise rep) simplifyKnownIterationSOAC _ pat _ op | Just (Screma (Constant k) arrs (ScremaForm scans reds map_lam)) <- asSOAC op, @@ -668,23 +669,23 @@ (Scan scan_lam scan_nes) = singleScan scans (scan_pes, red_pes, map_pes) = splitAt3 (length scan_nes) (length red_nes) $ - patternElements pat + patElems pat bindMapParam p a = do a_t <- lookupType a letBindNames [paramName p] $ BasicOp $ Index a $ fullSlice a_t [DimFix $ constant (0 :: Int64)] - bindArrayResult pe se = - letBindNames [patElemName pe] $ + bindArrayResult pe (SubExpRes cs se) = + certifying cs . letBindNames [patElemName pe] $ BasicOp $ ArrayLit [se] $ rowType $ patElemType pe - bindResult pe se = - letBindNames [patElemName pe] $ BasicOp $ SubExp se + bindResult pe (SubExpRes cs se) = + certifying cs $ letBindNames [patElemName pe] $ BasicOp $ SubExp se zipWithM_ bindMapParam (lambdaParams map_lam) arrs (to_scan, to_red, map_res) <- splitAt3 (length scan_nes) (length red_nes) <$> bodyBind (lambdaBody map_lam) - scan_res <- eLambda scan_lam $ map eSubExp $ scan_nes ++ to_scan - red_res <- eLambda red_lam $ map eSubExp $ red_nes ++ to_red + scan_res <- eLambda scan_lam $ map eSubExp $ scan_nes ++ map resSubExp to_scan + red_res <- eLambda red_lam $ map eSubExp $ red_nes ++ map resSubExp to_red zipWithM_ bindArrayResult scan_pes scan_res zipWithM_ bindResult red_pes red_res @@ -706,17 +707,17 @@ res <- bodyBind $ lambdaBody fold_lam - forM_ (zip (patternNames pat) res) $ \(v, se) -> - letBindNames [v] $ BasicOp $ SubExp se + forM_ (zip (patNames pat) res) $ \(v, SubExpRes cs se) -> + certifying cs $ letBindNames [v] $ BasicOp $ SubExp se simplifyKnownIterationSOAC _ _ _ _ = Skip data ArrayOp - = ArrayIndexing Certificates VName (Slice SubExp) - | ArrayRearrange Certificates VName [Int] - | ArrayRotate Certificates VName [SubExp] - | ArrayCopy Certificates VName + = ArrayIndexing Certs VName (Slice SubExp) + | ArrayRearrange Certs VName [Int] + | ArrayRotate Certs VName [SubExp] + | ArrayCopy Certs VName | -- | Never constructed. - ArrayVar Certificates VName + ArrayVar Certs VName deriving (Eq, Ord, Show) arrayOpArr :: ArrayOp -> VName @@ -726,14 +727,14 @@ arrayOpArr (ArrayCopy _ arr) = arr arrayOpArr (ArrayVar _ arr) = arr -arrayOpCerts :: ArrayOp -> Certificates +arrayOpCerts :: ArrayOp -> Certs arrayOpCerts (ArrayIndexing cs _ _) = cs arrayOpCerts (ArrayRearrange cs _ _) = cs arrayOpCerts (ArrayRotate cs _ _) = cs arrayOpCerts (ArrayCopy cs _) = cs arrayOpCerts (ArrayVar cs _) = cs -isArrayOp :: Certificates -> AST.Exp (Wise SOACS) -> Maybe ArrayOp +isArrayOp :: Certs -> AST.Exp (Wise SOACS) -> Maybe ArrayOp isArrayOp cs (BasicOp (Index arr slice)) = Just $ ArrayIndexing cs arr slice isArrayOp cs (BasicOp (Rearrange perm arr)) = @@ -745,14 +746,14 @@ isArrayOp _ _ = Nothing -fromArrayOp :: ArrayOp -> (Certificates, AST.Exp (Wise SOACS)) +fromArrayOp :: ArrayOp -> (Certs, AST.Exp (Wise SOACS)) fromArrayOp (ArrayIndexing cs arr slice) = (cs, BasicOp $ Index arr slice) fromArrayOp (ArrayRearrange cs arr perm) = (cs, BasicOp $ Rearrange perm arr) fromArrayOp (ArrayRotate cs arr rots) = (cs, BasicOp $ Rotate rots arr) fromArrayOp (ArrayCopy cs arr) = (cs, BasicOp $ Copy arr) fromArrayOp (ArrayVar cs arr) = (cs, BasicOp $ SubExp $ Var arr) -arrayOps :: AST.Body (Wise SOACS) -> S.Set (AST.Pattern (Wise SOACS), ArrayOp) +arrayOps :: AST.Body (Wise SOACS) -> S.Set (AST.Pat (Wise SOACS), ArrayOp) arrayOps = mconcat . map onStm . stmsToList . bodyStms where onStm (Let pat aux e) = @@ -778,8 +779,7 @@ where onStm (Let pat aux e) = let (cs', e') = onExp (stmAuxCerts aux) e - in certify cs' $ - mkLet' (patternContextIdents pat) (patternValueIdents pat) aux e' + in certify cs' $ mkLet' (patIdents pat) aux e' onExp cs e | Just op <- isArrayOp cs e, Just op' <- M.lookup op substs = @@ -838,9 +838,9 @@ zeroIsh o && oneIsh s _ -> False - indexesWith v (ArrayIndexing cs arr (DimFix (Var i) : _)) + indexesWith v (ArrayIndexing cs arr (Slice (DimFix (Var i) : _))) | arr `ST.elem` vtable, - all (`ST.elem` vtable) $ unCertificates cs = + all (`ST.elem` vtable) $ unCerts cs = i == v indexesWith _ _ = False @@ -851,16 +851,13 @@ if arraySize 0 arr_t == w then return arr else - certifying cs $ - letExp (baseString arr ++ "_prefix") $ - BasicOp $ - Index arr $ - fullSlice arr_t [DimSlice (intConst Int64 0) w (intConst Int64 1)] + certifying cs . letExp (baseString arr ++ "_prefix") . BasicOp . Index arr $ + fullSlice arr_t [DimSlice (intConst Int64 0) w (intConst Int64 1)] return $ Just ( arr', Param arr_elem (rowType arr_t), - ArrayIndexing cs arr_elem (drop 1 slice) + ArrayIndexing cs arr_elem (Slice (drop 1 (unSlice slice))) ) mapOverArr _ = return Nothing simplifyMapIota _ _ _ _ = Skip @@ -891,7 +888,7 @@ letBind pat $ Op $ Screma w (arrs <> more_arrs) (ScremaForm scan reduce map_lam') where map_param_names = map paramName (lambdaParams map_lam) - topLevelPattern = (`elem` fmap stmPattern (bodyStms (lambdaBody map_lam))) + topLevelPat = (`elem` fmap stmPat (bodyStms (lambdaBody map_lam))) onlyUsedOnce arr = case filter ((arr `nameIn`) . freeIn) $ stmsToList $ bodyStms $ lambdaBody map_lam of _ : _ : _ -> False @@ -903,7 +900,7 @@ arr `elem` map_param_names && all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn slice) && not (null slice) - && (not (null $ sliceDims slice) || (topLevelPattern pat' && onlyUsedOnce arr)) + && (not (null $ sliceDims slice) || (topLevelPat pat' && onlyUsedOnce arr)) arrayIsMapParam (_, ArrayRearrange cs arr perm) = arr `elem` map_param_names && all (`ST.elem` vtable) (namesToList $ freeIn cs) @@ -924,8 +921,8 @@ arr_transformed <- certifying (arrayOpCerts op) $ letExp (baseString arr ++ "_transformed") $ case op of - ArrayIndexing _ _ slice -> - BasicOp $ Index arr $ whole_dim : slice + ArrayIndexing _ _ (Slice slice) -> + BasicOp $ Index arr $ Slice $ whole_dim : slice ArrayRearrange _ _ perm -> BasicOp $ Rearrange (0 : map (+ 1) perm) arr ArrayRotate _ _ rots -> diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs --- a/src/Futhark/IR/SegOp.hs +++ b/src/Futhark/IR/SegOp.hs @@ -32,6 +32,7 @@ consumedInKernelBody, ResultManifest (..), KernelResult (..), + kernelResultCerts, kernelResultSubExp, SplitOrdering (..), @@ -56,6 +57,7 @@ import Control.Monad.Writer hiding (mapM_) import Data.Bifunctor (first) import Data.Bitraversable +import Data.Foldable (traverse_) import Data.List ( elemIndex, foldl', @@ -206,23 +208,27 @@ = -- | Each "worker" in the kernel returns this. -- Whether this is a result-per-thread or a -- result-per-group depends on where the 'SegOp' occurs. - Returns ResultManifest SubExp + Returns ResultManifest Certs SubExp | WriteReturns + Certs Shape -- Size of array. Must match number of dims. VName -- Which array [(Slice SubExp, SubExp)] | -- Arbitrary number of index/value pairs. ConcatReturns + Certs SplitOrdering -- Permuted? SubExp -- The final size. SubExp -- Per-thread/group (max) chunk size. VName -- Chunk by this worker. | TileReturns + Certs [(SubExp, SubExp)] -- Total/tile for each dimension VName -- Tile written by this worker. -- The TileReturns must not expect more than one -- result to be written per physical thread. | RegTileReturns + Certs -- For each dim of result: [ ( SubExp, -- size of this dim. SubExp, -- block tile size for this dim. @@ -232,23 +238,31 @@ VName -- Tile returned by this worker/group. deriving (Eq, Show, Ord) +-- | Get the certs for this 'KernelResult'. +kernelResultCerts :: KernelResult -> Certs +kernelResultCerts (Returns _ cs _) = cs +kernelResultCerts (WriteReturns cs _ _ _) = cs +kernelResultCerts (ConcatReturns cs _ _ _ _) = cs +kernelResultCerts (TileReturns cs _ _) = cs +kernelResultCerts (RegTileReturns cs _ _) = cs + -- | Get the root t'SubExp' corresponding values for a 'KernelResult'. kernelResultSubExp :: KernelResult -> SubExp -kernelResultSubExp (Returns _ se) = se -kernelResultSubExp (WriteReturns _ arr _) = Var arr -kernelResultSubExp (ConcatReturns _ _ _ v) = Var v -kernelResultSubExp (TileReturns _ v) = Var v -kernelResultSubExp (RegTileReturns _ v) = Var v +kernelResultSubExp (Returns _ _ se) = se +kernelResultSubExp (WriteReturns _ _ arr _) = Var arr +kernelResultSubExp (ConcatReturns _ _ _ _ v) = Var v +kernelResultSubExp (TileReturns _ _ v) = Var v +kernelResultSubExp (RegTileReturns _ _ v) = Var v instance FreeIn KernelResult where - freeIn' (Returns _ what) = freeIn' what - freeIn' (WriteReturns rws arr res) = freeIn' rws <> freeIn' arr <> freeIn' res - freeIn' (ConcatReturns o w per_thread_elems v) = - freeIn' o <> freeIn' w <> freeIn' per_thread_elems <> freeIn' v - freeIn' (TileReturns dims v) = - freeIn' dims <> freeIn' v - freeIn' (RegTileReturns dims_n_tiles v) = - freeIn' dims_n_tiles <> freeIn' v + freeIn' (Returns _ cs what) = freeIn' cs <> freeIn' what + freeIn' (WriteReturns cs rws arr res) = freeIn' cs <> freeIn' rws <> freeIn' arr <> freeIn' res + freeIn' (ConcatReturns cs o w per_thread_elems v) = + freeIn' cs <> freeIn' o <> freeIn' w <> freeIn' per_thread_elems <> freeIn' v + freeIn' (TileReturns cs dims v) = + freeIn' cs <> freeIn' dims <> freeIn' v + freeIn' (RegTileReturns cs dims_n_tiles v) = + freeIn' cs <> freeIn' dims_n_tiles <> freeIn' v instance ASTRep rep => FreeIn (KernelBody rep) where freeIn' (KernelBody dec stms res) = @@ -264,23 +278,29 @@ (substituteNames subst res) instance Substitute KernelResult where - substituteNames subst (Returns manifest se) = - Returns manifest (substituteNames subst se) - substituteNames subst (WriteReturns rws arr res) = + substituteNames subst (Returns manifest cs se) = + Returns manifest (substituteNames subst cs) (substituteNames subst se) + substituteNames subst (WriteReturns cs rws arr res) = WriteReturns + (substituteNames subst cs) (substituteNames subst rws) (substituteNames subst arr) (substituteNames subst res) - substituteNames subst (ConcatReturns o w per_thread_elems v) = + substituteNames subst (ConcatReturns cs o w per_thread_elems v) = ConcatReturns + (substituteNames subst cs) (substituteNames subst o) (substituteNames subst w) (substituteNames subst per_thread_elems) (substituteNames subst v) - substituteNames subst (TileReturns dims v) = - TileReturns (substituteNames subst dims) (substituteNames subst v) - substituteNames subst (RegTileReturns dims_n_tiles v) = + substituteNames subst (TileReturns cs dims v) = + TileReturns + (substituteNames subst cs) + (substituteNames subst dims) + (substituteNames subst v) + substituteNames subst (RegTileReturns cs dims_n_tiles v) = RegTileReturns + (substituteNames subst cs) (substituteNames subst dims_n_tiles) (substituteNames subst v) @@ -328,7 +348,7 @@ consumedInKernelBody (KernelBody dec stms res) = consumedInBody (Body dec stms []) <> mconcat (map consumedByReturn res) where - consumedByReturn (WriteReturns _ a _) = oneName a + consumedByReturn (WriteReturns _ _ a _) = oneName a consumedByReturn _ = mempty checkKernelBody :: @@ -352,18 +372,20 @@ ++ " values." zipWithM_ checkKernelResult kres ts where - consumeKernelResult (WriteReturns _ arr _) = + consumeKernelResult (WriteReturns _ _ arr _) = TC.consume =<< TC.lookupAliases arr consumeKernelResult _ = pure () - checkKernelResult (Returns _ what) t = + checkKernelResult (Returns _ cs what) t = do + TC.checkCerts cs TC.require [t] what - checkKernelResult (WriteReturns shape arr res) t = do + checkKernelResult (WriteReturns cs shape arr res) t = do + TC.checkCerts cs mapM_ (TC.require [Prim int64]) $ shapeDims shape arr_t <- lookupType arr forM_ res $ \(slice, e) -> do - mapM_ (traverse $ TC.require [Prim int64]) slice + traverse_ (TC.require [Prim int64]) slice TC.require [t] e unless (arr_t == t `arrayOfShape` shape) $ TC.bad $ @@ -376,7 +398,8 @@ ++ pretty shape ++ ", but destination array has type " ++ pretty arr_t - checkKernelResult (ConcatReturns o w per_thread_elems v) t = do + checkKernelResult (ConcatReturns cs o w per_thread_elems v) t = do + TC.checkCerts cs case o of SplitContiguous -> return () SplitStrided stride -> TC.require [Prim int64] stride @@ -385,14 +408,16 @@ vt <- lookupType v unless (vt == t `arrayOfRow` arraySize 0 vt) $ TC.bad $ TC.TypeError $ "Invalid type for ConcatReturns " ++ pretty v - checkKernelResult (TileReturns dims v) t = do + checkKernelResult (TileReturns cs dims v) t = do + TC.checkCerts cs forM_ dims $ \(dim, tile) -> do TC.require [Prim int64] dim TC.require [Prim int64] tile vt <- lookupType v unless (vt == t `arrayOfShape` Shape (map snd dims)) $ TC.bad $ TC.TypeError $ "Invalid type for TileReturns " ++ pretty v - checkKernelResult (RegTileReturns dims_n_tiles arr) t = do + checkKernelResult (RegTileReturns cs dims_n_tiles arr) t = do + TC.checkCerts cs mapM_ (TC.require [Prim int64]) dims mapM_ (TC.require [Prim int64]) blk_tiles mapM_ (TC.require [Prim int64]) reg_tiles @@ -417,31 +442,44 @@ PP.stack (map ppr (stmsToList stms)) text "return" <+> PP.braces (PP.commasep $ map ppr res) +certAnnots :: Certs -> [PP.Doc] +certAnnots cs + | cs == mempty = [] + | otherwise = [ppr cs] + instance Pretty KernelResult where - ppr (Returns ResultNoSimplify what) = - text "returns (manifest)" <+> ppr what - ppr (Returns ResultPrivate what) = - text "returns (private)" <+> ppr what - ppr (Returns ResultMaySimplify what) = - text "returns" <+> ppr what - ppr (WriteReturns shape arr res) = - ppr arr <+> PP.colon <+> ppr shape - text "with" <+> PP.apply (map ppRes res) + ppr (Returns ResultNoSimplify cs what) = + PP.spread $ certAnnots cs ++ ["returns (manifest)" <+> ppr what] + ppr (Returns ResultPrivate cs what) = + PP.spread $ certAnnots cs ++ ["returns (private)" <+> ppr what] + ppr (Returns ResultMaySimplify cs what) = + PP.spread $ certAnnots cs ++ ["returns" <+> ppr what] + ppr (WriteReturns cs shape arr res) = + PP.spread $ + certAnnots cs + ++ [ ppr arr <+> PP.colon <+> ppr shape + "with" <+> PP.apply (map ppRes res) + ] where - ppRes (slice, e) = - PP.brackets (commasep (map ppr slice)) <+> text "=" <+> ppr e - ppr (ConcatReturns SplitContiguous w per_thread_elems v) = - text "concat" - <> parens (commasep [ppr w, ppr per_thread_elems]) <+> ppr v - ppr (ConcatReturns (SplitStrided stride) w per_thread_elems v) = - text "concat_strided" - <> parens (commasep [ppr stride, ppr w, ppr per_thread_elems]) <+> ppr v - ppr (TileReturns dims v) = - "tile" <> parens (commasep $ map onDim dims) <+> ppr v + ppRes (slice, e) = ppr slice <+> text "=" <+> ppr e + ppr (ConcatReturns cs SplitContiguous w per_thread_elems v) = + PP.spread $ + certAnnots cs + ++ [ "concat" + <> parens (commasep [ppr w, ppr per_thread_elems]) <+> ppr v + ] + ppr (ConcatReturns cs (SplitStrided stride) w per_thread_elems v) = + PP.spread $ + certAnnots cs + ++ [ "concat_strided" + <> parens (commasep [ppr stride, ppr w, ppr per_thread_elems]) <+> ppr v + ] + ppr (TileReturns cs dims v) = + PP.spread $ certAnnots cs ++ ["tile" <> parens (commasep $ map onDim dims) <+> ppr v] where onDim (dim, tile) = ppr dim <+> "/" <+> ppr tile - ppr (RegTileReturns dims_n_tiles v) = - "blkreg_tile" <> parens (commasep $ map onDim dims_n_tiles) <+> ppr v + ppr (RegTileReturns cs dims_n_tiles v) = + PP.spread $ certAnnots cs ++ ["blkreg_tile" <> parens (commasep $ map onDim dims_n_tiles) <+> ppr v] where onDim (dim, blk_tile, reg_tile) = ppr dim <+> "/" <+> parens (ppr blk_tile <+> "*" <+> ppr reg_tile) @@ -529,15 +567,15 @@ SegHist _ _ _ _ body -> body segResultShape :: SegSpace -> Type -> KernelResult -> Type -segResultShape _ t (WriteReturns shape _ _) = +segResultShape _ t (WriteReturns _ shape _ _) = t `arrayOfShape` shape -segResultShape space t (Returns _ _) = +segResultShape space t Returns {} = foldr (flip arrayOfRow) t $ segSpaceDims space -segResultShape _ t (ConcatReturns _ w _ _) = +segResultShape _ t (ConcatReturns _ _ w _ _) = t `arrayOfRow` w -segResultShape _ t (TileReturns dims _) = +segResultShape _ t (TileReturns _ dims _) = t `arrayOfShape` Shape (map fst dims) -segResultShape _ t (RegTileReturns dims_n_tiles _) = +segResultShape _ t (RegTileReturns _ dims_n_tiles _) = t `arrayOfShape` Shape (map (\(dim, _, _) -> dim) dims_n_tiles) -- | The return type of a 'SegOp'. @@ -962,7 +1000,7 @@ instance ASTRep rep => ST.IndexOp (SegOp lvl rep) where indexOp vtable k (SegMap _ space _ kbody) is = do - Returns ResultMaySimplify se <- maybeNth k $ kernelBodyResult kbody + Returns ResultMaySimplify _ se <- maybeNth k $ kernelBodyResult kbody guard $ length gtids <= length is let idx_table = M.fromList $ zip gtids $ map (ST.Indexed mempty . untyped) is idx_table' = foldl' expandIndexedTable idx_table $ kernelBodyStms kbody @@ -976,11 +1014,11 @@ excess_is = drop (length gtids) is expandIndexedTable table stm - | [v] <- patternNames $ stmPattern stm, + | [v] <- patNames $ stmPat stm, Just (pe, cs) <- runWriterT $ primExpFromExp (asPrimExp table) $ stmExp stm = M.insert v (ST.Indexed (stmCerts stm <> cs) pe) table - | [v] <- patternNames $ stmPattern stm, + | [v] <- patNames $ stmPat stm, BasicOp (Index arr slice) <- stmExp stm, length (sliceDims slice) == length excess_is, arr `ST.elem` vtable, @@ -989,13 +1027,13 @@ ST.IndexedArray (stmCerts stm <> cs) arr - (fixSlice (map (fmap isInt64) slice') excess_is) + (fixSlice (fmap isInt64 slice') excess_is) in M.insert v idx table | otherwise = table asPrimExpSlice table = - runWriterT . mapM (traverse (primExpFromSubExpM (asPrimExp table))) + runWriterT . traverse (primExpFromSubExpM (asPrimExp table)) asPrimExp table v | Just (ST.Indexed cs e) <- M.lookup v table = tell cs >> return e @@ -1024,21 +1062,26 @@ SegSpace phys <$> mapM (traverse Engine.simplify) dims instance Engine.Simplifiable KernelResult where - simplify (Returns manifest what) = - Returns manifest <$> Engine.simplify what - simplify (WriteReturns ws a res) = - WriteReturns <$> Engine.simplify ws <*> Engine.simplify a <*> Engine.simplify res - simplify (ConcatReturns o w pte what) = + simplify (Returns manifest cs what) = + Returns manifest <$> Engine.simplify cs <*> Engine.simplify what + simplify (WriteReturns cs ws a res) = + WriteReturns <$> Engine.simplify cs + <*> Engine.simplify ws + <*> Engine.simplify a + <*> Engine.simplify res + simplify (ConcatReturns cs o w pte what) = ConcatReturns - <$> Engine.simplify o + <$> Engine.simplify cs + <*> Engine.simplify o <*> Engine.simplify w <*> Engine.simplify pte <*> Engine.simplify what - simplify (TileReturns dims what) = - TileReturns <$> Engine.simplify dims <*> Engine.simplify what - simplify (RegTileReturns dims_n_tiles what) = + simplify (TileReturns cs dims what) = + TileReturns <$> Engine.simplify cs <*> Engine.simplify dims <*> Engine.simplify what + simplify (RegTileReturns cs dims_n_tiles what) = RegTileReturns - <$> Engine.simplify dims_n_tiles + <$> Engine.simplify cs + <*> Engine.simplify dims_n_tiles <*> Engine.simplify what mkWiseKernelBody :: @@ -1048,18 +1091,18 @@ [KernelResult] -> KernelBody (Wise rep) mkWiseKernelBody dec bnds res = - let Body dec' _ _ = mkWiseBody dec bnds res_vs + let Body dec' _ _ = mkWiseBody dec bnds $ subExpsRes res_vs in KernelBody dec' bnds res where res_vs = map kernelResultSubExp res mkKernelBodyM :: - MonadBinder m => + MonadBuilder m => Stms (Rep m) -> [KernelResult] -> m (KernelBody (Rep m)) mkKernelBodyM stms kres = do - Body dec' _ _ <- mkBodyM stms res_ses + Body dec' _ _ <- mkBodyM stms $ subExpsRes res_ses return $ KernelBody dec' stms kres where res_ses = map kernelResultSubExp kres @@ -1095,7 +1138,7 @@ scope_vtable = segSpaceSymbolTable space bound_here = namesFromList $ M.keys $ scopeOfSegSpace space - consumedInResult (WriteReturns _ arr _) = + consumedInResult (WriteReturns _ _ arr _) = [arr] consumedInResult _ = [] @@ -1200,13 +1243,13 @@ -- | Simplification rules for simplifying 'SegOp's. segOpRules :: - (HasSegOp rep, BinderOps rep, Bindable rep) => + (HasSegOp rep, BuilderOps rep, Buildable rep) => RuleBook rep segOpRules = ruleBook [RuleOp segOpRuleTopDown] [RuleOp segOpRuleBottomUp] segOpRuleTopDown :: - (HasSegOp rep, BinderOps rep, Bindable rep) => + (HasSegOp rep, BuilderOps rep, Buildable rep) => TopDownRuleOp rep segOpRuleTopDown vtable pat dec op | Just op' <- asSegOp op = @@ -1215,7 +1258,7 @@ Skip segOpRuleBottomUp :: - (HasSegOp rep, BinderOps rep) => + (HasSegOp rep, BuilderOps rep) => BottomUpRuleOp rep segOpRuleBottomUp vtable pat dec op | Just op' <- asSegOp op = @@ -1224,35 +1267,31 @@ Skip topDownSegOp :: - (HasSegOp rep, BinderOps rep, Bindable rep) => + (HasSegOp rep, BuilderOps rep, Buildable rep) => ST.SymbolTable rep -> - Pattern rep -> + Pat rep -> StmAux (ExpDec rep) -> SegOp (SegOpLevel rep) rep -> Rule rep -- If a SegOp produces something invariant to the SegOp, turn it -- into a replicate. -topDownSegOp vtable (Pattern [] kpes) dec (SegMap lvl space ts (KernelBody _ kstms kres)) = Simplify $ do +topDownSegOp vtable (Pat kpes) dec (SegMap lvl space ts (KernelBody _ kstms kres)) = Simplify $ do (ts', kpes', kres') <- unzip3 <$> filterM checkForInvarianceResult (zip3 ts kpes kres) -- Check if we did anything at all. - when - (kres == kres') - cannotSimplify + when (kres == kres') cannotSimplify kbody <- mkKernelBodyM kstms kres' addStm $ - Let (Pattern [] kpes') dec $ - Op $ - segOp $ - SegMap lvl space ts' kbody + Let (Pat kpes') dec $ Op $ segOp $ SegMap lvl space ts' kbody where isInvariant Constant {} = True isInvariant (Var v) = isJust $ ST.lookup v vtable - checkForInvarianceResult (_, pe, Returns rm se) - | rm == ResultMaySimplify, + checkForInvarianceResult (_, pe, Returns rm cs se) + | cs == mempty, + rm == ResultMaySimplify, isInvariant se = do letBindNames [patElemName pe] $ BasicOp $ Replicate (Shape $ segSpaceDims space) se @@ -1263,7 +1302,7 @@ -- If a SegRed contains two reduction operations that have the same -- vector shape, merge them together. This saves on communication -- overhead, but can in principle lead to more local memory usage. -topDownSegOp _ (Pattern [] pes) _ (SegRed lvl space ops ts kbody) +topDownSegOp _ (Pat pes) _ (SegRed lvl space ops ts kbody) | length ops > 1, op_groupings <- groupBy sameShape $ @@ -1276,7 +1315,7 @@ pes' = red_pes' ++ map_pes ts' = red_ts' ++ map_ts kbody' = kbody {kernelBodyResult = red_res' ++ map_res} - letBind (Pattern [] pes') $ Op $ segOp $ SegRed lvl space ops' ts' kbody' + letBind (Pat pes') $ Op $ segOp $ SegRed lvl space ops' ts' kbody' where (red_pes, map_pes) = splitAt (segBinOpResults ops) pes (red_ts, map_ts) = splitAt (segBinOpResults ops) ts @@ -1334,15 +1373,15 @@ (kts, body, sum $ map (length . histDest) ops, SegHist lvl space ops) bottomUpSegOp :: - (HasSegOp rep, BinderOps rep) => + (HasSegOp rep, BuilderOps rep) => (ST.SymbolTable rep, UT.UsageTable) -> - Pattern rep -> + Pat rep -> StmAux (ExpDec rep) -> SegOp (SegOpLevel rep) rep -> Rule rep -- Some SegOp results can be moved outside the SegOp, which can -- simplify further analysis. -bottomUpSegOp (vtable, used) (Pattern [] kpes) dec segop = Simplify $ do +bottomUpSegOp (vtable, used) (Pat kpes) dec segop = Simplify $ do -- Iterate through the bindings. For each, we check whether it is -- in kres and can be moved outside. If so, we remove it from kres -- and kpes and make it a binding outside. We have to be careful @@ -1361,7 +1400,7 @@ localScope (scopeOfSegSpace space) $ mkKernelBodyM kstms' kres' - addStm $ Let (Pattern [] kpes') dec $ Op $ segOp $ mk_segop kts' kbody + addStm $ Let (Pat kpes') dec $ Op $ segOp $ mk_segop kts' kbody where (kts, KernelBody _ kstms kres, num_nonmap_results, mk_segop) = segOpGuts segop @@ -1371,8 +1410,8 @@ sliceWithGtidsFixed stm | Let _ _ (BasicOp (Index arr slice)) <- stm, space_slice <- map (DimFix . Var . fst) $ unSegSpace space, - space_slice `isPrefixOf` slice, - remaining_slice <- drop (length space_slice) slice, + 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 = @@ -1381,8 +1420,8 @@ Nothing distribute (kpes', kts', kres', kstms') stm - | Let (Pattern [] [pe]) _ _ <- stm, - Just (remaining_slice, arr) <- sliceWithGtidsFixed stm, + | Let (Pat [pe]) _ _ <- stm, + Just (Slice remaining_slice, arr) <- sliceWithGtidsFixed stm, Just (kpe, kpes'', kts'', kres'') <- isResult kpes' kts' kres' pe = do let outer_slice = map @@ -1395,7 +1434,7 @@ $ segSpaceDims space index kpe' = letBindNames [patElemName kpe'] . BasicOp . Index arr $ - outer_slice <> remaining_slice + Slice $ outer_slice <> remaining_slice if patElemName kpe `UT.isConsumed` used then do precopy <- newVName $ baseString (patElemName kpe) <> "_precopy" @@ -1422,26 +1461,25 @@ Just (kpe, kpes'', kts'', kres'') _ -> Nothing where - matches (_, _, Returns _ (Var v)) = v == patElemName pe + matches (_, _, Returns _ _ (Var v)) = v == patElemName pe matches _ = False -bottomUpSegOp _ _ _ _ = Skip --- Memory kernelBodyReturns :: - (Mem rep, HasScope rep m, Monad m) => - KernelBody rep -> + (Mem rep inner, HasScope rep m, Monad m) => + KernelBody somerep -> [ExpReturns] -> m [ExpReturns] kernelBodyReturns = zipWithM correct . kernelBodyResult where - correct (WriteReturns _ arr _) _ = varReturns arr + correct (WriteReturns _ _ arr _) _ = varReturns arr correct _ ret = return ret -- | Like 'segOpType', but for memory representations. segOpReturns :: - (Mem rep, Monad m, HasScope rep m) => - SegOp lvl rep -> + (Mem rep inner, Monad m, HasScope rep m) => + SegOp lvl somerep -> m [ExpReturns] segOpReturns k@(SegMap _ _ _ kbody) = kernelBodyReturns kbody . extReturns =<< opType k diff --git a/src/Futhark/IR/Seq.hs b/src/Futhark/IR/Seq.hs --- a/src/Futhark/IR/Seq.hs +++ b/src/Futhark/IR/Seq.hs @@ -16,7 +16,7 @@ ) where -import Futhark.Binder +import Futhark.Builder import Futhark.Construct import Futhark.IR.Pretty import Futhark.IR.Prop @@ -35,24 +35,24 @@ type Op Seq = () instance ASTRep Seq where - expTypesFromPattern = return . expExtTypesFromPattern + expTypesFromPat = return . expExtTypesFromPat instance TypeCheck.CheckableOp Seq where checkOp = pure instance TypeCheck.Checkable Seq -instance Bindable Seq where +instance Buildable Seq where mkBody = Body () - mkExpPat ctx val _ = basicPattern ctx val + mkExpPat idents _ = basicPat idents mkExpDec _ _ = () mkLetNames = simpleMkLetNames -instance BinderOps Seq +instance BuilderOps Seq instance PrettyRep Seq -instance BinderOps (Engine.Wise Seq) +instance BuilderOps (Engine.Wise Seq) simpleSeq :: Simplify.SimpleOps Seq simpleSeq = Simplify.bindableSimpleOps (const $ pure ((), mempty)) diff --git a/src/Futhark/IR/SeqMem.hs b/src/Futhark/IR/SeqMem.hs --- a/src/Futhark/IR/SeqMem.hs +++ b/src/Futhark/IR/SeqMem.hs @@ -21,7 +21,7 @@ import Futhark.IR.Mem.Simplify import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Pass -import Futhark.Pass.ExplicitAllocations (BinderOps (..), mkLetNamesB', mkLetNamesB'') +import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'') import qualified Futhark.TypeCheck as TC data SeqMem @@ -35,11 +35,7 @@ type Op SeqMem = MemOp () instance ASTRep SeqMem where - expTypesFromPattern = return . map snd . snd . bodyReturnsFromPattern - -instance OpReturns SeqMem where - opReturns (Alloc _ space) = return [MemMem space] - opReturns (Inner ()) = pure [] + expTypesFromPat = return . map snd . bodyReturnsFromPat instance PrettyRep SeqMem @@ -55,17 +51,17 @@ checkLetBoundDec = checkMemInfo checkRetType = mapM_ (TC.checkExtType . declExtTypeOf) primFParam name t = return $ Param name (MemPrim t) - matchPattern = matchPatternToExp + matchPat = matchPatToExp matchReturnType = matchFunctionReturnType matchBranchType = matchBranchReturnType matchLoopResult = matchLoopResultMem -instance BinderOps SeqMem where +instance BuilderOps SeqMem where mkExpDecB _ _ = return () mkBodyB stms res = return $ Body () stms res mkLetNamesB = mkLetNamesB' () -instance BinderOps (Engine.Wise SeqMem) where +instance BuilderOps (Engine.Wise SeqMem) where mkExpDecB pat e = return $ Engine.mkWiseExpDec pat () e mkBodyB stms res = return $ Engine.mkWiseBody () stms res mkLetNamesB = mkLetNamesB'' 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 @@ -56,10 +56,8 @@ -- t'Body' consists of executing all of the statements, then returning -- the values of the variables indicated by the result. -- --- A statement ('Stm') consists of a t'Pattern' alongside an --- expression 'ExpT'. A pattern contains a "context" part and a --- "value" part. The context is used for things like the size of --- arrays in the value part whose size is existential. +-- A statement ('Stm') consists of a t'Pat' alongside an +-- expression 'ExpT'. A pattern is a sequence of name/type pairs. -- -- For example, the source language expression @let z = x + y - 1 in -- z@ would in the core language be represented (in prettyprinted @@ -125,11 +123,12 @@ SubExp (..), PatElem, PatElemT (..), - PatternT (..), - Pattern, + PatT (..), + Pat, StmAux (..), Stm (..), Stms, + SubExpRes (..), Result, BodyT (..), Body, @@ -138,6 +137,7 @@ BinOp (..), CmpOp (..), ConvOp (..), + OpaqueOp (..), DimChange (..), ShapeChange, ExpT (..), @@ -163,6 +163,10 @@ stmsFromList, stmsToList, stmsHead, + subExpRes, + subExpsRes, + varRes, + varsRes, ) where @@ -208,36 +212,31 @@ type PatElem rep = PatElemT (LetDec rep) -- | A pattern is conceptually just a list of names and their types. -data PatternT dec = Pattern - { -- | existential context (sizes and memory blocks) - patternContextElements :: [PatElemT dec], - -- | "real" values - patternValueElements :: [PatElemT dec] - } +newtype PatT dec = Pat {patElems :: [PatElemT dec]} deriving (Ord, Show, Eq) -instance Semigroup (PatternT dec) where - Pattern cs1 vs1 <> Pattern cs2 vs2 = Pattern (cs1 ++ cs2) (vs1 ++ vs2) +instance Semigroup (PatT dec) where + Pat xs <> Pat ys = Pat (xs <> ys) -instance Monoid (PatternT dec) where - mempty = Pattern [] [] +instance Monoid (PatT dec) where + mempty = Pat mempty -instance Functor PatternT where +instance Functor PatT where fmap = fmapDefault -instance Foldable PatternT where +instance Foldable PatT where foldMap = foldMapDefault -instance Traversable PatternT where - traverse f (Pattern ctx vals) = - Pattern <$> traverse (traverse f) ctx <*> traverse (traverse f) vals +instance Traversable PatT where + traverse f (Pat xs) = + Pat <$> traverse (traverse f) xs -- | A type alias for namespace control. -type Pattern rep = PatternT (LetDec rep) +type Pat rep = PatT (LetDec rep) -- | Auxilliary Information associated with a statement. data StmAux dec = StmAux - { stmAuxCerts :: !Certificates, + { stmAuxCerts :: !Certs, stmAuxAttrs :: Attrs, stmAuxDec :: dec } @@ -249,8 +248,8 @@ -- | A local variable binding. data Stm rep = Let - { -- | Pattern. - stmPattern :: Pattern rep, + { -- | Pat. + stmPat :: Pat rep, -- | Auxiliary information statement. stmAux :: StmAux (ExpDec rep), -- | Expression. @@ -284,8 +283,31 @@ stm Seq.:< stms' -> Just (stm, stms') Seq.EmptyL -> Nothing +-- | A pairing of a subexpression and some certificates. +data SubExpRes = SubExpRes + { resCerts :: Certs, + resSubExp :: SubExp + } + deriving (Eq, Ord, Show) + +-- | Construct a 'SubExpRes' with no certificates. +subExpRes :: SubExp -> SubExpRes +subExpRes = SubExpRes mempty + +-- | Construct a 'SubExpRes' from a variable name. +varRes :: VName -> SubExpRes +varRes = subExpRes . Var + +-- | Construct a 'Result' from subexpressions. +subExpsRes :: [SubExp] -> Result +subExpsRes = map subExpRes + +-- | Construct a 'Result' from variable names. +varsRes :: [VName] -> Result +varsRes = map varRes + -- | The result of a body is a sequence of subexpressions. -type Result = [SubExp] +type Result = [SubExpRes] -- | A body consists of a number of bindings, terminating in a result -- (essentially a tuple literal). @@ -338,16 +360,26 @@ -- | A list of 'DimChange's, indicating the new dimensions of an array. type ShapeChange d = [DimChange d] +-- | Apart from being Opaque, what else is going on here? +data OpaqueOp + = -- | No special operation. + OpaqueNil + | -- | Print the argument, prefixed by this string. + OpaqueTrace String + deriving (Eq, Ord, Show) + -- | A primitive operation that returns something of known size and -- does not itself contain any bindings. data BasicOp = -- | A variable or constant. SubExp SubExp | -- | Semantically and operationally just identity, but is - -- invisible/impenetrable to optimisations (hopefully). This is - -- just a hack to avoid optimisation (so, to work around compiler - -- limitations). - Opaque SubExp + -- invisible/impenetrable to optimisations (hopefully). This + -- partially a hack to avoid optimisation (so, to work around + -- compiler limitations), but is also used to implement tracing + -- and other operations that are semantically invisible, but have + -- some sort of effect (brrr). + Opaque OpaqueOp SubExp | -- | Array literals, e.g., @[ [1+x, 3], [2, 1+4] ]@. -- Second arg is the element type of the rows of the array. ArrayLit [SubExp] Type @@ -367,8 +399,11 @@ -- | The certificates for bounds-checking are part of the 'Stm'. Index VName (Slice SubExp) | -- | An in-place update of the given array at the given position. - -- Consumes the array. - Update VName (Slice SubExp) SubExp + -- Consumes the array. If 'Safe', perform a run-time bounds check + -- and ignore the write if out of bounds (like @Scatter@). + Update Safety VName (Slice SubExp) SubExp + | FlatIndex VName (FlatSlice SubExp) + | FlatUpdate VName (FlatSlice SubExp) VName | -- | @concat@0([1],[2, 3, 4]) = [1, 2, 3, 4]@. Concat Int VName [VName] SubExp | -- | Copy the given array. The result will not alias anything. @@ -413,15 +448,14 @@ BasicOp BasicOp | Apply Name [(SubExp, Diet)] [RetType rep] (Safety, SrcLoc, [SrcLoc]) | If SubExp (BodyT rep) (BodyT rep) (IfDec (BranchType rep)) - | -- | @loop {a} = {v} (for i < n|while b) do b@. The merge - -- parameters are divided into context and value part. - DoLoop [(FParam rep, SubExp)] [(FParam rep, SubExp)] (LoopForm rep) (BodyT rep) + | -- | @loop {a} = {v} (for i < n|while b) do b@. + DoLoop [(FParam rep, SubExp)] (LoopForm rep) (BodyT 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 - -- accumulators are turned back into arrays. The 'Shape' is the + -- accumulators are turned back into arrays. The t'Shape' is the -- write index space. The corresponding arrays must all have this - -- shape outermost. This construct is not part of 'BasicOp' + -- shape outermost. This construct is not part of t'BasicOp' -- because we need the @rep@ parameter. WithAcc [(Shape, [VName], Maybe (Lambda rep, [SubExp]))] (Lambda rep) | Op (Op rep) 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 @@ -40,11 +40,11 @@ -- * Abstract syntax tree Ident (..), - Certificates (..), + Certs (..), SubExp (..), Param (..), DimIndex (..), - Slice, + Slice (..), dimFix, sliceIndices, sliceDims, @@ -52,6 +52,12 @@ fixSlice, sliceSlice, PatElemT (..), + + -- * Flat (LMAD) slices + FlatSlice (..), + FlatDimIndex (..), + flatSliceDims, + flatSliceStrides, ) where @@ -281,14 +287,14 @@ x `compare` y = identName x `compare` identName y -- | A list of names used for certificates in some expressions. -newtype Certificates = Certificates {unCertificates :: [VName]} +newtype Certs = Certs {unCerts :: [VName]} deriving (Eq, Ord, Show) -instance Semigroup Certificates where - Certificates x <> Certificates y = Certificates (x <> y) +instance Semigroup Certs where + Certs x <> Certs y = Certs (x <> y) -instance Monoid Certificates where - mempty = Certificates mempty +instance Monoid Certs where + mempty = Certs mempty -- | A subexpression is either a scalar constant or a variable. One -- important property is that evaluation of a subexpression is @@ -336,12 +342,22 @@ traverse f (DimFix d) = DimFix <$> f d traverse f (DimSlice i j s) = DimSlice <$> f i <*> f j <*> f s --- | A list of 'DimFix's, indicating how an array should be sliced. +-- | A list of 'DimIndex's, indicating how an array should be sliced. -- Whenever a function accepts a 'Slice', that slice should be total, -- i.e, cover all dimensions of the array. Deviators should be -- indicated by taking a list of 'DimIndex'es instead. -type Slice d = [DimIndex d] +newtype Slice d = Slice {unSlice :: [DimIndex d]} + deriving (Eq, Ord, Show) +instance Traversable Slice where + traverse f = fmap Slice . traverse (traverse f) . unSlice + +instance Functor Slice where + fmap = fmapDefault + +instance Foldable Slice where + foldMap = foldMapDefault + -- | If the argument is a 'DimFix', return its component. dimFix :: DimIndex d -> Maybe d dimFix (DimFix d) = Just d @@ -349,11 +365,11 @@ -- | If the slice is all 'DimFix's, return the components. sliceIndices :: Slice d -> Maybe [d] -sliceIndices = mapM dimFix +sliceIndices = mapM dimFix . unSlice -- | The dimensions of the array produced by this slice. sliceDims :: Slice d -> [d] -sliceDims = mapMaybe dimSlice +sliceDims = mapMaybe dimSlice . unSlice where dimSlice (DimSlice _ d _) = Just d dimSlice DimFix {} = Nothing @@ -365,30 +381,74 @@ -- | 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 (DimFix j : mis') is' = - j : fixSlice mis' is' -fixSlice (DimSlice orig_k _ orig_s : mis') (i : is') = - (orig_k + i * orig_s) : fixSlice mis' is' -fixSlice _ _ = [] +fixSlice = fixSlice' . unSlice + where + fixSlice' (DimFix j : mis') is' = + j : fixSlice' mis' is' + fixSlice' (DimSlice orig_k _ orig_s : mis') (i : is') = + (orig_k + i * orig_s) : fixSlice' mis' is' + fixSlice' _ _ = [] -- | 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 (DimFix j : js') is' = - DimFix j : sliceSlice js' is' -sliceSlice (DimSlice j _ s : js') (DimFix i : is') = - DimFix (j + (i * s)) : sliceSlice js' is' -sliceSlice (DimSlice j _ s0 : js') (DimSlice i n s1 : is') = - DimSlice (j + (s0 * i)) n (s0 * s1) : sliceSlice js' is' -sliceSlice _ _ = [] +sliceSlice (Slice jslice) (Slice islice) = Slice $ sliceSlice' jslice islice + where + sliceSlice' (DimFix j : js') is' = + DimFix j : sliceSlice' js' is' + sliceSlice' (DimSlice j _ s : js') (DimFix i : is') = + DimFix (j + (i * s)) : sliceSlice' js' is' + sliceSlice' (DimSlice j _ s0 : js') (DimSlice i n s1 : is') = + DimSlice (j + (s0 * i)) n (s0 * s1) : sliceSlice' js' is' + sliceSlice' _ _ = [] +data FlatDimIndex d + = FlatDimIndex + d + -- ^ Number of elements in dimension + d + -- ^ Stride of dimension + deriving (Eq, Ord, Show) + +instance Traversable FlatDimIndex where + traverse f (FlatDimIndex n s) = FlatDimIndex <$> f n <*> f s + +instance Functor FlatDimIndex where + fmap = fmapDefault + +instance Foldable FlatDimIndex where + foldMap = foldMapDefault + +data FlatSlice d = FlatSlice d [FlatDimIndex d] + deriving (Eq, Ord, Show) + +instance Traversable FlatSlice where + traverse f (FlatSlice offset is) = + FlatSlice <$> f offset <*> traverse (traverse f) is + +instance Functor FlatSlice where + fmap = fmapDefault + +instance Foldable FlatSlice where + foldMap = foldMapDefault + +flatSliceDims :: FlatSlice d -> [d] +flatSliceDims (FlatSlice _ ds) = map dimSlice ds + where + dimSlice (FlatDimIndex n _) = n + +flatSliceStrides :: FlatSlice d -> [d] +flatSliceStrides (FlatSlice _ ds) = map dimStride ds + where + dimStride (FlatDimIndex _ s) = s + -- | An element of a pattern - consisting of a name and an addditional -- parametric decoration. This decoration is what is expected to -- contain the type of the resulting variable. data PatElemT dec = PatElem { -- | The name being bound. patElemName :: VName, - -- | Pattern element decoration. + -- | Pat element decoration. patElemDec :: dec } deriving (Ord, Show, Eq) @@ -415,10 +475,8 @@ data ErrorMsgPart a = -- | A literal string. ErrorString String - | -- | A run-time integer value. - ErrorInt32 a - | -- | A bigger run-time integer value. - ErrorInt64 a + | -- | A run-time value. + ErrorVal PrimType a deriving (Eq, Ord, Show) instance IsString (ErrorMsgPart a) where @@ -434,19 +492,14 @@ traverse f (ErrorMsg parts) = ErrorMsg <$> traverse (traverse f) parts instance Functor ErrorMsgPart where - fmap _ (ErrorString s) = ErrorString s - fmap f (ErrorInt32 a) = ErrorInt32 $ f a - fmap f (ErrorInt64 a) = ErrorInt64 $ f a + fmap = fmapDefault instance Foldable ErrorMsgPart where - foldMap _ ErrorString {} = mempty - foldMap f (ErrorInt32 a) = f a - foldMap f (ErrorInt64 a) = f a + foldMap = foldMapDefault instance Traversable ErrorMsgPart where traverse _ (ErrorString s) = pure $ ErrorString s - traverse f (ErrorInt32 a) = ErrorInt32 <$> f a - traverse f (ErrorInt64 a) = ErrorInt64 <$> f a + traverse f (ErrorVal t a) = ErrorVal t <$> f a -- | How many non-constant parts does the error message have, and what -- is their type? @@ -454,5 +507,4 @@ errorMsgArgTypes (ErrorMsg parts) = mapMaybe onPart parts where onPart ErrorString {} = Nothing - onPart ErrorInt32 {} = Just $ IntType Int32 - onPart ErrorInt64 {} = Just $ IntType Int64 + onPart (ErrorVal t _) = Just t 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 @@ -106,14 +106,25 @@ mapExpM tv (BasicOp (Index arr slice)) = BasicOp <$> ( Index <$> mapOnVName tv arr - <*> mapM (traverse (mapOnSubExp tv)) slice + <*> traverse (mapOnSubExp tv) slice ) -mapExpM tv (BasicOp (Update arr slice se)) = +mapExpM tv (BasicOp (Update safety arr slice se)) = BasicOp - <$> ( Update <$> mapOnVName tv arr - <*> mapM (traverse (mapOnSubExp tv)) slice + <$> ( Update safety <$> mapOnVName tv arr + <*> traverse (mapOnSubExp tv) slice <*> mapOnSubExp tv se ) +mapExpM tv (BasicOp (FlatIndex arr slice)) = + BasicOp + <$> ( FlatIndex <$> mapOnVName tv arr + <*> traverse (mapOnSubExp tv) slice + ) +mapExpM tv (BasicOp (FlatUpdate arr slice se)) = + BasicOp + <$> ( FlatUpdate <$> mapOnVName tv arr + <*> traverse (mapOnSubExp tv) slice + <*> mapOnVName tv se + ) mapExpM tv (BasicOp (Iota n x s et)) = BasicOp <$> (Iota <$> mapOnSubExp tv n <*> mapOnSubExp tv x <*> mapOnSubExp tv s <*> pure et) mapExpM tv (BasicOp (Replicate shape vexp)) = @@ -143,8 +154,8 @@ BasicOp <$> (Manifest perm <$> mapOnVName tv e) mapExpM tv (BasicOp (Assert e msg loc)) = BasicOp <$> (Assert <$> mapOnSubExp tv e <*> traverse (mapOnSubExp tv) msg <*> pure loc) -mapExpM tv (BasicOp (Opaque e)) = - BasicOp <$> (Opaque <$> mapOnSubExp tv e) +mapExpM tv (BasicOp (Opaque op e)) = + BasicOp <$> (Opaque op <$> mapOnSubExp tv e) mapExpM tv (BasicOp (UpdateAcc v is ses)) = BasicOp <$> ( UpdateAcc @@ -158,19 +169,16 @@ onInput (shape, vs, op) = (,,) <$> mapOnShape tv shape <*> mapM (mapOnVName tv) vs <*> traverse (bitraverse (mapOnLambda tv) (mapM (mapOnSubExp tv))) op -mapExpM tv (DoLoop ctxmerge valmerge form loopbody) = do - ctxparams' <- mapM (mapOnFParam tv) ctxparams - valparams' <- mapM (mapOnFParam tv) valparams +mapExpM tv (DoLoop merge form loopbody) = do + params' <- mapM (mapOnFParam tv) params form' <- mapOnLoopForm tv form - let scope = scopeOf form' <> scopeOfFParams (ctxparams' ++ valparams') + let scope = scopeOf form' <> scopeOfFParams params' DoLoop - <$> (zip ctxparams' <$> mapM (mapOnSubExp tv) ctxinits) - <*> (zip valparams' <$> mapM (mapOnSubExp tv) valinits) + <$> (zip params' <$> mapM (mapOnSubExp tv) args) <*> pure form' <*> mapOnBody tv scope loopbody where - (ctxparams, ctxinits) = unzip ctxmerge - (valparams, valinits) = unzip valmerge + (params, args) = unzip merge mapExpM tv (Op op) = Op <$> mapOnOp tv op @@ -283,11 +291,17 @@ walkExpM tv (Apply _ args ret _) = mapM_ (walkOnSubExp tv . fst) args >> mapM_ (walkOnRetType tv) ret walkExpM tv (BasicOp (Index arr slice)) = - walkOnVName tv arr >> mapM_ (traverse_ (walkOnSubExp tv)) slice -walkExpM tv (BasicOp (Update arr slice se)) = + walkOnVName tv arr >> traverse_ (walkOnSubExp tv) slice +walkExpM tv (BasicOp (Update _ arr slice se)) = walkOnVName tv arr - >> mapM_ (traverse_ (walkOnSubExp tv)) slice + >> traverse_ (walkOnSubExp tv) slice >> walkOnSubExp tv se +walkExpM tv (BasicOp (FlatIndex arr slice)) = + walkOnVName tv arr >> traverse_ (walkOnSubExp tv) slice +walkExpM tv (BasicOp (FlatUpdate arr slice se)) = + walkOnVName tv arr + >> traverse_ (walkOnSubExp tv) slice + >> walkOnVName tv se walkExpM tv (BasicOp (Iota n x s _)) = walkOnSubExp tv n >> walkOnSubExp tv x >> walkOnSubExp tv s walkExpM tv (BasicOp (Replicate shape vexp)) = @@ -308,7 +322,7 @@ walkOnVName tv e walkExpM tv (BasicOp (Assert e msg _)) = walkOnSubExp tv e >> traverse_ (walkOnSubExp tv) msg -walkExpM tv (BasicOp (Opaque e)) = +walkExpM tv (BasicOp (Opaque _ e)) = walkOnSubExp tv e walkExpM tv (BasicOp (UpdateAcc v is ses)) = do walkOnVName tv v @@ -320,16 +334,13 @@ mapM_ (walkOnVName tv) vs traverse_ (bitraverse (walkOnLambda tv) (mapM (walkOnSubExp tv))) op walkOnLambda tv lam -walkExpM tv (DoLoop ctxmerge valmerge form loopbody) = do - mapM_ (walkOnFParam tv) ctxparams - mapM_ (walkOnFParam tv) valparams +walkExpM tv (DoLoop merge form loopbody) = do + mapM_ (walkOnFParam tv) params walkOnLoopForm tv form - mapM_ (walkOnSubExp tv) ctxinits - mapM_ (walkOnSubExp tv) valinits - let scope = scopeOfFParams (ctxparams ++ valparams) <> scopeOf form + mapM_ (walkOnSubExp tv) args + let scope = scopeOfFParams params <> scopeOf form walkOnBody tv scope loopbody where - (ctxparams, ctxinits) = unzip ctxmerge - (valparams, valinits) = unzip valmerge + (params, args) = unzip merge walkExpM tv (Op op) = walkOnOp tv op diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -9,7 +9,7 @@ import qualified Data.Text as T import Futhark.Compiler.Config -import Futhark.IR.SOACS as I hiding (stmPattern) +import Futhark.IR.SOACS as I hiding (stmPat) import Futhark.Internalise.Defunctionalise as Defunctionalise import Futhark.Internalise.Defunctorise as Defunctorise import qualified Futhark.Internalise.Exps as Exps diff --git a/src/Futhark/Internalise/AccurateSizes.hs b/src/Futhark/Internalise/AccurateSizes.hs --- a/src/Futhark/Internalise/AccurateSizes.hs +++ b/src/Futhark/Internalise/AccurateSizes.hs @@ -75,9 +75,9 @@ InternaliseM Result ensureResultExtShape msg loc rettype res = do res' <- ensureResultExtShapeNoCtx msg loc rettype res - ts <- mapM subExpType res' + ts <- mapM subExpResType res' let ctx = extractShapeContext rettype $ map arrayDims ts - pure $ ctx ++ res' + pure $ subExpsRes ctx ++ res' ensureResultExtShapeNoCtx :: ErrorMsg SubExp -> @@ -86,12 +86,12 @@ Result -> InternaliseM Result ensureResultExtShapeNoCtx msg loc rettype es = do - es_ts <- mapM subExpType es + es_ts <- mapM subExpResType es let ext_mapping = shapeExtMapping rettype es_ts rettype' = foldr (uncurry fixExt) rettype $ M.toList ext_mapping - assertProperShape t se = + assertProperShape t (SubExpRes cs se) = let name = "result_proper_shape" - in ensureExtShape msg loc t name se + in SubExpRes cs <$> ensureExtShape msg loc t name se zipWithM assertProperShape rettype' es ensureExtShape :: 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 @@ -6,7 +6,7 @@ ( bindingFParams, bindingLoopParams, bindingLambdaParams, - stmPattern, + stmPat, ) where @@ -21,11 +21,11 @@ bindingFParams :: [E.TypeParam] -> - [E.Pattern] -> + [E.Pat] -> ([I.FParam] -> [[I.FParam]] -> InternaliseM a) -> InternaliseM a bindingFParams tparams params m = do - flattened_params <- mapM flattenPattern params + flattened_params <- mapM flattenPat params let params_idents = concat flattened_params params_ts <- internaliseParamTypes $ @@ -35,7 +35,7 @@ let shape_params = [I.Param v $ I.Prim I.int64 | E.TypeParamDim v _ <- tparams] shape_subst = M.fromList [(I.paramName p, [I.Var $ I.paramName p]) | p <- shape_params] - bindingFlatPattern params_idents (concat params_ts) $ \valueparams -> do + bindingFlatPat params_idents (concat params_ts) $ \valueparams -> do let (certparams, valueparams') = unzip $ map fixAccParam (concat valueparams) I.localScope (I.scopeOfFParams $ catMaybes certparams ++ shape_params ++ valueparams') $ substitutingVars shape_subst $ @@ -49,45 +49,45 @@ bindingLoopParams :: [E.TypeParam] -> - E.Pattern -> + E.Pat -> [I.Type] -> ([I.FParam] -> [I.FParam] -> InternaliseM a) -> InternaliseM a bindingLoopParams tparams pat ts m = do - pat_idents <- flattenPattern pat + pat_idents <- flattenPat pat pat_ts <- internaliseLoopParamType (E.patternStructType pat) ts let shape_params = [I.Param v $ I.Prim I.int64 | E.TypeParamDim v _ <- tparams] shape_subst = M.fromList [(I.paramName p, [I.Var $ I.paramName p]) | p <- shape_params] - bindingFlatPattern pat_idents pat_ts $ \valueparams -> + bindingFlatPat pat_idents pat_ts $ \valueparams -> I.localScope (I.scopeOfFParams $ shape_params ++ concat valueparams) $ substitutingVars shape_subst $ m shape_params $ concat valueparams bindingLambdaParams :: - [E.Pattern] -> + [E.Pat] -> [I.Type] -> ([I.LParam] -> InternaliseM a) -> InternaliseM a bindingLambdaParams params ts m = do - params_idents <- concat <$> mapM flattenPattern params + params_idents <- concat <$> mapM flattenPat params - bindingFlatPattern params_idents ts $ \params' -> + bindingFlatPat params_idents ts $ \params' -> I.localScope (I.scopeOfLParams $ concat params') $ m $ concat params' -processFlatPattern :: +processFlatPat :: Show t => [E.Ident] -> [t] -> - InternaliseM ([[I.Param t]], VarSubstitutions) -processFlatPattern x y = processFlatPattern' [] x y + InternaliseM ([[I.Param t]], VarSubsts) +processFlatPat x y = processFlatPat' [] x y where - processFlatPattern' pat [] _ = do + processFlatPat' pat [] _ = do let (vs, substs) = unzip pat return (reverse vs, M.fromList substs) - processFlatPattern' pat (p : rest) ts = do + processFlatPat' pat (p : rest) ts = do (ps, rest_ts) <- handleMapping ts <$> internaliseBindee p - processFlatPattern' ((ps, (E.identName p, map (I.Var . I.paramName) ps)) : pat) rest rest_ts + processFlatPat' ((ps, (E.identName p, map (I.Var . I.paramName) ps)) : pat) rest rest_ts handleMapping ts [] = ([], ts) @@ -105,49 +105,49 @@ 1 -> return [name] _ -> replicateM n $ newVName $ baseString name -bindingFlatPattern :: +bindingFlatPat :: Show t => [E.Ident] -> [t] -> ([[I.Param t]] -> InternaliseM a) -> InternaliseM a -bindingFlatPattern idents ts m = do - (ps, substs) <- processFlatPattern idents ts +bindingFlatPat idents ts m = do + (ps, substs) <- processFlatPat idents ts local (\env -> env {envSubsts = substs `M.union` envSubsts env}) $ m ps -- | Flatten a pattern. Returns a list of identifiers. -flattenPattern :: MonadFreshNames m => E.Pattern -> m [E.Ident] -flattenPattern = flattenPattern' +flattenPat :: MonadFreshNames m => E.Pat -> m [E.Ident] +flattenPat = flattenPat' where - flattenPattern' (E.PatternParens p _) = - flattenPattern' p - flattenPattern' (E.Wildcard t loc) = do + flattenPat' (E.PatParens p _) = + flattenPat' p + flattenPat' (E.Wildcard t loc) = do name <- newVName "nameless" - flattenPattern' $ E.Id name t loc - flattenPattern' (E.Id v (Info t) loc) = + flattenPat' $ E.Id name t loc + flattenPat' (E.Id v (Info t) loc) = return [E.Ident v (Info t) loc] -- XXX: treat empty tuples and records as unit. - flattenPattern' (E.TuplePattern [] loc) = - flattenPattern' (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc) - flattenPattern' (E.RecordPattern [] loc) = - flattenPattern' (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc) - flattenPattern' (E.TuplePattern pats _) = - concat <$> mapM flattenPattern' pats - flattenPattern' (E.RecordPattern fs loc) = - flattenPattern' $ E.TuplePattern (map snd $ sortFields $ M.fromList fs) loc - flattenPattern' (E.PatternAscription p _ _) = - flattenPattern' p - flattenPattern' (E.PatternLit _ t loc) = - flattenPattern' $ E.Wildcard t loc - flattenPattern' (E.PatternConstr _ _ ps _) = - concat <$> mapM flattenPattern' ps + flattenPat' (E.TuplePat [] loc) = + flattenPat' (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc) + flattenPat' (E.RecordPat [] loc) = + flattenPat' (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc) + flattenPat' (E.TuplePat pats _) = + concat <$> mapM flattenPat' pats + flattenPat' (E.RecordPat fs loc) = + flattenPat' $ E.TuplePat (map snd $ sortFields $ M.fromList fs) loc + flattenPat' (E.PatAscription p _ _) = + flattenPat' p + flattenPat' (E.PatLit _ t loc) = + flattenPat' $ E.Wildcard t loc + flattenPat' (E.PatConstr _ _ ps _) = + concat <$> mapM flattenPat' ps -stmPattern :: - E.Pattern -> +stmPat :: + E.Pat -> [I.Type] -> ([VName] -> InternaliseM a) -> InternaliseM a -stmPattern pat ts m = do - pat' <- flattenPattern pat - bindingFlatPattern pat' ts $ m . map I.paramName . concat +stmPat pat ts m = do + pat' <- flattenPat pat + bindingFlatPat pat' ts $ m . map I.paramName . concat 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 @@ -27,19 +27,19 @@ -- | An expression or an extended 'Lambda' (with size parameters, -- which AST lambdas do not support). data ExtExp - = ExtLambda [Pattern] Exp StructType SrcLoc + = ExtLambda [Pat] Exp StructType SrcLoc | ExtExp Exp deriving (Show) -- | A static value stores additional information about the result of -- defunctionalization of an expression, aside from the residual expression. data StaticVal - = Dynamic PatternType - | LambdaSV Pattern StructType ExtExp Env + = Dynamic PatType + | LambdaSV Pat StructType ExtExp Env | RecordSV [(Name, StaticVal)] | -- | The constructor that is actually present, plus -- the others that are not. - SumSV Name [StaticVal] [(Name, [PatternType])] + SumSV Name [StaticVal] [(Name, [PatType])] | -- | The pair is the StaticVal and residual expression of this -- function as a whole, while the second StaticVal is its -- body. (Don't trust this too much, my understanding may have @@ -120,7 +120,7 @@ where tv substs = identityMapper - { mapOnPatternType = pure . replaceTypeSizes substs, + { mapOnPatType = pure . replaceTypeSizes substs, mapOnStructType = pure . replaceTypeSizes substs, mapOnExp = pure . onExp substs, mapOnName = pure . onName substs @@ -290,7 +290,7 @@ dimName (NamedDim qn) = S.singleton $ qualLeaf qn dimName _ = mempty -patternArraySizes :: Pattern -> S.Set VName +patternArraySizes :: Pat -> S.Set VName patternArraySizes = arraySizes . patternStructType data SizeSubst @@ -336,7 +336,7 @@ foldMap sizesToRename svs sizesToRename (LambdaSV param _ _ _) = patternDimNames param - <> S.map identName (S.filter couldBeSize $ patternIdents param) + <> S.map identName (S.filter couldBeSize $ patIdents param) where couldBeSize ident = unInfo (identType ident) == Scalar (Prim (Signed Int64)) @@ -375,7 +375,7 @@ defuncFun :: [VName] -> - [Pattern] -> + [Pat] -> Exp -> StructType -> SrcLoc -> @@ -513,8 +513,8 @@ | otherwise = defuncExp e0 defuncExp (AppExp (LetPat sizes pat e1 e2 loc) (Info (AppRes t retext))) = do (e1', sv1) <- defuncExp e1 - let env = matchPatternSV pat sv1 - pat' = updatePattern pat sv1 + let env = matchPatSV pat sv1 + pat' = updatePat pat sv1 (e2', sv2) <- localEnv env $ defuncExp e2 -- To maintain any sizes going out of scope, we need to compute the -- old size substitution induced by retext and also apply it to the @@ -543,6 +543,9 @@ defuncExp (Negate e0 loc) = do (e0', sv) <- defuncExp e0 return (Negate e0' loc, sv) +defuncExp (Not e0 loc) = do + (e0', sv) <- defuncExp e0 + return (Not e0' loc, sv) defuncExp (Lambda pats e0 _ (Info (_, ret)) loc) = defuncFun [] pats e0 ret loc -- Operator sections are expected to be converted to lambda-expressions @@ -554,14 +557,14 @@ defuncExp IndexSection {} = error "defuncExp: unexpected projection section." defuncExp (AppExp (DoLoop sparams pat e1 form e3 loc) res) = do (e1', sv1) <- defuncExp e1 - let env1 = matchPatternSV pat sv1 + let env1 = matchPatSV pat sv1 (form', env2) <- case form of For v e2 -> do e2' <- defuncExp' e2 return (For v e2', envFromIdent v) ForIn pat2 e2 -> do e2' <- defuncExp' e2 - return (ForIn pat2 e2', envFromPattern pat2) + return (ForIn pat2 e2', envFromPat pat2) While e2 -> do e2' <- localEnv env1 $ defuncExp' e2 return (While e2', mempty) @@ -677,8 +680,8 @@ defuncCase :: StaticVal -> Case -> DefM (Case, StaticVal) defuncCase sv (CasePat p e loc) = do - let p' = updatePattern p sv - env = matchPatternSV p sv + let p' = updatePat p sv + env = matchPatSV p sv (e', sv') <- localEnv env $ defuncExp e return (CasePat p' e' loc, sv') @@ -692,18 +695,18 @@ defuncSoacExp (Parens e loc) = Parens <$> defuncSoacExp e <*> pure loc defuncSoacExp (Lambda params e0 decl tp loc) = do - let env = foldMap envFromPattern params + let env = foldMap envFromPat params e0' <- localEnv env $ defuncSoacExp e0 return $ Lambda params e0' decl tp loc defuncSoacExp e | Scalar Arrow {} <- typeOf e = do (pats, body, tp) <- etaExpand (typeOf e) e - let env = foldMap envFromPattern pats + let env = foldMap envFromPat pats body' <- localEnv env $ defuncExp' body return $ Lambda pats body' Nothing (Info (mempty, tp)) mempty | otherwise = defuncExp' e -etaExpand :: PatternType -> Exp -> DefM ([Pattern], Exp, StructType) +etaExpand :: PatType -> Exp -> DefM ([Pat], Exp, StructType) etaExpand e_t e = do let (ps, ret) = getType e_t (pats, vars) <- fmap unzip . forM ps $ \(p, t) -> do @@ -741,16 +744,16 @@ -- that have order 0 types (i.e., non-functional). defuncLet :: [VName] -> - [Pattern] -> + [Pat] -> Exp -> StructType -> - DefM ([VName], [Pattern], Exp, StaticVal) + DefM ([VName], [Pat], Exp, StaticVal) defuncLet dims ps@(pat : pats) body rettype | patternOrderZero pat = do let bound_by_pat = (`S.member` patternDimNames pat) -- Take care to not include more size parameters than necessary. (pat_dims, rest_dims) = partition bound_by_pat dims - env = envFromPattern pat <> envFromDimNames pat_dims + env = envFromPat pat <> envFromDimNames pat_dims (rest_dims', pats', body', sv) <- localEnv env $ defuncLet rest_dims pats body rettype closure <- defuncFun dims ps body rettype mempty return @@ -772,13 +775,13 @@ RecordSV $ M.toList $ M.intersectionWith imposeType (M.fromList fs1) fs2 imposeType sv _ = sv -sizesForAll :: MonadFreshNames m => S.Set VName -> [Pattern] -> m ([VName], [Pattern]) +sizesForAll :: MonadFreshNames m => S.Set VName -> [Pat] -> m ([VName], [Pat]) sizesForAll bound_sizes params = do (params', sizes) <- runStateT (mapM (astMap tv) params) mempty return (S.toList sizes, params') where - bound = bound_sizes <> foldMap patternNames params - tv = identityMapper {mapOnPatternType = bitraverse onDim pure} + bound = bound_sizes <> foldMap patNames params + tv = identityMapper {mapOnPatType = bitraverse onDim pure} onDim (AnyDim (Just v)) = do modify $ S.insert v pure $ NamedDim $ qualName v @@ -804,14 +807,14 @@ let e' = AppExp (Apply e1' e2' d loc) t case sv1 of LambdaSV pat e0_t e0 closure_env -> do - let env' = matchPatternSV pat sv2 + let env' = matchPatSV pat sv2 dims = mempty (e0', sv) <- localNewEnv (env' <> closure_env) $ defuncExtExp e0 - let closure_pat = buildEnvPattern dims closure_env - pat' = updatePattern pat sv2 + let closure_pat = buildEnvPat dims closure_env + pat' = updatePat pat sv2 globals <- asks fst @@ -827,7 +830,7 @@ already_bound = globals <> S.fromList dims - <> S.map identName (foldMap patternIdents params) + <> S.map identName (foldMap patIdents params) more_dims = S.toList $ @@ -979,7 +982,7 @@ -- dimensions, a list of parameters, a function body, and the -- appropriate static value for applying the function at the given -- depth of partial application. -liftDynFun :: String -> StaticVal -> Int -> ([Pattern], Exp, StaticVal) +liftDynFun :: String -> StaticVal -> Int -> ([Pat], Exp, StaticVal) liftDynFun _ (DynamicFun (e, sv) _) 0 = ([], e, sv) liftDynFun s (DynamicFun clsr@(_, LambdaSV pat _ _ _) sv) d | d > 0 = @@ -995,16 +998,16 @@ -- | Converts a pattern to an environment that binds the individual names of the -- pattern to their corresponding types wrapped in a 'Dynamic' static value. -envFromPattern :: Pattern -> Env -envFromPattern pat = case pat of - TuplePattern ps _ -> foldMap envFromPattern ps - RecordPattern fs _ -> foldMap (envFromPattern . snd) fs - PatternParens p _ -> envFromPattern p +envFromPat :: Pat -> Env +envFromPat pat = case pat of + TuplePat ps _ -> foldMap envFromPat ps + RecordPat fs _ -> foldMap (envFromPat . snd) fs + PatParens p _ -> envFromPat p Id vn (Info t) _ -> M.singleton vn $ Binding Nothing $ Dynamic t Wildcard _ _ -> mempty - PatternAscription p _ _ -> envFromPattern p - PatternLit {} -> mempty - PatternConstr _ _ ps _ -> foldMap envFromPattern ps + PatAscription p _ _ -> envFromPat p + PatLit {} -> mempty + PatConstr _ _ ps _ -> foldMap envFromPat ps envFromDimNames :: [VName] -> Env envFromDimNames = M.fromList . flip zip (repeat d) @@ -1013,7 +1016,7 @@ -- | Create a new top-level value declaration with the given function name, -- return type, list of parameters, and body expression. -liftValDec :: VName -> PatternType -> [VName] -> [Pattern] -> Exp -> DefM () +liftValDec :: VName -> PatType -> [VName] -> [Pat] -> Exp -> DefM () liftValDec fname rettype dims pats body = addValBind dec where dims' = map (`TypeParamDim` mempty) dims @@ -1021,7 +1024,7 @@ -- forget those return sizes that we forgot to propagate along -- the way. Hopefully the internaliser is conservative and -- will insert reshapes... - bound_here = S.fromList dims <> S.map identName (foldMap patternIdents pats) + bound_here = S.fromList dims <> S.map identName (foldMap patIdents pats) anyDimIfNotBound (NamedDim v) | qualLeaf v `S.member` bound_here = NamedDim v | otherwise = AnyDim $ Just $ qualLeaf v @@ -1045,8 +1048,8 @@ -- | Given a closure environment, construct a record pattern that -- binds the closed over variables. Insert wildcard for any patterns -- that would otherwise clash with size parameters. -buildEnvPattern :: [VName] -> Env -> Pattern -buildEnvPattern sizes env = RecordPattern (map buildField $ M.toList env) mempty +buildEnvPat :: [VName] -> Env -> Pat +buildEnvPat sizes env = RecordPat (map buildField $ M.toList env) mempty where buildField (vn, Binding _ sv) = ( nameFromString (pretty vn), @@ -1062,14 +1065,14 @@ -- lifted function can create unique arrays as long as they do not -- alias any of its parameters. XXX: it is not clear that this is a -- sufficient property, unfortunately. -buildRetType :: Env -> [Pattern] -> StructType -> PatternType -> PatternType +buildRetType :: Env -> [Pat] -> StructType -> PatType -> PatType buildRetType env pats = comb where bound = - S.fromList (M.keys env) <> S.map identName (foldMap patternIdents pats) + S.fromList (M.keys env) <> S.map identName (foldMap patIdents pats) boundAsUnique v = maybe False (unique . unInfo . identType) $ - find ((== v) . identName) $ S.toList $ foldMap patternIdents pats + find ((== v) . identName) $ S.toList $ foldMap patIdents pats problematic v = (v `S.member` bound) && not (boundAsUnique v) comb (Scalar (Record fs_annot)) (Scalar (Record fs_got)) = Scalar $ Record $ M.intersectionWith comb fs_annot fs_got @@ -1087,7 +1090,7 @@ -- | Compute the corresponding type for the *representation* of a -- given static value (not the original possibly higher-order value). -typeFromSV :: StaticVal -> PatternType +typeFromSV :: StaticVal -> PatType typeFromSV (Dynamic tp) = tp typeFromSV (LambdaSV _ _ _ env) = @@ -1107,7 +1110,7 @@ -- | Construct the type for a fully-applied dynamic function from its -- static value and the original types of its arguments. -dynamicFunType :: StaticVal -> [PatternType] -> ([PatternType], PatternType) +dynamicFunType :: StaticVal -> [PatType] -> ([PatType], PatType) dynamicFunType (DynamicFun _ sv) (p : ps) = let (ps', ret) = dynamicFunType sv ps in (p : ps', ret) dynamicFunType sv _ = ([], typeFromSV sv) @@ -1115,16 +1118,16 @@ -- | Match a pattern with its static value. Returns an environment with -- the identifier components of the pattern mapped to the corresponding -- subcomponents of the static value. -matchPatternSV :: PatternBase Info VName -> StaticVal -> Env -matchPatternSV (TuplePattern ps _) (RecordSV ls) = - mconcat $ zipWith (\p (_, sv) -> matchPatternSV p sv) ps ls -matchPatternSV (RecordPattern ps _) (RecordSV ls) +matchPatSV :: PatBase Info VName -> StaticVal -> Env +matchPatSV (TuplePat ps _) (RecordSV ls) = + mconcat $ zipWith (\p (_, sv) -> matchPatSV p sv) ps ls +matchPatSV (RecordPat ps _) (RecordSV ls) | ps' <- sortOn fst ps, ls' <- sortOn fst ls, map fst ps' == map fst ls' = - mconcat $ zipWith (\(_, p) (_, sv) -> matchPatternSV p sv) ps' ls' -matchPatternSV (PatternParens pat _) sv = matchPatternSV pat sv -matchPatternSV (Id vn (Info t) _) sv = + mconcat $ zipWith (\(_, p) (_, sv) -> matchPatSV p sv) ps' ls' +matchPatSV (PatParens pat _) sv = matchPatSV pat sv +matchPatSV (Id vn (Info t) _) sv = -- When matching a pattern with a zero-order STaticVal, the type of -- the pattern wins out. This is important when matching a -- nonunique pattern with a unique value. @@ -1135,23 +1138,23 @@ dim_env = M.fromList $ map (,i64) $ S.toList $ typeDimNames t i64 = Binding Nothing $ Dynamic $ Scalar $ Prim $ Signed Int64 -matchPatternSV (Wildcard _ _) _ = mempty -matchPatternSV (PatternAscription pat _ _) sv = matchPatternSV pat sv -matchPatternSV PatternLit {} _ = mempty -matchPatternSV (PatternConstr c1 _ ps _) (SumSV c2 ls fs) +matchPatSV (Wildcard _ _) _ = mempty +matchPatSV (PatAscription pat _ _) sv = matchPatSV pat sv +matchPatSV PatLit {} _ = mempty +matchPatSV (PatConstr c1 _ ps _) (SumSV c2 ls fs) | c1 == c2 = - mconcat $ zipWith matchPatternSV ps ls + mconcat $ zipWith matchPatSV ps ls | Just ts <- lookup c1 fs = - mconcat $ zipWith matchPatternSV ps $ map svFromType ts + mconcat $ zipWith matchPatSV ps $ map svFromType ts | otherwise = - error $ "matchPatternSV: missing constructor in type: " ++ pretty c1 -matchPatternSV (PatternConstr c1 _ ps _) (Dynamic (Scalar (Sum fs))) + error $ "matchPatSV: missing constructor in type: " ++ pretty c1 +matchPatSV (PatConstr c1 _ ps _) (Dynamic (Scalar (Sum fs))) | Just ts <- M.lookup c1 fs = - mconcat $ zipWith matchPatternSV ps $ map svFromType ts + mconcat $ zipWith matchPatSV ps $ map svFromType ts | otherwise = - error $ "matchPatternSV: missing constructor in type: " ++ pretty c1 -matchPatternSV pat (Dynamic t) = matchPatternSV pat $ svFromType t -matchPatternSV pat sv = + error $ "matchPatSV: missing constructor in type: " ++ pretty c1 +matchPatSV pat (Dynamic t) = matchPatSV pat $ svFromType t +matchPatSV pat sv = error $ "Tried to match pattern " ++ pretty pat ++ " with static value " @@ -1165,18 +1168,18 @@ -- | Given a pattern and the static value for the defunctionalized argument, -- update the pattern to reflect the changes in the types. -updatePattern :: Pattern -> StaticVal -> Pattern -updatePattern (TuplePattern ps loc) (RecordSV svs) = - TuplePattern (zipWith updatePattern ps $ map snd svs) loc -updatePattern (RecordPattern ps loc) (RecordSV svs) +updatePat :: Pat -> StaticVal -> Pat +updatePat (TuplePat ps loc) (RecordSV svs) = + TuplePat (zipWith updatePat ps $ map snd svs) loc +updatePat (RecordPat ps loc) (RecordSV svs) | ps' <- sortOn fst ps, svs' <- sortOn fst svs = - RecordPattern - (zipWith (\(n, p) (_, sv) -> (n, updatePattern p sv)) ps' svs') + RecordPat + (zipWith (\(n, p) (_, sv) -> (n, updatePat p sv)) ps' svs') loc -updatePattern (PatternParens pat loc) sv = - PatternParens (updatePattern pat sv) loc -updatePattern (Id vn (Info tp) loc) sv = +updatePat (PatParens pat loc) sv = + PatParens (updatePat pat sv) loc +updatePat (Id vn (Info tp) loc) sv = Id vn (Info $ comb tp (typeFromSV sv `setUniqueness` Nonunique)) loc where -- Preserve any original zeroth-order types. @@ -1186,24 +1189,24 @@ comb (Scalar (Sum m1)) (Scalar (Sum m2)) = Scalar $ Sum $ M.intersectionWith (zipWith comb) m1 m2 comb t1 _ = t1 -- t1 must be array or prim. -updatePattern pat@(Wildcard (Info tp) loc) sv +updatePat pat@(Wildcard (Info tp) loc) sv | orderZero tp = pat | otherwise = Wildcard (Info $ typeFromSV sv) loc -updatePattern (PatternAscription pat tydecl loc) sv +updatePat (PatAscription pat tydecl loc) sv | orderZero . unInfo $ expandedType tydecl = - PatternAscription (updatePattern pat sv) tydecl loc - | otherwise = updatePattern pat sv -updatePattern p@PatternLit {} _ = p -updatePattern pat@(PatternConstr c1 (Info t) ps loc) sv@(SumSV _ svs _) + PatAscription (updatePat pat sv) tydecl loc + | otherwise = updatePat pat sv +updatePat p@PatLit {} _ = p +updatePat pat@(PatConstr c1 (Info t) ps loc) sv@(SumSV _ svs _) | orderZero t = pat - | otherwise = PatternConstr c1 (Info t') ps' loc + | otherwise = PatConstr c1 (Info t') ps' loc where t' = typeFromSV sv `setUniqueness` Nonunique - ps' = zipWith updatePattern ps svs -updatePattern (PatternConstr c1 _ ps loc) (Dynamic t) = - PatternConstr c1 (Info t) ps loc -updatePattern pat (Dynamic t) = updatePattern pat (svFromType t) -updatePattern pat sv = + ps' = zipWith updatePat ps svs +updatePat (PatConstr c1 _ ps loc) (Dynamic t) = + PatConstr c1 (Info t) ps loc +updatePat pat (Dynamic t) = updatePat pat (svFromType t) +updatePat pat sv = error $ "Tried to update pattern " ++ pretty pat ++ "to reflect the static value " @@ -1211,7 +1214,7 @@ -- | Convert a record (or tuple) type to a record static value. This is used for -- "unwrapping" tuples and records that are nested in 'Dynamic' static values. -svFromType :: PatternType -> StaticVal +svFromType :: PatType -> StaticVal svFromType (Scalar (Record fs)) = RecordSV . M.toList $ M.map svFromType fs svFromType t = Dynamic t @@ -1244,7 +1247,7 @@ (tparams', params', body', sv) <- defuncLet (map typeParamName tparams) params body rettype globals <- asks fst - let bound_sizes = foldMap patternNames params' <> S.fromList tparams' <> globals + let bound_sizes = foldMap patNames params' <> S.fromList tparams' <> globals rettype' = -- FIXME: dubious that we cannot assume that all sizes in the -- body are in scope. This is because when we insert 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 @@ -169,10 +169,8 @@ -- we need to make them visible, because substitutions involving -- abstract types must be lifted out in transformModBind. let subst_abs = - S.fromList $ - map snd $ - filter ((`S.member` abs) . fst) $ - M.toList ascript_substs + S.fromList . map snd . filter ((`S.member` abs) . fst) $ + M.toList ascript_substs bindingAbs subst_abs m evalModExp :: ModExp -> TransformM Mod @@ -254,7 +252,7 @@ mapOnQualName = \v -> return $ fst $ lookupSubstInScope v scope, mapOnStructType = astMap (substituter scope), - mapOnPatternType = astMap (substituter scope) + mapOnPatType = astMap (substituter scope) } onExp scope e = -- One expression is tricky, because it interacts with scoping rules. 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 @@ -4,6 +4,8 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +-- | Conversion of a monomorphic, first-order, defunctorised source +-- program to a core Futhark program. module Futhark.Internalise.Exps (transformProg) where import Control.Monad.Reader @@ -11,7 +13,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import qualified Data.Set as S -import Futhark.IR.SOACS as I hiding (stmPattern) +import Futhark.IR.SOACS as I hiding (stmPat) import Futhark.Internalise.AccurateSizes import Futhark.Internalise.Bindings import Futhark.Internalise.Lambdas @@ -58,12 +60,14 @@ (body', rettype') <- buildBody $ do body_res <- internaliseExp (baseString fname <> "_res") body - rettype_bad <- - internaliseReturnType rettype =<< mapM subExpType body_res - let rettype' = zeroExts rettype_bad + rettype' <- + fmap zeroExts . internaliseReturnType rettype =<< mapM subExpType body_res body_res' <- - ensureResultExtShape msg loc (map I.fromDecl rettype') body_res - pure (body_res', rettype') + ensureResultExtShape msg loc (map I.fromDecl rettype') $ subExpsRes body_res + pure + ( body_res', + replicate (length (shapeContext rettype')) (I.Prim int64) ++ rettype' + ) let all_params = shapeparams ++ concat params' @@ -102,7 +106,7 @@ let entry' = entryPoint (baseName ofname) (zip e_paramts params') (e_rettype, entry_rettype) args = map (I.Var . I.paramName) $ concat params' - entry_body <- buildBody_ $ do + (entry_body, ctx_ts) <- buildBody $ do -- Special case the (rare) situation where the entry point is -- not a function. maybe_const <- lookupConst ofname @@ -114,14 +118,14 @@ ctx <- extractShapeContext (concat entry_rettype) <$> mapM (fmap I.arrayDims . subExpType) vals - pure $ ctx ++ vals + pure (subExpsRes $ ctx ++ vals, map (const (I.Prim int64)) ctx) addFunDef $ I.FunDef (Just entry') (internaliseAttrs attrs) ("entry_" <> baseName ofname) - (concat entry_rettype) + (ctx_ts ++ concat entry_rettype) (shapeparams ++ concat params') entry_body @@ -182,7 +186,7 @@ internaliseBody :: String -> E.Exp -> InternaliseM Body internaliseBody desc e = - buildBody_ $ internaliseExp (desc <> "_res") e + buildBody_ $ subExpsRes <$> internaliseExp (desc <> "_res") e bodyFromStms :: InternaliseM (Result, a) -> @@ -221,17 +225,17 @@ let errmsg = errorMsg $ ["Range "] - ++ [ErrorInt64 start'_i64] + ++ [ErrorVal int64 start'_i64] ++ ( case maybe_second'_i64 of Nothing -> [] - Just second_i64 -> ["..", ErrorInt64 second_i64] + Just second_i64 -> ["..", ErrorVal int64 second_i64] ) ++ ( case end of DownToExclusive {} -> ["..>"] ToInclusive {} -> ["..."] UpToExclusive {} -> ["..<"] ) - ++ [ErrorInt64 end'_i64, " is invalid."] + ++ [ErrorVal int64 end'_i64, " is invalid."] (it, le_op, lt_op) <- case E.typeOf start of @@ -348,7 +352,7 @@ dims <- arrayDims <$> subExpType e' let parts = ["Value of (core language) shape ("] - ++ intersperse ", " (map ErrorInt64 dims) + ++ intersperse ", " (map (ErrorVal int64) dims) ++ [") cannot match shape of type `"] ++ dt' ++ ["`."] @@ -375,12 +379,7 @@ let tag ses = [(se, I.Observe) | se <- ses] args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args) let args'' = concatMap tag args' - letTupExp' desc $ - I.Apply - fname - args'' - [I.Prim rettype] - (Safe, loc, []) + letTupExp' desc $ I.Apply fname args'' [I.Prim rettype] (Safe, loc, []) | otherwise -> do args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args) fst <$> funcall desc qfname args' loc @@ -414,18 +413,20 @@ merge_ts = map (I.paramType . fst) merge loopbody'' <- localScope (scopeOfFParams $ map fst merge) . inScopeOf form' . buildBody_ $ - ensureArgShapes - "shape of loop result does not match shapes in loop parameter" - loc - (map (I.paramName . fst) ctxmerge) - merge_ts + fmap subExpsRes + . ensureArgShapes + "shape of loop result does not match shapes in loop parameter" + loc + (map (I.paramName . fst) ctxmerge) + merge_ts + . map resSubExp =<< bodyBind loopbody' attrs <- asks envAttrs map I.Var . dropCond <$> attributing attrs - (letTupExp desc (I.DoLoop ctxmerge valmerge form' loopbody'')) + (letTupExp desc (I.DoLoop (ctxmerge <> valmerge) form' loopbody'')) where sparams' = map (`TypeParamDim` mempty) sparams @@ -436,7 +437,7 @@ sets <- mapM subExpType ses shapeargs <- argShapes (map I.paramName shapepat) mergepat' sets return - ( shapeargs ++ ses, + ( subExpsRes $ shapeargs ++ ses, ( form', shapepat, mergepat', @@ -518,11 +519,11 @@ | not $ primType $ paramType p -> Reshape (map DimCoercion $ arrayDims $ paramType p) v _ -> SubExp se - internaliseExp "loop_cond" cond + subExpsRes <$> internaliseExp "loop_cond" cond loop_end_cond <- bodyBind loop_end_cond_body return - ( shapeargs ++ loop_end_cond ++ ses, + ( subExpsRes shapeargs ++ loop_end_cond ++ subExpsRes ses, ( I.WhileLoop $ I.paramName loop_while, shapepat, loop_while : mergepat', @@ -670,6 +671,16 @@ I.Prim (I.FloatType t) -> letTupExp' desc $ I.BasicOp $ I.BinOp (I.FSub t) (I.floatConst t 0) e' _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in Negate" +internaliseExp desc (E.Not e _) = do + e' <- internaliseExp1 "not_arg" e + et <- subExpType e' + case et of + I.Prim (I.IntType t) -> + letTupExp' desc $ I.BasicOp $ I.UnOp (I.Complement t) e' + I.Prim I.Bool -> + letTupExp' desc $ I.BasicOp $ I.UnOp I.Not e' + _ -> + error "Futhark.Internalise.internaliseExp: non-int/bool type in Not" internaliseExp desc (E.Update src slice ve loc) = do ves <- internaliseExp "lw_val" ve srcs <- internaliseExpToVars "src" src @@ -707,16 +718,27 @@ src'' <- replace t fs ve' to_update return $ bef ++ src'' ++ aft replace _ _ ve' _ = return ve' -internaliseExp desc (E.Attr attr e _) = - local f $ internaliseExp desc e +internaliseExp desc (E.Attr attr e loc) = do + e' <- local f $ internaliseExp desc e + case attr' of + "trace" -> + traceRes (locStr loc) e' + I.AttrComp "trace" [I.AttrAtom tag] -> + traceRes (nameToString tag) e' + "opaque" -> + mapM (letSubExp desc . BasicOp . Opaque OpaqueNil) e' + _ -> + pure e' where - attrs = oneAttr $ internaliseAttr attr + traceRes tag' e' = + mapM (letSubExp desc . BasicOp . Opaque (OpaqueTrace tag')) e' + attr' = internaliseAttr attr f env - | "unsafe" `inAttrs` attrs, + | attr' == "unsafe", not $ envSafe env = env {envDoBoundsChecks = False} | otherwise = - env {envAttrs = envAttrs env <> attrs} + env {envAttrs = envAttrs env <> oneAttr attr'} internaliseExp desc (E.Assert e1 e2 (Info check) loc) = do e1' <- internaliseExp1 "assert_cond" e1 c <- assert "assert_c" e1' (errorMsg [ErrorString $ "Assertion is false: " <> check]) loc @@ -794,23 +816,28 @@ internaliseArg :: String -> (E.Exp, Maybe VName) -> InternaliseM [SubExp] internaliseArg desc (arg, argdim) = do - arg' <- internaliseExp desc arg - case (arg', argdim) of - ([se], Just d) -> letBindNames [d] $ BasicOp $ SubExp se - _ -> return () - return arg' + exists <- askScope + case argdim of + Just d | d `M.member` exists -> pure [I.Var d] + _ -> do + arg' <- internaliseExp desc arg + case (arg', argdim) of + ([se], Just d) -> do + letBindNames [d] $ BasicOp $ SubExp se + _ -> return () + pure arg' subExpPrimType :: I.SubExp -> InternaliseM I.PrimType subExpPrimType = fmap I.elemType . subExpType -generateCond :: E.Pattern -> [I.SubExp] -> InternaliseM (I.SubExp, [I.SubExp]) +generateCond :: E.Pat -> [I.SubExp] -> InternaliseM (I.SubExp, [I.SubExp]) generateCond orig_p orig_ses = do (cmps, pertinent, _) <- compares orig_p orig_ses cmp <- letSubExp "matches" =<< eAll cmps return (cmp, pertinent) where -- Literals are always primitive values. - compares (E.PatternLit l t _) (se : ses) = do + compares (E.PatLit l t _) (se : ses) = do e' <- case l of PatLitPrim v -> pure $ constant $ internalisePrimValue v PatLitInt x -> internaliseExp1 "constant" $ E.IntLit x t mempty @@ -818,7 +845,7 @@ t' <- subExpPrimType se cmp <- letSubExp "match_lit" $ I.BasicOp $ I.CmpOp (I.CmpEq t') e' se return ([cmp], [se], ses) - compares (E.PatternConstr c (Info (E.Scalar (E.Sum fs))) pats _) (se : ses) = do + compares (E.PatConstr c (Info (E.Scalar (E.Sum fs))) pats _) (se : ses) = do (payload_ts, m) <- internaliseSumType $ M.map (map toStruct) fs case M.lookup c m of Just (i, payload_is) -> do @@ -829,26 +856,26 @@ return (cmp : cmps, pertinent, ses') Nothing -> error "generateCond: missing constructor" - compares (E.PatternConstr _ (Info t) _ _) _ = - error $ "generateCond: PatternConstr has nonsensical type: " ++ pretty t + compares (E.PatConstr _ (Info t) _ _) _ = + error $ "generateCond: PatConstr has nonsensical type: " ++ pretty t compares (E.Id _ t loc) ses = compares (E.Wildcard t loc) ses compares (E.Wildcard (Info t) _) ses = do n <- internalisedTypeSize $ E.toStruct t let (id_ses, rest_ses) = splitAt n ses return ([], id_ses, rest_ses) - compares (E.PatternParens pat _) ses = + compares (E.PatParens pat _) ses = compares pat ses -- XXX: treat empty tuples and records as bool. - compares (E.TuplePattern [] loc) ses = + compares (E.TuplePat [] loc) ses = compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses - compares (E.RecordPattern [] loc) ses = + compares (E.RecordPat [] loc) ses = compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses - compares (E.TuplePattern pats _) ses = + compares (E.TuplePat pats _) ses = comparesMany pats ses - compares (E.RecordPattern fs _) ses = + compares (E.RecordPat fs _) ses = comparesMany (map snd $ E.sortFields $ M.fromList fs) ses - compares (E.PatternAscription pat _ _) ses = + compares (E.PatAscription pat _ _) ses = compares pat ses compares pat [] = error $ "generateCond: No values left for pattern " ++ pretty pat @@ -872,7 +899,7 @@ internalisePat :: String -> [E.SizeBinder VName] -> - E.Pattern -> + E.Pat -> E.Exp -> E.Exp -> (E.Exp -> InternaliseM a) -> @@ -881,20 +908,20 @@ ses <- internaliseExp desc' e internalisePat' sizes p ses body m where - desc' = case S.toList $ E.patternIdents p of + desc' = case S.toList $ E.patIdents p of [v] -> baseString $ E.identName v _ -> desc internalisePat' :: [E.SizeBinder VName] -> - E.Pattern -> + E.Pat -> [I.SubExp] -> E.Exp -> (E.Exp -> InternaliseM a) -> InternaliseM a internalisePat' sizes p ses body m = do ses_ts <- mapM subExpType ses - stmPattern p ses_ts $ \pat_names -> do + stmPat p ses_ts $ \pat_names -> do bindExtSizes (AppRes (E.patternType p) (map E.sizeName sizes)) ses forM_ (zip pat_names ses) $ \(v, se) -> letBindNames [v] $ I.BasicOp $ I.SubExp se @@ -904,7 +931,7 @@ SrcLoc -> [SubExp] -> [E.DimIndex] -> - InternaliseM ([I.DimIndex SubExp], Certificates) + InternaliseM ([I.DimIndex SubExp], Certs) internaliseSlice loc dims idxs = do (idxs', oks, parts) <- unzip3 <$> zipWithM internaliseDimIndex dims idxs ok <- letSubExp "index_ok" =<< eAll oks @@ -912,7 +939,7 @@ errorMsg $ ["Index ["] ++ intercalate [", "] parts ++ ["] out of bounds for array of shape ["] - ++ intersperse "][" (map ErrorInt64 $ take (length idxs) dims) + ++ intersperse "][" (map (ErrorVal int64) $ take (length idxs) dims) ++ ["]."] c <- assert "index_certs" ok msg loc return (idxs', c) @@ -930,7 +957,7 @@ I.BasicOp $ I.CmpOp (I.CmpSlt I.Int64) i' w ok <- letSubExp "bounds_check" =<< eBinOp I.LogAnd (pure lowerBound) (pure upperBound) - return (I.DimFix i', ok, [ErrorInt64 i']) + return (I.DimFix i', ok, [ErrorVal int64 i']) -- Special-case an important common case that otherwise leads to horrible code. internaliseDimIndex @@ -986,7 +1013,7 @@ n <- letSubExp "n" =<< divRounding (toExp j_m_i) (toExp s') zero_stride <- letSubExp "zero_stride" $ I.BasicOp $ I.CmpOp (CmpEq int64) s_sign zero - nonzero_stride <- letSubExp "nonzero_stride" $ I.BasicOp $ I.UnOp Not zero_stride + nonzero_stride <- letSubExp "nonzero_stride" $ I.BasicOp $ I.UnOp I.Not zero_stride -- Bounds checks depend on whether we are slicing forwards or -- backwards. If forwards, we must check '0 <= i && i <= j'. If @@ -1038,20 +1065,20 @@ let parts = case (i, j, s) of (_, _, Just {}) -> - [ maybe "" (const $ ErrorInt64 i') i, + [ maybe "" (const $ ErrorVal int64 i') i, ":", - maybe "" (const $ ErrorInt64 j') j, + maybe "" (const $ ErrorVal int64 j') j, ":", - ErrorInt64 s' + ErrorVal int64 s' ] (_, Just {}, _) -> - [ maybe "" (const $ ErrorInt64 i') i, + [ maybe "" (const $ ErrorVal int64 i') i, ":", - ErrorInt64 j' + ErrorVal int64 j' ] - ++ maybe mempty (const [":", ErrorInt64 s']) s + ++ maybe mempty (const [":", ErrorVal int64 s']) s (_, Nothing, Nothing) -> - [ErrorInt64 i', ":"] + [ErrorVal int64 i', ":"] return (I.DimSlice i' n s', acceptable, parts) where zero = constant (0 :: Int64) @@ -1119,7 +1146,7 @@ img_params <- mapM (newParam "img_p" . rowType) =<< mapM lookupType img' let params = bucket_param : img_params rettype = I.Prim int64 : ne_ts - body = mkBody mempty $ map (I.Var . paramName) params + body = mkBody mempty $ varsRes $ map paramName params lam' <- mkLambda params $ ensureResultShape @@ -1191,7 +1218,7 @@ I.arrayDims $ I.paramType p nes <- bodyBind =<< renameBody lam_body - nes_ts <- mapM I.subExpType nes + nes_ts <- mapM I.subExpResType nes outsz <- arraysSize 0 <$> mapM lookupType arrs let acc_arr_tps = [I.arrayOf t (I.Shape [outsz]) NoUniqueness | t <- nes_ts] lam0' <- internaliseFoldLambda internaliseLambda lam0 nes_ts acc_arr_tps @@ -1212,7 +1239,7 @@ (srclocOf lam) [] (map I.typeOf $ I.lambdaParams lam0') - lam_res + (map resSubExp lam_res) ensureResultShape "shape of result does not match shape of initial value" (srclocOf lam0) @@ -1223,7 +1250,7 @@ let form = I.Parallel o comm lam0' w <- arraysSize 0 <$> mapM lookupType arrs - letTupExp' desc $ I.Op $ I.Stream w arrs form nes lam' + letTupExp' desc $ I.Op $ I.Stream w arrs form (map resSubExp nes) lam' internaliseStreamAcc :: String -> @@ -1246,7 +1273,8 @@ internaliseMapLambda internaliseLambda lam $ map I.Var $ paramName acc_p : bs' w <- arraysSize 0 <$> mapM lookupType bs' - letTupExp' "acc_res" $ I.Op $ I.Screma w (paramName acc_p : bs') (I.mapSOAC lam') + fmap subExpsRes . letTupExp' "acc_res" $ + I.Op $ I.Screma w (paramName acc_p : bs') (I.mapSOAC lam') op' <- case op of @@ -1308,7 +1336,7 @@ letSubExp "zero" $ I.BasicOp $ CmpOp (CmpEq (IntType t)) x (intConst t 0) - nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp Not zero + nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp I.Not zero c <- assert "nonzero_cert" nonzero "division by zero" loc certifying c m @@ -1493,7 +1521,7 @@ bodyExtType :: Body -> InternaliseM [ExtType] bodyExtType (Body _ stms res) = existentialiseExtTypes (M.keys stmsscope) . staticShapes - <$> extendedScope (traverse subExpType res) stmsscope + <$> extendedScope (traverse subExpResType res) stmsscope where stmsscope = scopeOf stms @@ -1592,7 +1620,7 @@ dims_match <- forM (zip x_dims y_dims) $ \(x_dim, y_dim) -> letSubExp "dim_eq" $ I.BasicOp $ I.CmpOp (I.CmpEq int64) x_dim y_dim shapes_match <- letSubExp "shapes_match" =<< eAll dims_match - compare_elems_body <- runBodyBinder $ do + compare_elems_body <- runBodyBuilder $ do -- Flatten both x and y. x_num_elems <- letSubExp "x_num_elems" @@ -1686,9 +1714,6 @@ fmap pure $ letSubExp desc $ BasicOp $ UpdateAcc acc' [i'] vs handleAccs _ _ = Nothing - handleRest [x] "!" = Just $ complementF x - handleRest [x] "opaque" = Just $ \desc -> - mapM (letSubExp desc . BasicOp . Opaque) =<< internaliseExp "opaque_arg" x handleRest [E.TupLit [a, si, v] _] "scatter" = Just $ scatterF 1 a si v handleRest [E.TupLit [a, si, v] _] "scatter_2d" = Just $ scatterF 2 a si v handleRest [E.TupLit [a, si, v] _] "scatter_3d" = Just $ scatterF 3 a si v @@ -1760,8 +1785,18 @@ <*> internaliseExpToVars (desc ++ "_zip_y") y ) handleRest [x] "unzip" = Just $ flip internaliseExp x - handleRest [x] "trace" = Just $ flip internaliseExp x - handleRest [x] "break" = Just $ flip internaliseExp x + handleRest [TupLit [arr, offset, n1, s1, n2, s2] _] "flat_index_2d" = Just $ \desc -> do + flatIndexHelper desc loc arr offset [(n1, s1), (n2, s2)] + handleRest [TupLit [arr1, offset, s1, s2, arr2] _] "flat_update_2d" = Just $ \desc -> do + flatUpdateHelper desc loc arr1 offset [s1, s2] arr2 + handleRest [TupLit [arr, offset, n1, s1, n2, s2, n3, s3] _] "flat_index_3d" = Just $ \desc -> do + flatIndexHelper desc loc arr offset [(n1, s1), (n2, s2), (n3, s3)] + handleRest [TupLit [arr1, offset, s1, s2, s3, arr2] _] "flat_update_3d" = Just $ \desc -> do + flatUpdateHelper desc loc arr1 offset [s1, s2, s3] arr2 + handleRest [TupLit [arr, offset, n1, s1, n2, s2, n3, s3, n4, s4] _] "flat_index_4d" = Just $ \desc -> do + flatIndexHelper desc loc arr offset [(n1, s1), (n2, s2), (n3, s3), (n4, s4)] + handleRest [TupLit [arr1, offset, s1, s2, s3, s4, arr2] _] "flat_update_4d" = Just $ \desc -> do + flatUpdateHelper desc loc arr1 offset [s1, s2, s3, s4] arr2 handleRest _ _ = Nothing toSigned int_to e desc = do @@ -1800,17 +1835,6 @@ letTupExp' desc $ I.BasicOp $ I.ConvOp (I.FPToUI float_from int_to) e' _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in ToUnsigned" - complementF e desc = do - e' <- internaliseExp1 "complement_arg" e - et <- subExpType e' - case et of - I.Prim (I.IntType t) -> - letTupExp' desc $ I.BasicOp $ I.UnOp (I.Complement t) e' - I.Prim I.Bool -> - letTupExp' desc $ I.BasicOp $ I.UnOp I.Not e' - _ -> - error "Futhark.Internalise.internaliseExp: non-int/bool type in Complement" - scatterF dim a si v desc = do si' <- internaliseExpToVars "write_arg_i" si svs <- internaliseExpToVars "write_arg_v" v @@ -1859,7 +1883,7 @@ "scatter value has wrong size" loc bodyTypes - results + (subExpsRes results) let lam = I.Lambda @@ -1872,6 +1896,100 @@ let sa_ws = map (Shape . take dim . arrayDims) sa_ts letTupExp' desc $ I.Op $ I.Scatter si_w lam sivs $ zip3 sa_ws (repeat 1) sas +flatIndexHelper :: String -> SrcLoc -> E.Exp -> E.Exp -> [(E.Exp, E.Exp)] -> InternaliseM [SubExp] +flatIndexHelper desc loc arr offset slices = do + arrs <- internaliseExpToVars "arr" arr + offset' <- internaliseExp1 "offset" offset + old_dim <- I.arraysSize 0 <$> mapM lookupType arrs + offset_inbounds_down <- letSubExp "offset_inbounds_down" $ I.BasicOp $ I.CmpOp (I.CmpUle Int64) (intConst Int64 0) offset' + offset_inbounds_up <- letSubExp "offset_inbounds_up" $ I.BasicOp $ I.CmpOp (I.CmpUlt Int64) offset' old_dim + slices' <- + mapM + ( \(n, s) -> do + n' <- internaliseExp1 "n" n + s' <- internaliseExp1 "s" s + return (n', s') + ) + slices + (min_bound, max_bound) <- + foldM + ( \(lower, upper) (n, s) -> do + n_m1 <- letSubExp "span" $ I.BasicOp $ I.BinOp (I.Sub Int64 I.OverflowUndef) n (intConst Int64 1) + spn <- letSubExp "span" $ I.BasicOp $ I.BinOp (I.Mul Int64 I.OverflowUndef) n_m1 s + + span_and_lower <- letSubExp "span_and_lower" $ I.BasicOp $ I.BinOp (I.Add Int64 I.OverflowUndef) spn lower + span_and_upper <- letSubExp "span_and_upper" $ I.BasicOp $ I.BinOp (I.Add Int64 I.OverflowUndef) spn upper + + lower' <- letSubExp "minimum" $ I.BasicOp $ I.BinOp (I.UMin Int64) span_and_lower lower + upper' <- letSubExp "maximum" $ I.BasicOp $ I.BinOp (I.UMax Int64) span_and_upper upper + + return (lower', upper') + ) + (offset', offset') + slices' + min_in_bounds <- letSubExp "min_in_bounds" $ I.BasicOp $ I.CmpOp (I.CmpUle Int64) (intConst Int64 0) min_bound + max_in_bounds <- letSubExp "max_in_bounds" $ I.BasicOp $ I.CmpOp (I.CmpUlt Int64) max_bound old_dim + + all_bounds <- + foldM + (\x y -> letSubExp "inBounds" $ I.BasicOp $ I.BinOp I.LogAnd x y) + offset_inbounds_down + [offset_inbounds_up, min_in_bounds, max_in_bounds] + + c <- assert "bounds_cert" all_bounds (ErrorMsg [ErrorString $ "Flat slice out of bounds: " ++ pretty old_dim ++ " and " ++ pretty slices']) loc + let slice = I.FlatSlice offset' $ map (uncurry FlatDimIndex) slices' + certifying c $ + forM arrs $ \arr' -> + letSubExp desc $ I.BasicOp $ I.FlatIndex arr' slice + +flatUpdateHelper :: String -> SrcLoc -> E.Exp -> E.Exp -> [E.Exp] -> E.Exp -> InternaliseM [SubExp] +flatUpdateHelper desc loc arr1 offset slices arr2 = do + arrs1 <- internaliseExpToVars "arr" arr1 + offset' <- internaliseExp1 "offset" offset + old_dim <- I.arraysSize 0 <$> mapM lookupType arrs1 + offset_inbounds_down <- letSubExp "offset_inbounds_down" $ I.BasicOp $ I.CmpOp (I.CmpUle Int64) (intConst Int64 0) offset' + offset_inbounds_up <- letSubExp "offset_inbounds_up" $ I.BasicOp $ I.CmpOp (I.CmpUlt Int64) offset' old_dim + arrs2 <- internaliseExpToVars "arr" arr2 + ts <- mapM lookupType arrs2 + slices' <- + mapM + ( \(s, i) -> do + s' <- internaliseExp1 "s" s + let n = arraysSize i ts + return (n, s') + ) + $ zip slices [0 ..] + (min_bound, max_bound) <- + foldM + ( \(lower, upper) (n, s) -> do + n_m1 <- letSubExp "span" $ I.BasicOp $ I.BinOp (I.Sub Int64 I.OverflowUndef) n (intConst Int64 1) + spn <- letSubExp "span" $ I.BasicOp $ I.BinOp (I.Mul Int64 I.OverflowUndef) n_m1 s + + span_and_lower <- letSubExp "span_and_lower" $ I.BasicOp $ I.BinOp (I.Add Int64 I.OverflowUndef) spn lower + span_and_upper <- letSubExp "span_and_upper" $ I.BasicOp $ I.BinOp (I.Add Int64 I.OverflowUndef) spn upper + + lower' <- letSubExp "minimum" $ I.BasicOp $ I.BinOp (I.UMin Int64) span_and_lower lower + upper' <- letSubExp "maximum" $ I.BasicOp $ I.BinOp (I.UMax Int64) span_and_upper upper + + return (lower', upper') + ) + (offset', offset') + slices' + min_in_bounds <- letSubExp "min_in_bounds" $ I.BasicOp $ I.CmpOp (I.CmpUle Int64) (intConst Int64 0) min_bound + max_in_bounds <- letSubExp "max_in_bounds" $ I.BasicOp $ I.CmpOp (I.CmpUlt Int64) max_bound old_dim + + all_bounds <- + foldM + (\x y -> letSubExp "inBounds" $ I.BasicOp $ I.BinOp I.LogAnd x y) + offset_inbounds_down + [offset_inbounds_up, min_in_bounds, max_in_bounds] + + c <- assert "bounds_cert" all_bounds (ErrorMsg [ErrorString $ "Flat slice out of bounds: " ++ pretty old_dim ++ " and " ++ pretty slices']) loc + let slice = I.FlatSlice offset' $ map (uncurry FlatDimIndex) slices' + certifying c $ + forM (zip arrs1 arrs2) $ \(arr1', arr2') -> + letSubExp desc $ I.BasicOp $ I.FlatUpdate arr1' slice arr2' + funcall :: String -> QualName VName -> @@ -1959,7 +2077,7 @@ replicateM k $ I.Param <$> newVName "x" <*> pure (I.Prim int64) add_lam_y_params <- replicateM k $ I.Param <$> newVName "y" <*> pure (I.Prim int64) - add_lam_body <- runBodyBinder $ + add_lam_body <- runBodyBuilder $ localScope (scopeOfLParams $ add_lam_x_params ++ add_lam_y_params) $ fmap resultBody $ forM (zip add_lam_x_params add_lam_y_params) $ \(x, y) -> @@ -1984,10 +2102,10 @@ -- the total sizes, which are the last elements in the offests. We -- just have to be careful in case the array is empty. last_index <- letSubExp "last_index" $ I.BasicOp $ I.BinOp (I.Sub Int64 OverflowUndef) w $ constant (1 :: Int64) - nonempty_body <- runBodyBinder $ + nonempty_body <- runBodyBuilder $ fmap resultBody $ forM all_offsets $ \offset_array -> - letSubExp "last_offset" $ I.BasicOp $ I.Index offset_array [I.DimFix last_index] + letSubExp "last_offset" $ I.BasicOp $ I.Index offset_array $ Slice [I.DimFix last_index] let empty_body = resultBody $ replicate k $ constant (0 :: Int64) is_empty <- letSubExp "is_empty" $ I.BasicOp $ I.CmpOp (CmpEq int64) w $ constant (0 :: Int64) sizes <- @@ -2024,8 +2142,8 @@ ++ map I.rowType arr_ts, I.lambdaBody = mkBody offset_stms $ - replicate (length arr_ts) offset - ++ map (I.Var . I.paramName) value_params + replicate (length arr_ts) (subExpRes offset) + ++ I.varsRes (map I.paramName value_params) } results <- letTupExp "partition_res" $ @@ -2111,7 +2229,7 @@ d' <- case substs of Just [v] -> return v _ -> return $ I.Var $ E.qualLeaf d - return $ ErrorInt64 d' + return $ ErrorVal int64 d' dimExpForError (DimExpConst d _) = return $ ErrorString $ pretty d dimExpForError DimExpAny = return "" diff --git a/src/Futhark/Internalise/FreeVars.hs b/src/Futhark/Internalise/FreeVars.hs --- a/src/Futhark/Internalise/FreeVars.hs +++ b/src/Futhark/Internalise/FreeVars.hs @@ -3,12 +3,11 @@ module Futhark.Internalise.FreeVars ( freeVars, without, - member, ident, size, sizes, NameSet (..), - patternVars, + patVars, ) where @@ -36,10 +35,6 @@ withoutM :: NameSet -> NameSet -> NameSet withoutM (NameSet x) (NameSet y) = NameSet $ x `M.difference` y --- | Is this name in the 'NameSet'? -member :: VName -> NameSet -> Bool -member v (NameSet m) = v `M.member` m - -- | A 'NameSet' with a single 'Nonunique' name. ident :: Ident -> NameSet ident v = NameSet $ M.singleton (identName v) (toStruct $ unInfo $ identType v) @@ -74,11 +69,11 @@ AppExp (LetPat let_sizes pat e1 e2 _) _ -> freeVars e1 <> ( (sizes (patternDimNames pat) <> freeVars e2) - `withoutM` (patternVars pat <> foldMap (size . sizeName) let_sizes) + `withoutM` (patVars pat <> foldMap (size . sizeName) let_sizes) ) AppExp (LetFun vn (tparams, pats, _, _, e1) e2 _) _ -> ( (freeVars e1 <> sizes (foldMap patternDimNames pats)) - `without` ( S.map identName (foldMap patternIdents pats) + `without` ( S.map identName (foldMap patIdents pats) <> S.fromList (map typeParamName tparams) ) ) @@ -86,9 +81,10 @@ AppExp (If e1 e2 e3 _) _ -> freeVars e1 <> freeVars e2 <> freeVars e3 AppExp (Apply e1 e2 _ _) _ -> freeVars e1 <> freeVars e2 Negate e _ -> freeVars e + Not e _ -> freeVars e Lambda pats e0 _ (Info (_, t)) _ -> (sizes (foldMap patternDimNames pats) <> freeVars e0 <> sizes (typeDimNames t)) - `withoutM` foldMap patternVars pats + `withoutM` foldMap patVars pats OpSection {} -> mempty OpSectionLeft _ _ e _ _ _ -> freeVars e OpSectionRight _ _ e _ _ _ -> freeVars e @@ -98,11 +94,11 @@ let (e2fv, e2ident) = formVars form in freeVars e1 <> ( (e2fv <> freeVars e3) - `withoutM` (sizes (S.fromList sparams) <> patternVars pat <> e2ident) + `withoutM` (sizes (S.fromList sparams) <> patVars pat <> e2ident) ) where formVars (For v e2) = (freeVars e2, ident v) - formVars (ForIn p e2) = (freeVars e2, patternVars p) + formVars (ForIn p e2) = (freeVars e2, patVars p) formVars (While e2) = (freeVars e2, mempty) AppExp (BinOp (qn, _) (Info qn_t) (e1, _) (e2, _) _) _ -> NameSet (M.singleton (qualLeaf qn) $ toStruct qn_t) @@ -122,7 +118,7 @@ where caseFV (CasePat p eCase _) = (sizes (patternDimNames p) <> freeVars eCase) - `withoutM` patternVars p + `withoutM` patVars p freeDimIndex :: DimIndexBase Info VName -> NameSet freeDimIndex (DimFix e) = freeVars e @@ -130,5 +126,5 @@ foldMap (foldMap freeVars) [me1, me2, me3] -- | Extract all the variable names bound in a pattern. -patternVars :: Pattern -> NameSet -patternVars = mconcat . map ident . S.toList . patternIdents +patVars :: Pat -> NameSet +patVars = mconcat . map ident . S.toList . patIdents diff --git a/src/Futhark/Internalise/Lambdas.hs b/src/Futhark/Internalise/Lambdas.hs --- a/src/Futhark/Internalise/Lambdas.hs +++ b/src/Futhark/Internalise/Lambdas.hs @@ -49,7 +49,7 @@ (lam_params, orig_body, rettype) <- internaliseLambda lam $ I.Prim int64 : map outer argtypes let orig_chunk_param : params = lam_params - body <- runBodyBinder $ do + body <- runBodyBuilder $ do letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size return orig_body mkLambda (chunk_param : params) $ do @@ -95,7 +95,7 @@ (lam_params, orig_body, _) <- internaliseLambda lam $ I.Prim int64 : chunktypes let orig_chunk_param : params = lam_params - body <- runBodyBinder $ do + body <- runBodyBuilder $ do letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size return orig_body return (chunk_param : params, body) @@ -139,6 +139,6 @@ (resultBody <$> mkResult eq_class (i + 1)) lambdaWithIncrement :: I.Body -> InternaliseM I.Body - lambdaWithIncrement lam_body = runBodyBinder $ do - eq_class <- head <$> bodyBind lam_body + lambdaWithIncrement lam_body = runBodyBuilder $ do + eq_class <- resSubExp . head <$> bodyBind lam_body resultBody <$> mkResult eq_class 0 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 @@ -73,18 +73,17 @@ m = identityMapper {mapOnExp = \e' -> modify (<> existentials e') >> pure e'} in execState (astMap m e) here -liftFunction :: VName -> [TypeParam] -> [Pattern] -> StructType -> Exp -> LiftM Exp +liftFunction :: VName -> [TypeParam] -> [Pat] -> StructType -> Exp -> LiftM Exp liftFunction fname tparams params ret funbody = do -- Find free variables global <- gets stateGlobal let bound = global - <> foldMap patternNames params + <> foldMap patNames params <> S.fromList (map typeParamName tparams) - <> existentials funbody free = - let immediate_free = FV.freeVars funbody `FV.without` bound + let immediate_free = FV.freeVars funbody `FV.without` (bound <> existentials funbody) sizes_in_free = foldMap typeDimNames $ M.elems $ FV.unNameSet immediate_free 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 @@ -9,7 +9,7 @@ ( InternaliseM, runInternaliseM, throwError, - VarSubstitutions, + VarSubsts, InternaliseEnv (..), FunInfo, substitutingVars, @@ -48,10 +48,10 @@ -- | A mapping from external variable names to the corresponding -- internalised subexpressions. -type VarSubstitutions = M.Map VName [SubExp] +type VarSubsts = M.Map VName [SubExp] data InternaliseEnv = InternaliseEnv - { envSubsts :: VarSubstitutions, + { envSubsts :: VarSubsts, envDoBoundsChecks :: Bool, envSafe :: Bool, envAttrs :: Attrs @@ -60,14 +60,14 @@ data InternaliseState = InternaliseState { stateNameSource :: VNameSource, stateFunTable :: FunTable, - stateConstSubsts :: VarSubstitutions, + stateConstSubsts :: VarSubsts, stateConstScope :: Scope SOACS, stateFuns :: [FunDef SOACS] } newtype InternaliseM a = InternaliseM - (BinderT SOACS (ReaderT InternaliseEnv (State InternaliseState)) a) + (BuilderT SOACS (ReaderT InternaliseEnv (State InternaliseState)) a) deriving ( Functor, Applicative, @@ -83,7 +83,7 @@ getNameSource = gets stateNameSource putNameSource src = modify $ \s -> s {stateNameSource = src} -instance MonadBinder InternaliseM where +instance MonadBuilder InternaliseM where type Rep InternaliseM = SOACS mkExpDecM pat e = InternaliseM $ mkExpDecM pat e mkBodyM bnds res = InternaliseM $ mkBodyM bnds res @@ -100,7 +100,7 @@ runInternaliseM safe (InternaliseM m) = modifyNameSource $ \src -> let ((_, consts), s) = - runState (runReaderT (runBinderT m mempty) newEnv) (newState src) + runState (runReaderT (runBuilderT m mempty) newEnv) (newState src) in ((consts, reverse $ stateFuns s), stateNameSource s) where newEnv = @@ -119,7 +119,7 @@ stateFuns = mempty } -substitutingVars :: VarSubstitutions -> InternaliseM a -> InternaliseM a +substitutingVars :: VarSubsts -> InternaliseM a -> InternaliseM a substitutingVars substs = local $ \env -> env {envSubsts = substs <> envSubsts env} lookupSubst :: VName -> InternaliseM (Maybe [SubExp]) @@ -153,7 +153,7 @@ let stms = bodyStms $ funDefBody fd substs = takeLast (length (funDefRetType fd)) $ - bodyResult $ funDefBody fd + map resSubExp $ bodyResult $ funDefBody fd addStms stms modify $ \s -> s @@ -174,7 +174,7 @@ SubExp -> ErrorMsg SubExp -> SrcLoc -> - InternaliseM Certificates + InternaliseM Certs assert desc se msg loc = assertingOne $ do attrs <- asks $ attrsForAssert . envAttrs attributing attrs $ @@ -184,8 +184,8 @@ -- | Execute the given action if 'envDoBoundsChecks' is true, otherwise -- just return an empty list. asserting :: - InternaliseM Certificates -> - InternaliseM Certificates + InternaliseM Certs -> + InternaliseM Certs asserting m = do doBoundsChecks <- asks envDoBoundsChecks if doBoundsChecks @@ -196,5 +196,5 @@ -- just return an empty list. assertingOne :: InternaliseM VName -> - InternaliseM Certificates -assertingOne m = asserting $ Certificates . pure <$> m + InternaliseM Certs +assertingOne m = asserting $ Certs . pure <$> m 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 @@ -63,7 +63,7 @@ RecordReplacements ( VName, [TypeParam], - [Pattern], + [Pat], StructType, [VName], Exp, @@ -76,7 +76,7 @@ -- record patterns. type RecordReplacements = M.Map VName RecordReplacement -type RecordReplacement = M.Map Name (VName, PatternType) +type RecordReplacement = M.Map Name (VName, PatType) -- Monomorphization environment mapping names of polymorphic functions -- to a representation of their corresponding function bindings. @@ -264,12 +264,12 @@ then second (mconcat . map replace . S.toList) t else t -sizesForPat :: MonadFreshNames m => Pattern -> m ([VName], Pattern) +sizesForPat :: MonadFreshNames m => Pat -> m ([VName], Pat) sizesForPat pat = do (params', sizes) <- runStateT (astMap tv pat) [] return (sizes, params') where - tv = identityMapper {mapOnPatternType = bitraverse onDim pure} + tv = identityMapper {mapOnPatType = bitraverse onDim pure} onDim (AnyDim _) = do v <- lift $ newVName "size" modify (v :) @@ -289,7 +289,7 @@ transformAppExp (Coerce e tp loc) res = AppExp <$> (Coerce <$> transformExp e <*> pure tp <*> pure loc) <*> pure (Info res) transformAppExp (LetPat sizes pat e1 e2 loc) res = do - (pat', rr) <- transformPattern pat + (pat', rr) <- transformPat pat AppExp <$> ( LetPat sizes pat' <$> transformExp e1 <*> withRecordReplacements rr (transformExp e2) @@ -442,6 +442,8 @@ Ascript <$> transformExp e <*> pure tp <*> pure loc transformExp (Negate e loc) = Negate <$> transformExp e <*> pure loc +transformExp (Not e loc) = + Not <$> transformExp e <*> pure loc transformExp (Lambda params e0 decl tp loc) = do e0' <- transformExp e0 return $ Lambda params e0' decl tp loc @@ -508,7 +510,7 @@ transformCase :: Case -> MonoM Case transformCase (CasePat p e loc) = do - (p', rr) <- transformPattern p + (p', rr) <- transformPat p CasePat p' <$> withRecordReplacements rr (transformExp e) <*> pure loc transformDimIndex :: DimIndexBase Info VName -> MonoM (DimIndexBase Info VName) @@ -523,10 +525,10 @@ Exp -> Maybe Exp -> Maybe Exp -> - PatternType -> + PatType -> (PName, StructType, Maybe VName) -> (PName, StructType, Maybe VName) -> - (PatternType, [VName]) -> + (PatType, [VName]) -> SrcLoc -> MonoM Exp desugarBinOpSection op e_left e_right t (xp, xtype, xext) (yp, ytype, yext) (rettype, retext) loc = do @@ -576,7 +578,7 @@ (v, pat, var_e) <- patAndVar argtype return (v, id, var_e, [pat]) -desugarProjectSection :: [Name] -> PatternType -> SrcLoc -> MonoM Exp +desugarProjectSection :: [Name] -> PatType -> SrcLoc -> MonoM Exp desugarProjectSection fields (Scalar (Arrow _ _ t1 t2)) loc = do p <- newVName "project_p" let body = foldl project (Var (qualName p) (Info t1) mempty) fields @@ -594,7 +596,7 @@ ++ pretty field desugarProjectSection _ t _ = error $ "desugarOpSection: not a function type: " ++ pretty t -desugarIndexSection :: [DimIndex] -> PatternType -> SrcLoc -> MonoM Exp +desugarIndexSection :: [DimIndex] -> PatType -> SrcLoc -> MonoM Exp desugarIndexSection idxs (Scalar (Arrow _ _ t1 t2)) loc = do p <- newVName "index_i" let body = AppExp (Index (Var (qualName p) (Info t1) loc) idxs loc) (Info (AppRes t2 [])) @@ -617,43 +619,43 @@ e' = unfoldLetFuns rest e e_t = typeOf e' -transformPattern :: Pattern -> MonoM (Pattern, RecordReplacements) -transformPattern (Id v (Info (Scalar (Record fs))) loc) = do +transformPat :: Pat -> MonoM (Pat, RecordReplacements) +transformPat (Id v (Info (Scalar (Record fs))) loc) = do let fs' = M.toList fs (fs_ks, fs_ts) <- fmap unzip $ forM fs' $ \(f, ft) -> (,) <$> newVName (nameToString f) <*> transformType ft return - ( RecordPattern + ( RecordPat (zip (map fst fs') (zipWith3 Id fs_ks (map Info fs_ts) $ repeat loc)) loc, M.singleton v $ M.fromList $ zip (map fst fs') $ zip fs_ks fs_ts ) -transformPattern (Id v t loc) = return (Id v t loc, mempty) -transformPattern (TuplePattern pats loc) = do - (pats', rrs) <- unzip <$> mapM transformPattern pats - return (TuplePattern pats' loc, mconcat rrs) -transformPattern (RecordPattern fields loc) = do +transformPat (Id v t loc) = return (Id v t loc, mempty) +transformPat (TuplePat pats loc) = do + (pats', rrs) <- unzip <$> mapM transformPat pats + return (TuplePat pats' loc, mconcat rrs) +transformPat (RecordPat fields loc) = do let (field_names, field_pats) = unzip fields - (field_pats', rrs) <- unzip <$> mapM transformPattern field_pats - return (RecordPattern (zip field_names field_pats') loc, mconcat rrs) -transformPattern (PatternParens pat loc) = do - (pat', rr) <- transformPattern pat - return (PatternParens pat' loc, rr) -transformPattern (Wildcard (Info t) loc) = do + (field_pats', rrs) <- unzip <$> mapM transformPat field_pats + return (RecordPat (zip field_names field_pats') loc, mconcat rrs) +transformPat (PatParens pat loc) = do + (pat', rr) <- transformPat pat + return (PatParens pat' loc, rr) +transformPat (Wildcard (Info t) loc) = do t' <- transformType t return (wildcard t' loc, mempty) -transformPattern (PatternAscription pat td loc) = do - (pat', rr) <- transformPattern pat - return (PatternAscription pat' td loc, rr) -transformPattern (PatternLit e t loc) = return (PatternLit e t loc, mempty) -transformPattern (PatternConstr name t all_ps loc) = do - (all_ps', rrs) <- unzip <$> mapM transformPattern all_ps - return (PatternConstr name t all_ps' loc, mconcat rrs) +transformPat (PatAscription pat td loc) = do + (pat', rr) <- transformPat pat + return (PatAscription pat' td loc, rr) +transformPat (PatLit e t loc) = return (PatLit e t loc, mempty) +transformPat (PatConstr name t all_ps loc) = do + (all_ps', rrs) <- unzip <$> mapM transformPat all_ps + return (PatConstr name t all_ps' loc, mconcat rrs) -wildcard :: PatternType -> SrcLoc -> Pattern +wildcard :: PatType -> SrcLoc -> Pat wildcard (Scalar (Record fs)) loc = - RecordPattern (zip (M.keys fs) $ map ((`Wildcard` loc) . Info) $ M.elems fs) loc + RecordPat (zip (M.keys fs) $ map ((`Wildcard` loc) . Info) $ M.elems fs) loc wildcard t loc = Wildcard (Info t) loc @@ -718,15 +720,15 @@ (substs, t_shape_params) <- typeSubstsM loc (noSizes bind_t) $ noNamedParams t let substs' = M.map (Subst []) substs rettype' = substTypesAny (`M.lookup` substs') rettype - substPatternType = + substPatType = substTypesAny (fmap (fmap fromStruct) . (`M.lookup` substs')) - params' = map (substPattern entry substPatternType) params + params' = map (substPat entry substPatType) params bind_t' = substTypesAny (`M.lookup` substs') bind_t (shape_params_explicit, shape_params_implicit) = partition ((`S.member` mustBeExplicit bind_t') . typeParamName) $ shape_params ++ t_shape_params - (params'', rrs) <- unzip <$> mapM transformPattern params' + (params'', rrs) <- unzip <$> mapM transformPat params' mapM_ noticeDims $ rettype : map patternStructType params'' @@ -763,7 +765,7 @@ mapOnName = pure, mapOnQualName = pure, mapOnStructType = pure . applySubst substs, - mapOnPatternType = pure . applySubst substs + mapOnPatType = pure . applySubst substs } shapeParam tp = Id (typeParamName tp) (Info i64) $ srclocOf tp @@ -836,20 +838,20 @@ onDim (MonoAnon v) = pure $ AnyDim v -- Perform a given substitution on the types in a pattern. -substPattern :: Bool -> (PatternType -> PatternType) -> Pattern -> Pattern -substPattern entry f pat = case pat of - TuplePattern pats loc -> TuplePattern (map (substPattern entry f) pats) loc - RecordPattern fs loc -> RecordPattern (map substField fs) loc +substPat :: Bool -> (PatType -> PatType) -> Pat -> Pat +substPat entry f pat = case pat of + TuplePat pats loc -> TuplePat (map (substPat entry f) pats) loc + RecordPat fs loc -> RecordPat (map substField fs) loc where - substField (n, p) = (n, substPattern entry f p) - PatternParens p loc -> PatternParens (substPattern entry f p) loc + substField (n, p) = (n, substPat entry f p) + PatParens p loc -> PatParens (substPat entry f p) loc Id vn (Info tp) loc -> Id vn (Info $ f tp) loc Wildcard (Info tp) loc -> Wildcard (Info $ f tp) loc - PatternAscription p td loc - | entry -> PatternAscription (substPattern False f p) td loc - | otherwise -> substPattern False f p - PatternLit e (Info tp) loc -> PatternLit e (Info $ f tp) loc - PatternConstr n (Info tp) ps loc -> PatternConstr n (Info $ f tp) ps loc + PatAscription p td loc + | entry -> PatAscription (substPat False f p) td loc + | otherwise -> substPat False f p + PatLit e (Info tp) loc -> PatLit e (Info $ f tp) loc + PatConstr n (Info tp) ps loc -> PatConstr n (Info $ f tp) ps loc toPolyBinding :: ValBind -> PolyBinding toPolyBinding (ValBind _ name _ (Info (rettype, retext)) tparams params body _ attrs loc) = @@ -865,7 +867,7 @@ mapOnName = pure, mapOnQualName = pure, mapOnStructType = pure . applySubst (`M.lookup` subs), - mapOnPatternType = pure . applySubst (`M.lookup` subs) + mapOnPatType = pure . applySubst (`M.lookup` subs) } body' <- astMap mapper body @@ -873,7 +875,7 @@ return valbind { valBindRetType = Info (applySubst (`M.lookup` subs) rettype, retext), - valBindParams = map (substPattern entry $ applySubst (`M.lookup` subs)) pats, + valBindParams = map (substPat entry $ applySubst (`M.lookup` subs)) pats, valBindBody = body' } 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 @@ -32,7 +32,8 @@ mmBlkRegTiling :: Stm GPU -> TileM (Maybe (Stms GPU, Stm GPU)) mmBlkRegTiling (Let pat aux (Op (SegOp (SegMap SegThread {} seg_space ts old_kbody)))) - | KernelBody () kstms [Returns ResultMaySimplify (Var res_nm)] <- old_kbody, + | KernelBody () kstms [Returns ResultMaySimplify cs (Var res_nm)] <- old_kbody, + cs == mempty, -- check kernel has one result of primitive type [res_tp] <- ts, primType res_tp, @@ -59,7 +60,7 @@ -- exactly one of the two innermost dimensions of the kernel Just var_dims <- isInvarTo1of2InnerDims mempty seg_space variance arrs, -- get the variables on which the first result of redomap depends on - [redomap_orig_res] <- patternValueElements pat_redomap, + [redomap_orig_res] <- patElems pat_redomap, Just res_red_var <- M.lookup (patElemName redomap_orig_res) variance, -- variance of the reduce result -- we furthermore check that code1 is only formed by @@ -90,7 +91,7 @@ red_t <- subExpType red_ne ---- in this binder: host code and outer seggroup (ie. the new kernel) ---- - (new_kernel, host_stms) <- runBinder $ do + (new_kernel, host_stms) <- runBuilder $ do -- host code tk_name <- nameFromString . pretty <$> newVName "Tk" @@ -132,7 +133,7 @@ gid_flat <- newVName "gid_flat" ---- in this binder: outer seggroup ---- - (ret_seggroup, stms_seggroup) <- runBinder $ do + (ret_seggroup, stms_seggroup) <- runBuilder $ do iii <- letExp "iii" =<< toExp (le64 gid_y * pe64 ty_ry) jjj <- letExp "jjj" =<< toExp (le64 gid_x * pe64 tx_rx) @@ -144,7 +145,7 @@ css'' <- update' "css" css_merge' [i, j] red_ne resultBodyM [Var css''] resultBodyM [Var css'] - return [Var css] + return [varRes css] let [cssss] = cssss_list a_loc_init <- scratch "A_loc" map_t1 [a_loc_sz] @@ -278,7 +279,7 @@ index "B_loc_elem" b_loc [b_loc_ind] >>= update "bsss" bsss_merge [j] resultBodyM [Var bsss] - return $ map Var [asss, bsss] + return $ varsRes [asss, bsss] let [asss, bsss] = reg_mem @@ -323,7 +324,7 @@ ) (resultBodyM [Var css_merge']) resultBodyM [Var css] - return [Var css] + return [varRes css] resultBodyM $ map Var redomap_res ) @@ -388,7 +389,7 @@ rss'' <- update' "rss" rss_merge' [i, j] res_el resultBodyM [Var rss''] resultBodyM [Var rss'] - return [Var rss] + return [varRes rss] let rssss : _ = rssss_list return rssss @@ -407,7 +408,7 @@ new_shape = concat [ones, block_dims, ones, rest_dims] letExp "res_reshaped" $ BasicOp $ Reshape (map DimNew new_shape) epilogue_res - return [RegTileReturns regtile_ret_dims epilogue_res'] + return [RegTileReturns mempty regtile_ret_dims epilogue_res'] let level' = SegGroup (Count grid_size) (Count group_size) SegNoVirt space' = SegSpace gid_flat (rem_outer_dims ++ [(gid_y, gridDim_y), (gid_x, gridDim_x)]) @@ -416,39 +417,39 @@ return $ Just (host_stms, new_kernel) mmBlkRegTiling _ = return Nothing -ceilDiv :: MonadBinder 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 -scratch :: MonadBinder 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 -- index an array with indices given in outer_indices; any inner -- dims of arr not indexed by outer_indices are sliced entirely -index :: MonadBinder 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 shape = arrayShape arr_t inner_dims = shapeDims $ stripDims (length outer_indices) shape untouched d = DimSlice (intConst Int64 0) d (intConst Int64 1) inner_slices = map untouched inner_dims - indices = map (DimFix . Var) outer_indices ++ inner_slices - letExp se_desc $ BasicOp $ Index arr indices + slice = Slice $ map (DimFix . Var) outer_indices ++ inner_slices + letExp se_desc $ BasicOp $ Index arr slice -update :: MonadBinder m => String -> VName -> [VName] -> VName -> m VName +update :: MonadBuilder m => String -> VName -> [VName] -> VName -> m VName update se_desc arr indices new_elem = update' se_desc arr indices (Var new_elem) -update' :: MonadBinder 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 arr (map (DimFix . Var) indices) new_elem + letExp se_desc $ BasicOp $ Update Unsafe arr (Slice $ map (DimFix . Var) indices) new_elem forLoop' :: SubExp -> -- loop var [VName] -> -- loop inits ( VName -> [VName] -> -- (loop var -> loop inits -> loop body) - Binder GPU (Body GPU) + Builder GPU (Body GPU) ) -> - Binder GPU [VName] + Builder GPU [VName] forLoop' i_bound merge body = do i <- newVName "i" -- could give this as arg to the function let loop_form = ForLoop i Int64 i_bound [] @@ -457,17 +458,17 @@ loop_inits <- mapM (\merge_t -> newParam "merge" $ toDecl merge_t Unique) merge_ts loop_body <- - runBodyBinder . inScopeOf loop_form . localScope (scopeOfFParams loop_inits) $ + runBodyBuilder . inScopeOf loop_form . localScope (scopeOfFParams loop_inits) $ body i $ map paramName loop_inits letTupExp "loop" $ - DoLoop [] (zip loop_inits $ map Var merge) loop_form loop_body + DoLoop (zip loop_inits $ map Var merge) loop_form loop_body forLoop :: SubExp -> [VName] -> - (VName -> [VName] -> Binder GPU (Body GPU)) -> - Binder GPU VName + (VName -> [VName] -> Builder GPU (Body GPU)) -> + Builder GPU VName forLoop i_bound merge body = do res_list <- forLoop' i_bound merge body return $ head res_list @@ -486,9 +487,7 @@ rebindLambda lam new_params res_names = stmsFromList ( zipWith - ( \ident new_param -> - mkLet [] [ident] $ BasicOp $ SubExp $ Var new_param - ) + (\ident new_param -> mkLet [ident] $ BasicOp $ SubExp $ Var new_param) idents new_params ) @@ -503,8 +502,8 @@ lam_params res_cpy_stms = zipWith - ( \res_name lam_res -> - mkLet [] [Ident res_name lam_ret_type] $ BasicOp $ SubExp lam_res + ( \res_name (SubExpRes cs lam_res) -> + certify cs $ mkLet [Ident res_name lam_ret_type] $ BasicOp $ SubExp lam_res ) res_names lam_ress @@ -573,13 +572,13 @@ Maybe (Stms GPU, M.Map VName (Stm GPU)) processIndirections arrs _ acc stm@(Let patt _ (BasicOp (Index _ _))) | Just (ss, tab) <- acc, - [p] <- patternValueElements patt, + [p] <- patElems patt, p_nm <- patElemName p, nameIn p_nm arrs = Just (ss, M.insert p_nm stm tab) processIndirections _ res_red_var acc stm'@(Let patt _ _) | Just (ss, tab) <- acc, - ps <- patternValueElements patt, + ps <- patElems patt, all (\p -> not (nameIn (patElemName p) res_red_var)) ps = Just (ss Seq.|> stm', tab) | otherwise = Nothing @@ -599,7 +598,7 @@ se8 :: SubExp se8 = intConst Int64 8 -getParTiles :: (String, String) -> (Name, Name) -> SubExp -> Binder GPU (SubExp, SubExp) +getParTiles :: (String, String) -> (Name, Name) -> SubExp -> Builder GPU (SubExp, SubExp) getParTiles (t_str, r_str) (t_name, r_name) len_dim = case len_dim of Constant (IntValue (Int64Value 8)) -> @@ -613,7 +612,7 @@ r <- letSubExp r_str $ Op $ SizeOp $ GetSize r_name SizeRegTile return (t, r) -getSeqTile :: String -> Name -> SubExp -> SubExp -> SubExp -> Binder GPU SubExp +getSeqTile :: String -> Name -> SubExp -> SubExp -> SubExp -> Builder GPU SubExp getSeqTile tk_str tk_name len_dim ty tx = case (tx, ty) of (Constant (IntValue (Int64Value v_x)), Constant (IntValue (Int64Value v_y))) -> @@ -728,7 +727,7 @@ -- exactly one of the two innermost dimensions of the kernel Just _ <- isInvarTo2of3InnerDims mempty space variance inp_soac_arrs, -- get the free variables on which the result of redomap depends on - redomap_orig_res <- patternValueElements pat_redomap, + redomap_orig_res <- patElems pat_redomap, res_red_var <- -- variance of the reduce result mconcat $ mapMaybe ((`M.lookup` variance) . patElemName) redomap_orig_res, mempty /= res_red_var, @@ -751,11 +750,10 @@ -- (for sanity sake, they should be) ker_res_nms <- mapMaybe getResNm kres, length ker_res_nms == length kres, - Pattern [] _ <- pat, all primType kertp, all (variantToDim variance gtid_z) ker_res_nms = do -- HERE STARTS THE IMPLEMENTATION: - (new_kernel, host_stms) <- runBinder $ do + (new_kernel, host_stms) <- runBuilder $ do -- host code -- process the z-variant arrays that need transposition; -- these "manifest" statements should come before the kernel @@ -791,7 +789,7 @@ gid_flat <- newVName "gid_flat" ---- in this binder: outer seggroup ---- - (ret_seggroup, stms_seggroup) <- runBinder $ do + (ret_seggroup, stms_seggroup) <- runBuilder $ do ii <- letExp "ii" =<< toExp (le64 gid_z * pe64 rz) jj1 <- letExp "jj1" =<< toExp (le64 gid_y * pe64 ty) jj2 <- letExp "jj2" =<< toExp (le64 gid_x * pe64 tx) @@ -803,7 +801,7 @@ css <- forLoop rz [css_init] $ \i [css_merge] -> do css' <- update' "css" css_merge [i] red_ne resultBodyM [Var css'] - return $ Var css + return $ varRes css -- scratch the shared-memory arrays corresponding to the arrays that are -- input to the redomap and are invariant to the outermost parallel dimension. @@ -824,7 +822,7 @@ ltid_flat <- newVName "ltid_flat" ltid <- newVName "ltid" let segspace = SegSpace ltid_flat [(ltid, group_size)] - ((res_v, res_i), stms) <- runBinder $ do + ((res_v, res_i), stms) <- runBuilder $ do offs <- letExp "offs" =<< toExp (pe64 group_size * le64 tt) loc_ind <- letExp "loc_ind" =<< toExp (le64 ltid + le64 offs) letBindNames [gtid_z] =<< toExp (le64 ii + le64 loc_ind) @@ -848,7 +846,7 @@ --y_tp <- subExpType y_elm return (y_elm, y_ind) - let ret = WriteReturns (Shape [rz]) loc_Y_nm [([DimFix res_i], res_v)] + let ret = WriteReturns mempty (Shape [rz]) loc_Y_nm [(Slice [DimFix res_i], res_v)] let body = KernelBody () stms [ret] res_nms <- @@ -865,7 +863,7 @@ letBindNames [gtid_x] =<< toExp (le64 jj2 + le64 ltid_x) reg_arr_merge_nms_slc <- forM reg_arr_merge_nms $ \reg_arr_nm -> index "res_reg_slc" reg_arr_nm [ltid_y, ltid_x] - letTupExp' "redomap_guarded" + fmap subExpsRes . letTupExp' "redomap_guarded" =<< eIf (toExp $ le64 gtid_y .<. pe64 d_Ky .&&. le64 gtid_x .<. pe64 d_Kx) ( do @@ -925,11 +923,11 @@ segMap3D "rssss" segthd_lvl ResultPrivate (se1, ty, tx) $ \(_ltid_z, ltid_y, ltid_x) -> forM (zip kertp redomap_res) $ \(res_tp, res) -> do rss_init <- scratch "rss_init" (elemType res_tp) [rz, se1, se1] - fmap Var $ + fmap varRes $ forLoop rz [rss_init] $ \i [rss] -> do - let slice = [DimFix $ Var i, DimFix se0, DimFix se0] + let slice = Slice [DimFix $ Var i, DimFix se0, DimFix se0] thread_res <- index "thread_res" res [ltid_y, ltid_x, i] - rss' <- letSubExp "rss" $ BasicOp $ Update rss slice $ Var thread_res + rss' <- letSubExp "rss" $ BasicOp $ Update Unsafe rss slice $ Var thread_res resultBodyM [rss'] else segMap3D "rssss" segthd_lvl ResultPrivate (se1, ty, tx) $ \(_ltid_z, ltid_y, ltid_x) -> do letBindNames [gtid_y] =<< toExp (le64 jj1 + le64 ltid_y) @@ -956,10 +954,10 @@ ) (eBody $ map eBlank kertp) rss' <- forM (zip res_els rss_merge) $ \(res_el, rs_merge) -> do - let slice = [DimFix $ Var i, DimFix se0, DimFix se0] - letSubExp "rss" $ BasicOp $ Update rs_merge slice res_el + let slice = Slice [DimFix $ Var i, DimFix se0, DimFix se0] + letSubExp "rss" $ BasicOp $ Update Unsafe rs_merge slice res_el resultBodyM rss' - return $ map Var rss + return $ varsRes rss ---------------------------------------------------------------- -- Finally, reshape the result arrays for the RegTileReturn --- @@ -979,32 +977,32 @@ new_shape = concat [ones, block_dims, ones, rest_dims] letExp "res_reshaped" $ BasicOp $ Reshape (map DimNew new_shape) res - return $ map (RegTileReturns regtile_ret_dims) epilogue_res' - -- END (ret_seggroup, stms_seggroup) <- runBinder $ do + return $ map (RegTileReturns mempty regtile_ret_dims) epilogue_res' + -- END (ret_seggroup, stms_seggroup) <- runBuilder $ do let level' = SegGroup (Count grid_size) (Count group_size) SegNoVirt space' = SegSpace gid_flat (rem_outer_dims ++ [(gid_z, gridDim_z), (gid_y, gridDim_y), (gid_x, gridDim_x)]) kbody' = KernelBody () stms_seggroup ret_seggroup return $ Let pat aux $ Op $ SegOp $ SegMap level' space' kertp kbody' - -- END (new_kernel, host_stms) <- runBinder $ do + -- END (new_kernel, host_stms) <- runBuilder $ do return $ Just (host_stms, new_kernel) where - getResNm (Returns ResultMaySimplify (Var res_nm)) = Just res_nm + getResNm (Returns ResultMaySimplify _ (Var res_nm)) = Just res_nm getResNm _ = Nothing - limitTile :: String -> SubExp -> SubExp -> Binder GPU SubExp + limitTile :: String -> SubExp -> SubExp -> Builder GPU SubExp limitTile t_str t d_K = letSubExp t_str $ BasicOp $ BinOp (SMin Int64) t d_K insertTranspose :: VarianceTable -> (VName, SubExp) -> (M.Map VName (Stm GPU), M.Map VName (PrimType, Stm GPU)) -> (VName, Stm GPU) -> - Binder GPU (M.Map VName (Stm GPU), M.Map VName (PrimType, Stm GPU)) + Builder GPU (M.Map VName (Stm GPU), M.Map VName (PrimType, Stm GPU)) insertTranspose variance (gidz, _) (tab_inn, tab_out) (p_nm, stm@(Let patt yy (BasicOp (Index arr_nm slc)))) - | [p] <- patternValueElements patt, + | [p] <- patElems patt, ptp <- elemType $ patElemType p, p_nm == patElemName p = - case L.findIndices (variantSliceDim variance gidz) slc of + case L.findIndices (variantSliceDim variance gidz) (unSlice slc) of [] -> return (M.insert p_nm stm tab_inn, tab_out) i : _ -> do arr_tp <- lookupType arr_nm 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 @@ -37,6 +37,7 @@ import Control.Monad.Reader import qualified Data.Map.Strict as M +import Data.Maybe (isJust) import Futhark.Analysis.Alias import Futhark.IR import Futhark.IR.Aliases @@ -46,7 +47,7 @@ removeProgAliases, removeStmAliases, ) -import qualified Futhark.IR.GPU.Kernel as Kernel +import qualified Futhark.IR.GPU as GPU import qualified Futhark.IR.MC as MC import qualified Futhark.IR.Mem as Memory import Futhark.IR.Prop.Aliases @@ -139,13 +140,15 @@ runReader (cseInBody ds $ funDefBody fundec) $ newCSEState cse_arrays } where - -- XXX: we treat every result as a consumption here, because we + -- XXX: we treat every non-entry result as a consumption here, because we -- our core language is not strong enough to fully capture the -- aliases we want, so we are turning some parts off (see #803, -- #1241, and the related comment in TypeCheck.hs). This is not a -- practical problem while we still perform such aggressive -- inlining. - ds = map retDiet $ funDefRetType fundec + ds + | isJust $ funDefEntryPoint fundec = map (diet . declExtTypeOf) $ funDefRetType fundec + | otherwise = map retDiet $ funDefRetType fundec retDiet t | primType $ declExtTypeOf t = Observe | otherwise = Consume @@ -186,16 +189,19 @@ cseInStms _ [] m = do a <- m return (mempty, a) -cseInStms consumed (bnd : bnds) m = - cseInStm consumed bnd $ \bnd' -> do - (bnds', a) <- cseInStms consumed bnds m - bnd'' <- mapM nestedCSE bnd' - return (stmsFromList bnd'' <> bnds', a) +cseInStms consumed (stm : stms) m = + cseInStm consumed stm $ \stm' -> do + (stms', a) <- cseInStms consumed stms m + stm'' <- mapM nestedCSE stm' + return (stmsFromList stm'' <> stms', a) where - nestedCSE bnd' = do - let ds = map patElemDiet $ patternValueElements $ stmPattern bnd' - e <- mapExpM (cse ds) $ stmExp bnd' - return bnd' {stmExp = e} + nestedCSE stm' = do + let ds = + case stmExp stm' of + DoLoop merge _ _ -> map (diet . declTypeOf . fst) merge + _ -> map patElemDiet $ patElems $ stmPat stm' + e <- mapExpM (cse ds) $ stmExp stm' + return stm' {stmExp = e} cse ds = identityMapper @@ -217,15 +223,15 @@ CSEState (esubsts, nsubsts) cse_arrays <- ask let e' = substituteNames nsubsts e pat' = substituteNames nsubsts pat - if any (bad cse_arrays) $ patternValueElements pat + if any (bad cse_arrays) $ patElems pat then m [Let pat' (StmAux cs attrs edec) e'] else case M.lookup (edec, e') esubsts of Just subpat -> local (addNameSubst pat' subpat) $ do let lets = - [ Let (Pattern [] [patElem']) (StmAux cs attrs edec) $ + [ Let (Pat [patElem']) (StmAux cs attrs edec) $ BasicOp $ SubExp $ Var $ patElemName patElem - | (name, patElem) <- zip (patternNames pat') $ patternElements subpat, + | (name, patElem) <- zip (patNames pat') $ patElems subpat, let patElem' = patElem {patElemName = name} ] m lets @@ -242,7 +248,7 @@ type ExpressionSubstitutions rep = M.Map (ExpDec rep, Exp rep) - (Pattern rep) + (Pat rep) type NameSubstitutions = M.Map VName VName @@ -254,16 +260,16 @@ newCSEState :: Bool -> CSEState rep newCSEState = CSEState (M.empty, M.empty) -mkSubsts :: PatternT dec -> PatternT dec -> M.Map VName VName -mkSubsts pat vs = M.fromList $ zip (patternNames pat) (patternNames vs) +mkSubsts :: PatT dec -> PatT dec -> M.Map VName VName +mkSubsts pat vs = M.fromList $ zip (patNames pat) (patNames vs) -addNameSubst :: PatternT dec -> PatternT dec -> CSEState rep -> CSEState rep +addNameSubst :: PatT dec -> PatT dec -> CSEState rep -> CSEState rep addNameSubst pat subpat (CSEState (esubsts, nsubsts) cse_arrays) = CSEState (esubsts, mkSubsts pat subpat `M.union` nsubsts) cse_arrays addExpSubst :: ASTRep rep => - Pattern rep -> + Pat rep -> ExpDec rep -> Exp rep -> CSEState rep -> @@ -290,10 +296,10 @@ CSEInOp (Op rep), CSEInOp op ) => - CSEInOp (Kernel.HostOp rep op) + CSEInOp (GPU.HostOp rep op) where - cseInOp (Kernel.SegOp op) = Kernel.SegOp <$> cseInOp op - cseInOp (Kernel.OtherOp op) = Kernel.OtherOp <$> cseInOp op + cseInOp (GPU.SegOp op) = GPU.SegOp <$> cseInOp op + cseInOp (GPU.OtherOp op) = GPU.OtherOp <$> cseInOp op cseInOp x = return x instance @@ -311,20 +317,20 @@ instance (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => - CSEInOp (Kernel.SegOp lvl rep) + CSEInOp (GPU.SegOp lvl rep) where cseInOp = subCSE - . Kernel.mapSegOpM - (Kernel.SegOpMapper return cseInLambda cseInKernelBody return return) + . GPU.mapSegOpM + (GPU.SegOpMapper return cseInLambda cseInKernelBody return return) cseInKernelBody :: (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => - Kernel.KernelBody rep -> - CSEM rep (Kernel.KernelBody rep) -cseInKernelBody (Kernel.KernelBody bodydec bnds res) = do + GPU.KernelBody rep -> + CSEM rep (GPU.KernelBody rep) +cseInKernelBody (GPU.KernelBody bodydec bnds res) = do Body _ bnds' _ <- cseInBody (map (const Observe) res) $ Body bodydec bnds [] - return $ Kernel.KernelBody bodydec bnds' res + return $ GPU.KernelBody bodydec bnds' res instance CSEInOp op => CSEInOp (Memory.MemOp op) where cseInOp o@Memory.Alloc {} = return o 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 @@ -11,22 +11,76 @@ -- dead at the end of the loop. If it is not, we may cause data -- hazards. -- --- This module rewrites loops with memory block merge parameters such --- that each memory block is copied at the end of the iteration, thus --- ensuring that any allocation inside the loop is dead at the end of --- the loop. This is only possible for allocations whose size is --- loop-invariant, although the initial size may differ from the size --- produced by the loop result. +-- This pass tries to rewrite loops with memory parameters. +-- Specifically, it takes loops of this form: -- --- Additionally, inside parallel kernels we also copy the initial --- value. This has the effect of making the memory block returned by --- the array non-existential, which is important for later memory --- expansion to work. +-- @ +-- loop {..., A_mem, ..., A, ...} ... do { +-- ... +-- let A_out_mem = alloc(...) -- stores A_out +-- in {..., A_out_mem, ..., A_out, ...} +-- } +-- @ +-- +-- and turns them into +-- +-- @ +-- let A_in_mem = alloc(...) +-- let A_out_mem = alloc(...) +-- let A_in = copy A -- in A_in_mem +-- loop {..., A_in_mem, A_out_mem, ..., A=A_in, ...} ... do { +-- ... +-- in {..., A_out_mem, A_mem, ..., A_out, ...} +-- } +-- @ +-- +-- The result is essentially "pointer swapping" between the two memory +-- initial blocks @A_mem@ and @A_out_mem@. The invariant is that the +-- array is always stored in the "first" memory block at the beginning +-- of the loop (and also in the final result). We do need to add an +-- extra element to the pattern, however. The initial copy of @A@ +-- could be elided if @A@ is unique (thus @A_in_mem=A_mem@). This is +-- because only then is it safe to use @A_mem@ to store loop results. +-- We don't currently do this. +-- +-- Unfortunately, not all loops fit the pattern above. In particular, +-- a nested loop that has been transformed as such does not! +-- Therefore we also have another double buffering strategy, that +-- turns +-- +-- @ +-- loop {..., A_mem, ..., A, ...} ... do { +-- ... +-- let A_out_mem = alloc(...) +-- -- A in A_out_mem +-- in {..., A_out_mem, ..., A, ...} +-- } +-- @ +-- +-- into +-- +-- @ +-- let A_res_mem = alloc(...) +-- loop {..., A_mem, ..., A, ...} ... do { +-- ... +-- let A_out_mem = alloc(...) +-- -- A in A_out_mem +-- let A' = copy A +-- -- A' in A_res_mem +-- in {..., A_res_mem, ..., A, ...} +-- } +-- @ +-- +-- The allocation of A_out_mem can then be hoisted out because it is +-- dead at the end of the loop. This always works as long as +-- A_out_mem has a loop-invariant allocation size, but requires a copy +-- per iteration (and an initial one, elided above). module Futhark.Optimise.DoubleBuffer (doubleBufferGPU, doubleBufferMC) where import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer +import Data.Bifunctor import Data.List (find) import qualified Data.Map.Strict as M import Data.Maybe @@ -37,7 +91,8 @@ import Futhark.Pass import Futhark.Pass.ExplicitAllocations (arraySizeInBytesExp) import Futhark.Pass.ExplicitAllocations.GPU () -import Futhark.Util (maybeHead) +import Futhark.Transform.Substitute +import Futhark.Util (mapAccumLM, maybeHead) -- | The pass for GPU kernels. doubleBufferGPU :: Pass GPUMem GPUMem @@ -48,7 +103,7 @@ doubleBufferMC = doubleBuffer optimiseMCOp -- | The double buffering pass definition. -doubleBuffer :: Mem rep => OptimiseOp rep -> Pass rep rep +doubleBuffer :: Mem rep inner => OptimiseOp rep -> Pass rep rep doubleBuffer onOp = Pass { passName = "Double buffer", @@ -58,22 +113,20 @@ where optimise scope stms = modifyNameSource $ \src -> let m = - runDoubleBufferM $ - localScope scope $ - fmap stmsFromList $ optimiseStms $ stmsToList stms + runDoubleBufferM $ localScope scope $ optimiseStms $ stmsToList stms in runState (runReaderT m env) src env = Env mempty doNotTouchLoop onOp - doNotTouchLoop ctx val body = return (mempty, ctx, val, body) + doNotTouchLoop pat merge body = pure (mempty, pat, merge, body) type OptimiseLoop rep = - [(FParam rep, SubExp)] -> + Pat rep -> [(FParam rep, SubExp)] -> Body rep -> DoubleBufferM rep - ( [Stm rep], - [(FParam rep, SubExp)], + ( Stms rep, + Pat rep, [(FParam rep, SubExp)], Body rep ) @@ -100,27 +153,27 @@ optimiseBody :: ASTRep rep => Body rep -> DoubleBufferM rep (Body rep) optimiseBody body = do - bnds' <- optimiseStms $ stmsToList $ bodyStms body - return $ body {bodyStms = stmsFromList bnds'} + stms' <- optimiseStms $ stmsToList $ bodyStms body + pure $ body {bodyStms = stms'} -optimiseStms :: ASTRep rep => [Stm rep] -> DoubleBufferM rep [Stm rep] -optimiseStms [] = return [] +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 - return $ e_es ++ es' + pure $ e_es <> es' -optimiseStm :: forall rep. ASTRep rep => Stm rep -> DoubleBufferM rep [Stm rep] -optimiseStm (Let pat aux (DoLoop ctx val form body)) = do +optimiseStm :: forall rep. ASTRep rep => Stm rep -> DoubleBufferM rep (Stms rep) +optimiseStm (Let pat aux (DoLoop merge form body)) = do body' <- - localScope (scopeOf form <> scopeOfFParams (map fst $ ctx ++ val)) $ + localScope (scopeOf form <> scopeOfFParams (map fst merge)) $ optimiseBody body opt_loop <- asks envOptimiseLoop - (bnds, ctx', val', body'') <- opt_loop ctx val body' - return $ bnds ++ [Let pat aux $ DoLoop ctx' val' form body''] + (stms, pat', merge', body'') <- opt_loop pat merge body' + pure $ stms <> oneStm (Let pat' aux $ DoLoop merge' form body'') optimiseStm (Let pat aux e) = do onOp <- asks envOptimiseOp - pure . Let pat aux <$> mapExpM (optimise onOp) e + oneStm . Let pat aux <$> mapExpM (optimise onOp) e where optimise onOp = identityMapper @@ -139,7 +192,7 @@ mapOnSegOpBody = optimiseKernelBody } inSegOp env = env {envOptimiseLoop = optimiseLoop} -optimiseGPUOp op = return op +optimiseGPUOp op = pure op optimiseMCOp :: OptimiseOp MCMem optimiseMCOp (Inner (ParOp par_op op)) = @@ -153,7 +206,7 @@ mapOnSegOpBody = optimiseKernelBody } inSegOp env = env {envOptimiseLoop = optimiseLoop} -optimiseMCOp op = return op +optimiseMCOp op = pure op optimiseKernelBody :: ASTRep rep => @@ -161,7 +214,7 @@ DoubleBufferM rep (KernelBody rep) optimiseKernelBody kbody = do stms' <- optimiseStms $ stmsToList $ kernelBodyStms kbody - return $ kbody {kernelBodyStms = stmsFromList stms'} + pure $ kbody {kernelBodyStms = stms'} optimiseLambda :: ASTRep rep => @@ -169,39 +222,119 @@ DoubleBufferM rep (Lambda rep) optimiseLambda lam = do body <- localScope (castScope $ scopeOf lam) $ optimiseBody $ lambdaBody lam - return lam {lambdaBody = body} + pure lam {lambdaBody = body} -type Constraints rep = - ( ASTRep rep, - FParamInfo rep ~ FParamMem, - LParamInfo rep ~ LParamMem, - RetType rep ~ RetTypeMem, - LetDec rep ~ LetDecMem, - BranchType rep ~ BranchTypeMem, +type Constraints rep inner = + ( Mem rep inner, + BuilderOps rep, ExpDec rep ~ (), BodyDec rep ~ (), - OpReturns rep + LetDec rep ~ LetDecMem ) -optimiseLoop :: (Constraints rep, Op rep ~ MemOp inner, BinderOps rep) => OptimiseLoop rep -optimiseLoop ctx val body = do +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 + Let (Pat [pe]) _ (Op (Alloc size _)) + | patElemName pe == needle, + invariant size -> + Just (stm, stms') + _ -> + let bound' = namesFromList (patNames (stmPat stm)) <> bound + in second (oneStm stm <>) <$> extractAllocOf bound' needle stms' + where + invariant Constant {} = True + invariant (Var v) = not $ v `nameIn` bound + +optimiseLoop :: Constraints rep inner => OptimiseLoop rep +optimiseLoop pat merge body = do + (outer_stms_1, pat', merge', body') <- + optimiseLoopBySwitching pat merge body + (outer_stms_2, pat'', merge'', body'') <- + inScopeOf outer_stms_1 $ optimiseLoopByCopying pat' merge' body' + pure (outer_stms_1 <> outer_stms_2, pat'', merge'', body'') + +isArrayIn :: VName -> Param FParamMem -> Bool +isArrayIn x (Param _ (MemArray _ _ _ (ArrayIn y _))) = x == y +isArrayIn _ _ = False + +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')) <- + second unzip3 <$> mapAccumLM check (mempty, body_stms) (zip3 pes merge body_res) + merge'' <- mapM (maybeCopyInitial buffered) $ mconcat merge' + pure (Pat $ mconcat pes', merge'', Body () body_stms' $ mconcat body_res') + pure (outer_stms, pat', merge', body') + where + merge_bound = namesFromList $ map (paramName . fst) merge + + check (buffered, body_stms') (pe, (param, arg), res) + | Mem space <- paramType param, + Var arg_v <- arg, + -- XXX: what happens if there are multiple arrays in the same + -- memory block? + [arr_param] <- filter (isArrayIn (paramName param)) $ map fst merge, + MemArray pt _ _ (ArrayIn _ ixfun) <- paramDec arr_param, + Var res_v <- resSubExp res, + Just (res_v_alloc, body_stms'') <- extractAllocOf merge_bound res_v body_stms' = do + num_bytes <- + letSubExp "num_bytes" =<< toExp (product $ primByteSize pt : IxFun.base ixfun) + arr_mem_in <- + letExp (baseString arg_v <> "_in") $ Op $ Alloc num_bytes space + pe_unused <- + PatElem + <$> newVName (baseString (patElemName pe) <> "_unused") + <*> pure (MemMem space) + param_out <- + Param + <$> newVName (baseString (paramName param) <> "_out") + <*> pure (MemMem space) + addStm res_v_alloc + pure + ( ( M.insert (paramName param) arr_mem_in buffered, + substituteNames (M.singleton res_v (paramName param_out)) body_stms'' + ), + ( [pe, pe_unused], + [(param, Var arr_mem_in), (param_out, resSubExp res)], + [ res {resSubExp = Var $ paramName param_out}, + subExpRes $ Var $ paramName param + ] + ) + ) + | otherwise = + pure + ( (buffered, body_stms'), + ([pe], [(param, arg)], [res]) + ) + + maybeCopyInitial buffered (param@(Param _ (MemArray _ _ _ (ArrayIn mem _))), Var arg) + | Just mem' <- mem `M.lookup` buffered = do + arg_info <- lookupMemInfo arg + case arg_info of + MemArray pt shape u (ArrayIn _ arg_ixfun) -> do + arg_copy <- newVName (baseString arg <> "_dbcopy") + letBind (Pat [PatElem arg_copy $ MemArray pt shape u $ ArrayIn mem' arg_ixfun]) $ + BasicOp $ Copy arg + pure (param, Var arg_copy) + _ -> pure (param, Var arg) + maybeCopyInitial _ (param, arg) = pure (param, arg) + +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. buffered <- doubleBufferMergeParams - (zip (map fst ctx) (bodyResult body)) - (map fst merge) + (zip (map fst merge) (bodyResult body)) (boundInBody body) -- Then create the allocations of the buffers and copies of the -- initial values. (merge', allocs) <- allocStms merge buffered -- Modify the loop body to copy buffered result arrays. let body' = doubleBufferResult (map fst merge) buffered body - (ctx', val') = splitAt (length ctx) merge' - -- Modify the initial merge p - return (allocs, ctx', val', body') - where - merge = ctx ++ val + pure (stmsFromList allocs, pat, merge', body') -- | The booleans indicate whether we should also play with the -- initial merge values. @@ -215,13 +348,13 @@ doubleBufferMergeParams :: MonadFreshNames m => - [(Param FParamMem, SubExp)] -> - [Param FParamMem] -> + [(Param FParamMem, SubExpRes)] -> Names -> m [DoubleBuffer] -doubleBufferMergeParams ctx_and_res val_params bound_in_loop = - evalStateT (mapM buffer val_params) M.empty +doubleBufferMergeParams ctx_and_res bound_in_loop = + evalStateT (mapM buffer ctx_and_res) M.empty where + params = map fst ctx_and_res loopVariant v = v `nameIn` bound_in_loop || v `elem` map (paramName . fst) ctx_and_res @@ -230,9 +363,9 @@ Just (Constant v, True) loopInvariantSize (Var v) = case find ((== v) . paramName . fst) ctx_and_res of - Just (_, Constant val) -> + Just (_, SubExpRes _ (Constant val)) -> Just (Constant val, False) - Just (_, Var v') + Just (_, SubExpRes _ (Var v')) | not $ loopVariant v' -> Just (Var v', False) Just _ -> @@ -240,7 +373,7 @@ Nothing -> Just (Var v, True) - sizeForMem mem = maybeHead $ mapMaybe (arrayInMem . paramDec) val_params + sizeForMem mem = maybeHead $ mapMaybe (arrayInMem . paramDec) params where arrayInMem (MemArray pt shape _ (ArrayIn arraymem ixfun)) | IxFun.isDirect ixfun, @@ -254,26 +387,28 @@ ) arrayInMem _ = Nothing - buffer fparam = case paramType fparam of + buffer (fparam, res) = case paramType fparam of Mem space - | Just (size, b) <- sizeForMem $ paramName fparam -> do + | Just (size, b) <- sizeForMem $ paramName fparam, + Var res_v <- resSubExp res, + res_v `nameIn` bound_in_loop -> do -- Let us double buffer this! bufname <- lift $ newVName "double_buffer_mem" modify $ M.insert (paramName fparam) (bufname, b) - return $ BufferAlloc bufname size space b + pure $ BufferAlloc bufname size space b Array {} | MemArray _ _ _ (ArrayIn mem ixfun) <- paramDec fparam -> do buffered <- gets $ M.lookup mem case buffered of Just (bufname, b) -> do copyname <- lift $ newVName "double_buffer_array" - return $ BufferCopy bufname ixfun copyname b + pure $ BufferCopy bufname ixfun copyname b Nothing -> - return NoBuffer - _ -> return NoBuffer + pure NoBuffer + _ -> pure NoBuffer allocStms :: - (Constraints rep, Op rep ~ MemOp inner, BinderOps rep) => + Constraints rep inner => [(FParam rep, SubExp)] -> [DoubleBuffer] -> DoubleBufferM rep ([(FParam rep, SubExp)], [Stm rep]) @@ -281,13 +416,13 @@ where allocation m@(Param pname _, _) (BufferAlloc name size space b) = do stms <- lift $ - runBinder_ $ do + runBuilder_ $ do size' <- toSubExp "double_buffer_size" size letBindNames [name] $ Op $ Alloc size' space tell $ stmsToList stms if b - then return (Param pname $ MemMem space, Var name) - else return m + then pure (Param pname $ MemMem space, Var name) + else pure m allocation (f, Var v) (BufferCopy mem _ _ b) | b = do v_copy <- lift $ newVName $ baseString v ++ "_double_buffer_copy" (_v_mem, v_ixfun) <- lift $ lookupArraySummary v @@ -295,7 +430,7 @@ shape = arrayShape $ paramType f bound = MemArray bt shape NoUniqueness $ ArrayIn mem v_ixfun tell - [ Let (Pattern [] [PatElem v_copy bound]) (defAux ()) $ + [ Let (Pat [PatElem v_copy bound]) (defAux ()) $ BasicOp $ Copy v ] -- It is important that we treat this as a consumption, to @@ -305,37 +440,37 @@ let uniqueMemInfo (MemArray pt pshape _ ret) = MemArray pt pshape Unique ret uniqueMemInfo info = info - return (uniqueMemInfo <$> f, Var v_copy) + pure (uniqueMemInfo <$> f, Var v_copy) allocation (f, se) _ = - return (f, se) + pure (f, se) doubleBufferResult :: - (Constraints rep) => + Constraints rep inner => [FParam rep] -> [DoubleBuffer] -> Body rep -> Body rep -doubleBufferResult valparams buffered (Body _ bnds res) = +doubleBufferResult valparams buffered (Body _ stms res) = let (ctx_res, val_res) = splitAt (length res - length valparams) res - (copybnds, val_res') = + (copystms, val_res') = unzip $ zipWith3 buffer valparams buffered val_res - in Body () (bnds <> stmsFromList (catMaybes copybnds)) $ ctx_res ++ val_res' + in Body () (stms <> stmsFromList (catMaybes copystms)) $ ctx_res ++ val_res' where - buffer _ (BufferAlloc bufname _ _ _) _ = - (Nothing, Var bufname) - buffer fparam (BufferCopy bufname ixfun copyname _) (Var v) = + buffer _ (BufferAlloc bufname _ _ _) se = + (Nothing, se {resSubExp = Var bufname}) + buffer fparam (BufferCopy bufname ixfun copyname _) (SubExpRes cs (Var v)) = -- To construct the copy we will need to figure out its type -- based on the type of the function parameter. let t = resultType $ paramType fparam summary = MemArray (elemType t) (arrayShape t) NoUniqueness $ ArrayIn bufname ixfun copybnd = - Let (Pattern [] [PatElem copyname summary]) (defAux ()) $ + Let (Pat [PatElem copyname summary]) (defAux ()) $ BasicOp $ Copy v - in (Just copybnd, Var copyname) + in (Just copybnd, SubExpRes cs (Var copyname)) buffer _ _ se = (Nothing, se) - parammap = M.fromList $ zip (map paramName valparams) res + parammap = M.fromList $ zip (map paramName valparams) $ map resSubExp res resultType t = t `setArrayDims` map substitute (arrayDims t) 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 @@ -102,16 +102,14 @@ binding :: [(Ident, Names)] -> FusionGM a -> FusionGM a binding vs = local (`bindVars` vs) -gatherStmPattern :: Pattern -> Exp -> FusionGM FusedRes -> FusionGM FusedRes -gatherStmPattern pat e = binding $ zip idents aliases +gatherStmPat :: Pat -> Exp -> FusionGM FusedRes -> FusionGM FusedRes +gatherStmPat pat e = binding $ zip idents aliases where - idents = patternIdents pat - aliases = - replicate (length (patternContextNames pat)) mempty - ++ expAliases (Alias.analyseExp mempty e) + idents = patIdents pat + aliases = expAliases (Alias.analyseExp mempty e) -bindingPat :: Pattern -> FusionGM a -> FusionGM a -bindingPat = binding . (`zip` repeat mempty) . patternIdents +bindingPat :: Pat -> FusionGM a -> FusionGM a +bindingPat = binding . (`zip` repeat mempty) . patIdents bindingParams :: Typed t => [Param t] -> FusionGM a -> FusionGM a bindingParams = binding . (`zip` repeat mempty) . map paramIdent @@ -148,9 +146,12 @@ return res' {kernels = M.map inspectKer $ kernels res'} checkForUpdates :: FusedRes -> Exp -> FusionGM FusedRes -checkForUpdates res (BasicOp (Update src is _)) = do - let ifvs = namesToList $ mconcat $ map freeIn is +checkForUpdates res (BasicOp (Update _ src slice _)) = do + let ifvs = namesToList $ freeIn slice updateKerInPlaces res ([src], ifvs) +checkForUpdates res (BasicOp (FlatUpdate src slice _)) = do + let ifvs = namesToList $ freeIn slice + updateKerInPlaces res ([src], ifvs) checkForUpdates res (Op (Futhark.Scatter _ _ _ written_info)) = do let updt_arrs = map (\(_, _, x) -> x) written_info updateKerInPlaces res (updt_arrs, []) @@ -161,11 +162,11 @@ -- variables in scope (map) by inserting each (pattern-array) name. -- Finally, if the binding is an in-place update, then the @inplace@ field -- of each (result) kernel is updated with the new in-place updates. -bindingFamily :: Pattern -> FusionGM FusedRes -> FusionGM FusedRes +bindingFamily :: Pat -> FusionGM FusedRes -> FusionGM FusedRes bindingFamily pat = local bind where - idents = patternIdents pat - family = patternNames pat + idents = patIdents pat + family = patNames pat bind env = foldl (bindingFamilyVar family) env idents bindingTransform :: PatElem -> VName -> SOAC.ArrayTransform -> FusionGM a -> FusionGM a @@ -223,7 +224,7 @@ fuseConsts :: Names -> Stms SOACS -> PassM (Stms SOACS) fuseConsts used_consts consts = - fuseStms mempty consts $ map Var $ namesToList used_consts + fuseStms mempty consts $ varsRes $ namesToList used_consts fuseFun :: Stms SOACS -> FunDef SOACS -> PassM (FunDef SOACS) fuseFun consts fun = do @@ -397,13 +398,13 @@ [Stm] -> Names -> FusedRes -> - (Pattern, StmAux (), SOAC, Names) -> + (Pat, StmAux (), SOAC, Names) -> FusionGM FusedRes greedyFuse rem_bnds lam_used_nms res (out_idds, aux, orig_soac, consumed) = do soac <- inlineSOACInputs orig_soac (inp_nms, other_nms) <- soacInputs soac -- Assumption: the free vars in lambda are already in @infusible res@. - let out_nms = patternNames out_idds + let out_nms = patNames out_idds isInfusible = (`nameIn` infusible res) is_screma = case orig_soac of SOAC.Screma _ form _ -> @@ -452,7 +453,7 @@ let comb = M.unionWith S.union if not fusible_ker - then addNewKerWithInfusible res (patternIdents out_idds, aux, soac, consumed) ufs + then addNewKerWithInfusible res (patIdents out_idds, aux, soac, consumed) ufs else do -- Need to suitably update `inpArr': -- (i) first remove the inpArr bindings of the old kernel @@ -496,10 +497,10 @@ prodconsGreedyFuse :: FusedRes -> - (Pattern, StmAux (), SOAC, Names) -> + (Pat, StmAux (), SOAC, Names) -> FusionGM (Bool, [FusedKer], [KernName], [FusedKer], [KernName]) prodconsGreedyFuse res (out_idds, aux, soac, consumed) = do - let out_nms = patternNames out_idds -- Extract VNames from output patterns + let out_nms = patNames out_idds -- Extract VNames from output patterns to_fuse_knmSet = getKersWithInpArrs res out_nms -- Find kernels which consume outputs to_fuse_knms = S.toList to_fuse_knmSet lookup_kern k = case M.lookup k (kernels res) of @@ -515,7 +516,7 @@ (ok_kers_compat, fused_kers) <- do kers <- forM to_fuse_kers $ - attemptFusion mempty (patternNames out_idds) soac consumed + attemptFusion mempty (patNames out_idds) soac consumed case sequence kers of Nothing -> return (False, []) Just kers' -> return (True, map certifyKer kers') @@ -526,11 +527,11 @@ horizontGreedyFuse :: [Stm] -> FusedRes -> - (Pattern, StmAux (), SOAC, Names) -> + (Pat, StmAux (), SOAC, Names) -> FusionGM (Bool, [FusedKer], [KernName], [FusedKer], [KernName]) horizontGreedyFuse rem_bnds res (out_idds, aux, soac, consumed) = do (inp_nms, _) <- soacInputs soac - let out_nms = patternNames out_idds + let out_nms = patNames out_idds infusible_nms = namesFromList $ filter (`nameIn` infusible res) out_nms out_arr_nms = case soac of -- the accumulator result cannot be fused! @@ -554,7 +555,7 @@ -- located and sort based on the index so that partial fusion may -- succeed. We use the last position where one of the kernel -- outputs occur. - let bnd_nms = map (patternNames . stmPattern) rem_bnds + let bnd_nms = map (patNames . stmPat) rem_bnds kernminds <- forM to_fuse_knms $ \ker_nm -> do ker <- lookupKernel ker_nm case mapMaybe (\out_nm -> L.findIndex (elem out_nm) bnd_nms) (outNames ker) of @@ -567,7 +568,6 @@ -- now try to fuse kernels one by one (in a fold); @ok_ind@ is the index of the -- kernel until which fusion succeded, and @fused_ker@ is the resulting kernel. - use_scope <- (<> scopeOf rem_bnds) <$> askScope (_, ok_ind, _, fused_ker, _) <- foldM ( \(cur_ok, n, prev_ind, cur_ker, ufus_nms) (ker, _ker_nm, bnd_ind) -> do @@ -589,25 +589,20 @@ -- output transforms. cons_no_out_transf = SOAC.nullTransforms $ outputTransform ker - consumer_ok <- do - let consumer_bnd = rem_bnds !! bnd_ind - maybesoac <- runReaderT (SOAC.fromExp $ stmExp consumer_bnd) use_scope - case maybesoac of - -- check that consumer's lambda body does not use - -- directly the produced arrays (e.g., see noFusion3.fut). - Right conssoac -> - return $ - not $ - curker_outset - `namesIntersect` freeIn (lambdaBody $ SOAC.lambda conssoac) - Left _ -> return True + -- check that consumer's lambda body does not use + -- directly the produced arrays (e.g., see noFusion3.fut). + let consumer_ok = + not $ + curker_outset + `namesIntersect` freeIn (lambdaBody $ SOAC.lambda $ fsoac ker) let interm_bnds_ok = cur_ok && consumer_ok && out_transf_ok && cons_no_out_transf && foldl ( \ok bnd -> ok - && not (curker_outset `namesIntersect` freeIn (stmExp bnd)) -- hardwired to False after first fail + && not (curker_outset `namesIntersect` freeIn (stmExp bnd)) + -- hardwired to False after first fail -- (i) check that the in-between bindings do -- not use the result of current kernel OR || @@ -619,7 +614,7 @@ not ( null $ curker_outnms - `L.intersect` patternNames (stmPattern bnd) + `L.intersect` patNames (stmPat bnd) ) ) True @@ -646,7 +641,7 @@ -- Find the kernels we have fused into and the name of the last such -- kernel (if any). let (to_fuse_kers', to_fuse_knms', _) = unzip3 $ take ok_ind kernminds' - new_kernms = drop (ok_ind -1) to_fuse_knms' + new_kernms = drop (ok_ind - 1) to_fuse_knms' return (ok_ind > 0, [fused_ker], new_kernms, to_fuse_kers', to_fuse_knms') where @@ -686,12 +681,7 @@ -- be considered a stream, to avoid infinite recursion. fusionGatherStms fres - ( Let - (Pattern [] pes) - bndtp - (DoLoop [] merge (ForLoop i it w loop_vars) body) - : bnds - ) + (Let (Pat pes) bndtp (DoLoop merge (ForLoop i it w loop_vars) body) : bnds) res | not $ null loop_vars = do let (merge_params, merge_init) = unzip merge @@ -711,11 +701,11 @@ let lam_params = chunk_param : acc_params ++ [offset_param] ++ chunked_params - lam_body <- runBodyBinder $ + lam_body <- runBodyBuilder $ localScope (scopeOfLParams lam_params) $ do let merge' = zip merge_params $ map (Futhark.Var . paramName) acc_params j <- newVName "j" - loop_body <- runBodyBinder $ do + loop_body <- runBodyBuilder $ do forM_ (zip loop_params chunked_params) $ \(p, a_p) -> letBindNames [paramName p] $ BasicOp $ @@ -725,7 +715,7 @@ return body eBody [ pure $ - DoLoop [] merge' (ForLoop j it (Futhark.Var chunk_size) []) loop_body, + DoLoop merge' (ForLoop j it (Futhark.Var chunk_size) []) loop_body, pure $ BasicOp $ BinOp (Add Int64 OverflowUndef) (Futhark.Var offset) (Futhark.Var chunk_size) ] @@ -745,7 +735,7 @@ fusionGatherStms fres - (Let (Pattern [] (pes <> [discard_pe])) bndtp (Op stream) : bnds) + (Let (Pat (pes <> [discard_pe])) bndtp (Op stream) : bnds) res fusionGatherStms fres (bnd@(Let pat _ e) : bnds) res = do maybesoac <- SOAC.fromExp e @@ -754,14 +744,14 @@ -- We put the variables produced by Scatter into the infusible -- set to force horizontal fusion. It is not possible to -- producer/consumer-fuse Scatter anyway. - fres' <- addNamesToInfusible fres $ namesFromList $ patternNames pat + fres' <- addNamesToInfusible fres $ namesFromList $ patNames pat fres'' <- mapLike fres' soac lam checkForUpdates fres'' e Right soac@(SOAC.Hist _ _ lam _) -> do -- We put the variables produced by Hist into the infusible -- set to force horizontal fusion. It is not possible to -- producer/consumer-fuse Hist anyway. - fres' <- addNamesToInfusible fres $ namesFromList $ patternNames pat + fres' <- addNamesToInfusible fres $ namesFromList $ patNames pat mapLike fres' soac lam Right soac@(SOAC.Screma _ (ScremaForm scans reds map_lam) _) -> reduceLike soac (map scanLambda scans <> map redLambda reds <> [map_lam]) $ @@ -777,12 +767,12 @@ Sequential -> [lam] reduceLike soac lambdas nes _ - | [pe] <- patternValueElements pat, + | Pat [pe] <- pat, Just (src, trns) <- SOAC.transformFromExp (stmCerts bnd) e -> bindingTransform pe src trns $ fusionGatherStms fres bnds res | otherwise -> do - let pat_vars = map (BasicOp . SubExp . Var) $ patternNames pat - bres <- gatherStmPattern pat e $ fusionGatherStms fres bnds res + let pat_vars = map (BasicOp . SubExp . Var) $ patNames pat + bres <- gatherStmPat pat e $ fusionGatherStms fres bnds res bres' <- checkForUpdates bres e foldM fusionGatherExp bres' (e : pat_vars) where @@ -803,11 +793,11 @@ consumed' <- varsAliases consumed greedyFuse rem_bnds used_lam blres (pat, aux, soac, consumed') fusionGatherStms fres [] res = - foldM fusionGatherExp fres $ map (BasicOp . SubExp) res + foldM fusionGatherExp fres $ map (BasicOp . SubExp . resSubExp) res fusionGatherExp :: FusedRes -> Exp -> FusionGM FusedRes -fusionGatherExp fres (DoLoop ctx val form loop_body) = do - fres' <- addNamesToInfusible fres $ freeIn form <> freeIn ctx <> freeIn val +fusionGatherExp fres (DoLoop merge form loop_body) = do + fres' <- addNamesToInfusible fres $ freeIn form <> freeIn merge let form_idents = case form of ForLoop i it _ loopvars -> @@ -815,11 +805,8 @@ WhileLoop {} -> [] new_res <- - binding - ( zip (form_idents ++ map (paramIdent . fst) (ctx <> val)) $ - repeat mempty - ) - $ fusionGatherBody mempty loop_body + binding (zip (form_idents ++ map (paramIdent . fst) merge) $ repeat mempty) $ + fusionGatherBody mempty loop_body -- make the inpArr infusible, so that they -- cannot be fused from outside the loop: let (inp_arrs, _) = unzip $ M.toList $ inpArr new_res @@ -902,10 +889,10 @@ fuseInExp :: Exp -> FusionGM Exp -- Handle loop specially because we need to bind the types of the -- merge variables. -fuseInExp (DoLoop ctx val form loopbody) = +fuseInExp (DoLoop merge form loopbody) = binding (zip form_idents $ repeat mempty) $ - bindingParams (map fst $ ctx ++ val) $ - DoLoop ctx val form <$> fuseInBody loopbody + bindingParams (map fst merge) $ + DoLoop merge form <$> fuseInBody loopbody where form_idents = case form of WhileLoop {} -> [] @@ -926,12 +913,12 @@ body' <- bindingParams params $ fuseInBody body return $ Lambda params body' rtp -replaceSOAC :: Pattern -> StmAux () -> Exp -> FusionGM (Stms SOACS) -replaceSOAC (Pattern _ []) _ _ = return mempty -replaceSOAC pat@(Pattern _ (patElem : _)) aux e = do +replaceSOAC :: Pat -> StmAux () -> Exp -> FusionGM (Stms SOACS) +replaceSOAC (Pat []) _ _ = return mempty +replaceSOAC pat@(Pat (patElem : _)) aux e = do fres <- asks fusedRes let pat_nm = patElemName patElem - names = patternIdents pat + names = patIdents pat case M.lookup pat_nm (outArr fres) of Nothing -> oneStm . Let pat aux <$> fuseInExp e @@ -957,13 +944,13 @@ insertKerSOAC :: StmAux () -> [VName] -> FusedKer -> FusionGM (Stms SOACS) insertKerSOAC aux names ker = do new_soac' <- finaliseSOAC $ fsoac ker - runBinder_ $ do + runBuilder_ $ do f_soac <- SOAC.toSOAC new_soac' -- The fused kernel may consume more than the original SOACs (see -- issue #224). We insert copy expressions to fix it. f_soac' <- copyNewlyConsumed (fusedConsumed ker) $ addOpAliases mempty f_soac validents <- zipWithM newIdent (map baseString names) $ SOAC.typeOf new_soac' - auxing (kerAux ker <> aux) $ letBind (basicPattern [] validents) $ Op f_soac' + auxing (kerAux ker <> aux) $ letBind (basicPat validents) $ Op f_soac' transformOutput (outputTransform ker) names validents -- | Perform simplification and fusion inside the lambda(s) of a SOAC. @@ -1002,7 +989,7 @@ copyNewlyConsumed :: Names -> Futhark.SOAC (Aliases.Aliases SOACS) -> - Binder SOACS (Futhark.SOAC SOACS) + Builder SOACS (Futhark.SOAC SOACS) copyNewlyConsumed was_consumed soac = case soac of Futhark.Screma w arrs (Futhark.ScremaForm scans reds map_lam) -> do 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 @@ -21,7 +21,7 @@ import qualified Data.Map.Strict as M import Data.Maybe import qualified Futhark.Analysis.HORep.SOAC as SOAC -import Futhark.Binder (Bindable (..), insertStm, insertStms, mkLet) +import Futhark.Builder (Buildable (..), insertStm, insertStms, mkLet) import Futhark.Construct (mapResult) import Futhark.IR import Futhark.Util (dropLast, splitAt3, takeLast) @@ -44,7 +44,7 @@ -- The result is the fused function, and a list of the array inputs -- expected by the SOAC containing the fused function. fuseMaps :: - Bindable rep => + Buildable rep => -- | The producer var names that still need to be returned Names -> -- | Function of SOAC to be fused. @@ -76,19 +76,15 @@ } new_body2 = let bnds res = - [ mkLet [] [p] $ BasicOp $ SubExp e - | (p, e) <- zip pat res + [ certify cs $ mkLet [p] $ BasicOp $ SubExp e + | (p, SubExpRes cs e) <- zip pat res ] bindLambda res = stmsFromList (bnds res) `insertStms` makeCopiesInner (lambdaBody lam2) in makeCopies $ mapResult bindLambda (lambdaBody lam1) new_body2_rses = bodyResult new_body2 new_body2' = - new_body2 - { bodyResult = - new_body2_rses - ++ map (Var . identName) unfus_pat - } + new_body2 {bodyResult = new_body2_rses ++ map (varRes . identName) unfus_pat} -- infusible variables are added at the end of the result/pattern/type (lam2redparams, unfus_pat, pat, inputmap, makeCopies, makeCopiesInner) = fuseInputs unfus_nms lam1 inp1 out1 lam2 inp2 @@ -96,7 +92,7 @@ --(unfus_accpat, unfus_arrpat) = splitAt (length unfus_accs) unfus_pat fuseInputs :: - Bindable rep => + Buildable rep => Names -> Lambda rep -> [SOAC.Input] -> @@ -172,7 +168,7 @@ _ -> (m, ra) removeDuplicateInputs :: - Bindable 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) @@ -188,11 +184,10 @@ arrmap ) forward to from b = - mkLet [] [to] (BasicOp $ SubExp $ Var from) - `insertStm` b + mkLet [to] (BasicOp $ SubExp $ Var from) `insertStm` b fuseRedomap :: - Bindable rep => + Buildable rep => Names -> [VName] -> Lambda rep -> diff --git a/src/Futhark/Optimise/Fusion/LoopKernel.hs b/src/Futhark/Optimise/Fusion/LoopKernel.hs --- a/src/Futhark/Optimise/Fusion/LoopKernel.hs +++ b/src/Futhark/Optimise/Fusion/LoopKernel.hs @@ -76,7 +76,7 @@ SOAC.ArrayTransforms -> [VName] -> [Ident] -> - Binder SOACS () + Builder SOACS () transformOutput ts names = descend ts where descend ts' validents = @@ -86,15 +86,15 @@ letBindNames [k] $ BasicOp $ SubExp $ Var $ identName valident t SOAC.:< ts'' -> do let (es, css) = unzip $ map (applyTransform t) validents - mkPat (Ident nm tp) = Pattern [] [PatElem nm tp] - opts <- concat <$> mapM primOpType es + mkPat (Ident nm tp) = Pat [PatElem nm tp] + opts <- concat <$> mapM basicOpType es newIds <- forM (zip names opts) $ \(k, opt) -> newIdent (baseString k) opt forM_ (zip3 css newIds es) $ \(cs, ids, e) -> certifying cs $ letBind (mkPat ids) (BasicOp e) descend ts'' newIds -applyTransform :: SOAC.ArrayTransform -> Ident -> (BasicOp, Certificates) +applyTransform :: SOAC.ArrayTransform -> Ident -> (BasicOp, Certs) applyTransform (SOAC.Rearrange cs perm) v = (Rearrange perm' $ identName v, cs) where @@ -684,10 +684,10 @@ let map_body = mkBody ( oneStm $ - Let (setPatternOuterDimTo w map_pat) (defAux ()) $ + Let (setPatOuterDimTo w map_pat) (defAux ()) $ Op $ Futhark.Screma w arrs' scan_form ) - $ map Var $ patternNames map_pat + $ varsRes $ patNames map_pat map_fun' = Lambda map_params map_body map_rettype perm = case lambdaReturnType map_fun of [] -> [] @@ -710,8 +710,8 @@ let t = paramType param `setOuterSize` w in param {paramDec = t} -setPatternOuterDimTo :: SubExp -> Pattern -> Pattern -setPatternOuterDimTo w = fmap (`setOuterSize` w) +setPatOuterDimTo :: SubExp -> Pat -> Pat +setPatOuterDimTo w = fmap (`setOuterSize` w) -- Now for fiddling with transpositions... @@ -857,7 +857,7 @@ stripArray (length shape - length outershape) inpt inner_body <- - runBodyBinder $ + runBodyBuilder $ eBody [SOAC.toExp $ inner $ map (SOAC.identInput . paramIdent) ps] let inner_fun = Lambda 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 @@ -71,7 +71,7 @@ import Control.Monad.RWS import qualified Data.Map.Strict as M import Futhark.Analysis.Alias -import Futhark.Binder +import Futhark.Builder import Futhark.IR.Aliases import Futhark.IR.GPU import Futhark.IR.MC @@ -119,17 +119,14 @@ descend [] m = m descend (stm : stms) m = bindingStm stm $ descend stms m -type Constraints rep = (Bindable rep, CanBeAliased (Op rep)) +type Constraints rep = (Buildable rep, CanBeAliased (Op rep)) optimiseBody :: Constraints rep => Body (Aliases rep) -> ForwardingM rep (Body (Aliases rep)) optimiseBody (Body als bnds res) = do - bnds' <- - deepen $ - optimiseStms (stmsToList bnds) $ - mapM_ seen res + bnds' <- deepen $ optimiseStms (stmsToList bnds) $ mapM_ (seen . resSubExp) res return $ Body als (stmsFromList bnds') res where seen Constant {} = return () @@ -156,7 +153,7 @@ let updated_names = map updateName updates notUpdated = - not . any (`elem` updated_names) . patternNames . stmPattern + not . any (`elem` updated_names) . patNames . stmPat -- Condition (5) and (7) are assumed to be checked by -- lowerUpdate. @@ -171,11 +168,11 @@ checkIfForwardableUpdate bnd' return $ bnd' : bnds' where - boundHere = patternNames $ stmPattern bnd + boundHere = patNames $ stmPat bnd checkIfForwardableUpdate (Let pat (StmAux cs _ _) e) - | Pattern [] [PatElem v dec] <- pat, - BasicOp (Update src slice (Var ve)) <- e = + | Pat [PatElem v dec] <- pat, + BasicOp (Update Unsafe src slice (Var ve)) <- e = maybeForward ve v dec cs src slice checkIfForwardableUpdate _ = return () @@ -184,10 +181,9 @@ Let pat dec <$> optimiseExp e optimiseExp :: Constraints rep => Exp (Aliases rep) -> ForwardingM rep (Exp (Aliases rep)) -optimiseExp (DoLoop ctx val form body) = - bindingScope (scopeOf form) $ - bindingFParams (map fst $ ctx ++ val) $ - DoLoop ctx val form <$> optimiseBody body +optimiseExp (DoLoop merge form body) = + bindingScope (scopeOf form) . bindingFParams (map fst merge) $ + DoLoop merge form <$> optimiseBody body optimiseExp (Op op) = do f <- asks topOnOp Op <$> f op @@ -199,7 +195,7 @@ } onSegOp :: - (Bindable rep, CanBeAliased (Op rep)) => + (Buildable rep, CanBeAliased (Op rep)) => SegOp lvl (Aliases rep) -> ForwardingM rep (SegOp lvl (Aliases rep)) onSegOp op = @@ -324,7 +320,7 @@ ForwardingM rep a -> ForwardingM rep a bindingStm (Let pat _ _) = local $ \(TopDown n vtable d x y) -> - let entries = M.fromList $ map entry $ patternElements pat + let entries = M.fromList $ map entry $ patElems pat entry patElem = let (aliases, _) = patElemDec patElem in ( patElemName patElem, @@ -394,7 +390,7 @@ VName -> VName -> LetDec (Aliases rep) -> - Certificates -> + Certs -> VName -> Slice SubExp -> ForwardingM 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 @@ -25,7 +25,7 @@ updateName :: VName, -- | Type of result. updateType :: dec, - updateCertificates :: Certificates, + updateCerts :: Certs, updateSource :: VName, updateIndices :: Slice SubExp, updateValue :: VName @@ -46,33 +46,32 @@ lowerUpdate :: ( MonadFreshNames m, - Bindable rep, + Buildable rep, LetDec rep ~ Type, CanBeAliased (Op rep) ) => LowerUpdate rep m -lowerUpdate scope (Let pat aux (DoLoop ctx val form body)) updates = do - canDo <- lowerUpdateIntoLoop scope updates pat ctx val form body +lowerUpdate scope (Let pat aux (DoLoop merge form body)) updates = do + canDo <- lowerUpdateIntoLoop scope updates pat merge form body Just $ do - (prebnds, postbnds, ctxpat, valpat, ctx', val', body') <- canDo + (prebnds, postbnds, pat', merge', body') <- canDo return $ prebnds ++ [ certify (stmAuxCerts aux) $ - mkLet ctxpat valpat $ DoLoop ctx' val' form body' + mkLet pat' $ DoLoop merge' form body' ] ++ postbnds lowerUpdate _ (Let pat aux (BasicOp (SubExp (Var v)))) - [DesiredUpdate bindee_nm bindee_dec cs src is val] - | patternNames pat == [src] = + [DesiredUpdate bindee_nm bindee_dec cs src (Slice is) val] + | patNames pat == [src] = let is' = fullSlice (typeOf bindee_dec) is - in Just $ - return - [ certify (stmAuxCerts aux <> cs) $ - mkLet [] [Ident bindee_nm $ typeOf bindee_dec] $ - BasicOp $ Update v is' $ Var val - ] + in Just . pure $ + [ certify (stmAuxCerts aux <> cs) $ + mkLet [Ident bindee_nm $ typeOf bindee_dec] $ + BasicOp $ Update Unsafe v is' $ Var val + ] lowerUpdate _ _ _ = Nothing @@ -81,12 +80,12 @@ scope (Let pat aux (Op (SegOp (SegMap lvl space ts kbody)))) updates - | all ((`elem` patternNames pat) . updateValue) updates, + | all ((`elem` patNames pat) . updateValue) updates, not source_used_in_kbody = do mk <- lowerUpdatesIntoSegMap scope pat updates space kbody Just $ do (pat', kbody', poststms) <- mk - let cs = stmAuxCerts aux <> foldMap updateCertificates updates + let cs = stmAuxCerts aux <> foldMap updateCerts updates return $ certify cs (Let pat' aux $ Op $ SegOp $ SegMap lvl space ts kbody') : stmsToList poststms @@ -104,13 +103,13 @@ lowerUpdatesIntoSegMap :: MonadFreshNames m => Scope (Aliases GPU) -> - Pattern (Aliases GPU) -> + Pat (Aliases GPU) -> [DesiredUpdate (LetDec (Aliases GPU))] -> SegSpace -> KernelBody (Aliases GPU) -> Maybe ( m - ( Pattern (Aliases GPU), + ( Pat (Aliases GPU), KernelBody (Aliases GPU), Stms (Aliases GPU) ) @@ -118,11 +117,11 @@ lowerUpdatesIntoSegMap scope pat updates kspace kbody = do -- The updates are all-or-nothing. Being more liberal would require -- changes to the in-place-lowering pass itself. - mk <- zipWithM onRet (patternElements pat) (kernelBodyResult kbody) + mk <- zipWithM onRet (patElems pat) (kernelBodyResult kbody) return $ do (pes, bodystms, krets, poststms) <- unzip4 <$> sequence mk return - ( Pattern [] pes, + ( Pat pes, kbody { kernelBodyStms = kernelBodyStms kbody <> mconcat bodystms, kernelBodyResult = krets @@ -135,48 +134,46 @@ onRet (PatElem v v_dec) ret | Just (DesiredUpdate bindee_nm bindee_dec _cs src slice _val) <- find ((== v) . updateValue) updates = do - Returns _ se <- Just ret + Returns _ cs se <- Just ret -- The slice we're writing per thread must fully cover the -- underlying dimensions. guard $ let (dims', slice') = unzip . drop (length gtids) . filter (isNothing . dimFix . snd) $ - zip (arrayDims (typeOf bindee_dec)) slice - in isFullSlice (Shape dims') slice' + zip (arrayDims (typeOf bindee_dec)) (unSlice slice) + in isFullSlice (Shape dims') (Slice slice') Just $ do (slice', bodystms) <- - flip runBinderT scope $ + flip runBuilderT scope $ traverse (toSubExp "index") $ - fixSlice (map (fmap pe64) slice) $ - map (pe64 . Var) gtids + fixSlice (fmap pe64 slice) $ map (pe64 . Var) gtids let res_dims = arrayDims $ snd bindee_dec - ret' = WriteReturns (Shape res_dims) src [(map DimFix slice', se)] + ret' = WriteReturns cs (Shape res_dims) src [(Slice $ map DimFix slice', se)] return ( PatElem bindee_nm bindee_dec, bodystms, ret', oneStm $ - mkLet [] [Ident v $ typeOf v_dec] $ + mkLet [Ident v $ typeOf v_dec] $ BasicOp $ Index bindee_nm slice ) onRet pe ret = Just $ return (pe, mempty, ret, mempty) lowerUpdateIntoLoop :: - ( Bindable rep, - BinderOps rep, + ( Buildable rep, + BuilderOps rep, Aliased rep, LetDec rep ~ (als, Type), MonadFreshNames m ) => Scope rep -> [DesiredUpdate (LetDec rep)] -> - Pattern rep -> - [(FParam rep, SubExp)] -> + Pat rep -> [(FParam rep, SubExp)] -> LoopForm rep -> Body rep -> @@ -185,13 +182,11 @@ ( [Stm rep], [Stm rep], [Ident], - [Ident], [(FParam rep, SubExp)], - [(FParam rep, SubExp)], Body rep ) ) -lowerUpdateIntoLoop scope updates pat ctx val form body = do +lowerUpdateIntoLoop scope updates pat val form body = do -- Algorithm: -- -- 0) Map each result of the loop body to a corresponding in-place @@ -227,19 +222,19 @@ Just $ do in_place_map <- mk_in_place_map (val', prebnds, postbnds) <- mkMerges in_place_map - let (ctxpat, valpat) = mkResAndPat in_place_map + let valpat = mkResAndPat in_place_map idxsubsts = indexSubstitutions in_place_map (idxsubsts', newbnds) <- substituteIndices idxsubsts $ bodyStms body (body_res, res_bnds) <- manipulateResult in_place_map idxsubsts' let body' = mkBody (newbnds <> res_bnds) body_res - return (prebnds, postbnds, ctxpat, valpat, ctx, val', body') + return (prebnds, postbnds, valpat, val', body') where usedInBody = mconcat $ map (`lookupAliases` scope) $ namesToList $ freeIn body <> freeIn form - resmap = zip (bodyResult body) $ patternValueIdents pat + resmap = zip (bodyResult body) $ patIdents pat mkMerges :: - (MonadFreshNames m, Bindable rep) => + (MonadFreshNames m, Buildable rep) => [LoopResultSummary (als, Type)] -> m ([(Param DeclType, SubExp)], [Stm rep], [Stm rep]) mkMerges summaries = do @@ -256,18 +251,17 @@ (updateValue update) (source_t `setArrayDims` sliceDims (updateIndices update)) tell - ( [ mkLet [] [Ident source source_t] $ - BasicOp $ - Update - (updateSource update) - (fullSlice source_t $ updateIndices update) - $ snd $ mergeParam summary + ( [ mkLet [Ident source source_t] . BasicOp $ + Update + Unsafe + (updateSource update) + (fullSlice source_t $ unSlice $ updateIndices update) + $ snd $ mergeParam summary ], - [ mkLet [] [elmident] $ - BasicOp $ - Index - (updateName update) - (fullSlice source_t $ updateIndices update) + [ mkLet [elmident] . BasicOp $ + Index + (updateName update) + (fullSlice source_t $ unSlice $ updateIndices update) ] ) return $ @@ -281,15 +275,13 @@ mkResAndPat summaries = let (origpat, extrapat) = partitionEithers $ map mkResAndPat' summaries - in ( patternContextIdents pat, - origpat ++ extrapat - ) + in origpat ++ extrapat mkResAndPat' summary | Just (update, _, _) <- relatedUpdate summary = Right (Ident (updateName update) (snd $ updateType update)) | otherwise = - Left (inPatternAs summary) + Left (inPatAs summary) summariseLoop :: ( Aliased rep, @@ -298,7 +290,7 @@ Scope rep -> [DesiredUpdate (als, Type)] -> Names -> - [(SubExp, Ident)] -> + [(SubExpRes, Ident)] -> [(Param DeclType, SubExp)] -> Maybe (m [LoopResultSummary (als, Type)]) summariseLoop scope updates usedInBody resmap merge = @@ -316,7 +308,7 @@ return LoopResultSummary { resultSubExp = se, - inPatternAs = v, + inPatAs = v, mergeParam = (fparam, mergeinit), relatedUpdate = Just @@ -336,8 +328,8 @@ loopInvariant Constant {} = True data LoopResultSummary dec = LoopResultSummary - { resultSubExp :: SubExp, - inPatternAs :: Ident, + { resultSubExp :: SubExpRes, + inPatAs :: Ident, mergeParam :: (Param DeclType, SubExp), relatedUpdate :: Maybe (DesiredUpdate dec, VName, dec) } @@ -354,28 +346,26 @@ return (name, (cs, nm, dec, is)) manipulateResult :: - (Bindable rep, MonadFreshNames m) => + (Buildable rep, MonadFreshNames m) => [LoopResultSummary (LetDec rep)] -> IndexSubstitutions (LetDec rep) -> m (Result, Stms rep) manipulateResult summaries substs = do let (orig_ses, updated_ses) = partitionEithers $ map unchangedRes summaries (subst_ses, res_bnds) <- runWriterT $ zipWithM substRes updated_ses substs - return (orig_ses ++ subst_ses, stmsFromList res_bnds) + pure (orig_ses ++ subst_ses, stmsFromList res_bnds) where unchangedRes summary = case relatedUpdate summary of Nothing -> Left $ resultSubExp summary Just _ -> Right $ resultSubExp summary - substRes (Var res_v) (subst_v, (_, nm, _, _)) + substRes (SubExpRes res_cs (Var res_v)) (subst_v, (_, nm, _, _)) | res_v == subst_v = - return $ Var nm - substRes res_se (_, (cs, nm, dec, is)) = do + pure $ SubExpRes res_cs $ Var nm + substRes (SubExpRes res_cs res_se) (_, (cs, nm, dec, Slice is)) = do v' <- newIdent' (++ "_updated") $ Ident nm $ typeOf dec tell - [ certify cs $ - mkLet [] [v'] $ - BasicOp $ - Update nm (fullSlice (typeOf dec) is) res_se + [ certify (res_cs <> cs) . mkLet [v'] . BasicOp $ + Update Unsafe nm (fullSlice (typeOf dec) is) res_se ] - return $ Var $ identName v' + pure $ varRes $ identName v' 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 @@ -20,7 +20,7 @@ import Futhark.Transform.Substitute import Futhark.Util -type IndexSubstitution dec = (Certificates, VName, dec, Slice SubExp) +type IndexSubstitution dec = (Certs, VName, dec, Slice SubExp) type IndexSubstitutions dec = [(VName, IndexSubstitution dec)] @@ -36,8 +36,8 @@ -- | Perform the substitution. substituteIndices :: ( MonadFreshNames m, - BinderOps rep, - Bindable rep, + BuilderOps rep, + Buildable rep, Aliased rep, LetDec rep ~ dec ) => @@ -45,43 +45,42 @@ Stms rep -> m (IndexSubstitutions dec, Stms rep) substituteIndices substs bnds = - runBinderT (substituteIndicesInStms substs bnds) types + runBuilderT (substituteIndicesInStms substs bnds) types where types = typeEnvFromSubstitutions substs substituteIndicesInStms :: - (MonadBinder m, Bindable (Rep m), Aliased (Rep m)) => + (MonadBuilder m, Buildable (Rep m), Aliased (Rep m)) => IndexSubstitutions (LetDec (Rep m)) -> Stms (Rep m) -> m (IndexSubstitutions (LetDec (Rep m))) substituteIndicesInStms = foldM substituteIndicesInStm substituteIndicesInStm :: - (MonadBinder m, Bindable (Rep m), Aliased (Rep m)) => + (MonadBuilder m, Buildable (Rep m), Aliased (Rep m)) => IndexSubstitutions (LetDec (Rep m)) -> Stm (Rep m) -> m (IndexSubstitutions (LetDec (Rep m))) substituteIndicesInStm substs (Let pat rep e) = do e' <- substituteIndicesInExp substs e - (substs', pat') <- substituteIndicesInPattern substs pat + (substs', pat') <- substituteIndicesInPat substs pat addStm $ Let pat' rep e' return substs' -substituteIndicesInPattern :: - (MonadBinder m, LetDec (Rep m) ~ dec) => +substituteIndicesInPat :: + (MonadBuilder m, LetDec (Rep m) ~ dec) => IndexSubstitutions (LetDec (Rep m)) -> - PatternT dec -> - m (IndexSubstitutions (LetDec (Rep m)), PatternT dec) -substituteIndicesInPattern substs pat = do - (substs', context) <- mapAccumLM sub substs $ patternContextElements pat - (substs'', values) <- mapAccumLM sub substs' $ patternValueElements pat - return (substs'', Pattern context values) + PatT dec -> + m (IndexSubstitutions (LetDec (Rep m)), PatT dec) +substituteIndicesInPat substs pat = do + (substs', pes) <- mapAccumLM sub substs $ patElems pat + return (substs', Pat pes) where sub substs' patElem = return (substs', patElem) substituteIndicesInExp :: - ( MonadBinder m, - Bindable (Rep m), + ( MonadBuilder m, + Buildable (Rep m), Aliased (Rep m), LetDec (Rep m) ~ dec ) => @@ -91,7 +90,7 @@ substituteIndicesInExp substs (Op op) = do let used_in_op = filter ((`nameIn` freeIn op) . fst) substs var_substs <- fmap mconcat $ - forM used_in_op $ \(v, (cs, src, src_dec, is)) -> do + forM used_in_op $ \(v, (cs, src, src_dec, Slice is)) -> do v' <- certifying cs $ letExp "idx" $ BasicOp $ Index src $ fullSlice (typeOf src_dec) is @@ -114,10 +113,9 @@ row <- certifying cs2 $ letExp (baseString v ++ "_row") $ - BasicOp $ Index src2 $ fullSlice (typeOf src2dec) is2 + BasicOp $ Index src2 $ fullSlice (typeOf src2dec) (unSlice is2) row_copy <- - letExp (baseString v ++ "_row_copy") $ - BasicOp $ Copy row + letExp (baseString v ++ "_row_copy") $ BasicOp $ Copy row return $ update v @@ -128,7 +126,7 @@ `setType` ( typeOf src2dec `setArrayDims` sliceDims is2 ), - [] + Slice [] ) substs' consumingSubst substs' _ = @@ -136,7 +134,7 @@ in foldM consumingSubst substs . namesToList . consumedInExp substituteIndicesInSubExp :: - MonadBinder m => + MonadBuilder m => IndexSubstitutions (LetDec (Rep m)) -> SubExp -> m SubExp @@ -146,22 +144,22 @@ return se substituteIndicesInVar :: - MonadBinder m => + MonadBuilder m => IndexSubstitutions (LetDec (Rep m)) -> VName -> m VName substituteIndicesInVar substs v - | Just (cs2, src2, _, []) <- lookup v substs = + | Just (cs2, src2, _, Slice []) <- lookup v substs = certifying cs2 $ letExp (baseString src2) $ BasicOp $ SubExp $ Var src2 - | Just (cs2, src2, src2_dec, is2) <- lookup v substs = + | Just (cs2, src2, src2_dec, Slice is2) <- lookup v substs = certifying cs2 $ letExp "idx" $ BasicOp $ Index src2 $ fullSlice (typeOf src2_dec) is2 | otherwise = return v substituteIndicesInBody :: - (MonadBinder m, Bindable (Rep m), Aliased (Rep m)) => + (MonadBuilder m, Buildable (Rep m), Aliased (Rep m)) => IndexSubstitutions (LetDec (Rep m)) -> Body (Rep m) -> m (Body (Rep m)) @@ -171,8 +169,11 @@ collectStms $ substituteIndicesInStms substs stms (res', res_stms) <- inScopeOf stms' $ - collectStms $ mapM (substituteIndicesInSubExp substs') res + collectStms $ mapM (onSubExpRes substs') res mkBodyM (stms' <> res_stms) res' + where + onSubExpRes substs' (SubExpRes cs se) = + SubExpRes cs <$> substituteIndicesInSubExp substs' se update :: 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 @@ -4,7 +4,8 @@ -- | This module implements a compiler pass for inlining functions, -- then removing those that have become dead. module Futhark.Optimise.InliningDeadFun - ( inlineFunctions, + ( inlineAggressively, + inlineConservatively, removeDeadFunctions, ) where @@ -14,11 +15,10 @@ import Control.Parallel.Strategies import Data.List (partition) import qualified Data.Map.Strict as M -import Data.Maybe import qualified Data.Set as S import Futhark.Analysis.CallGraph import qualified Futhark.Analysis.SymbolTable as ST -import Futhark.Binder +import Futhark.Builder import Futhark.IR.SOACS import Futhark.IR.SOACS.Simplify ( simpleSOACS, @@ -45,75 +45,90 @@ (bs, srcs) = unzip $ parMap rpar f' as in (bs, mconcat srcs) -aggInlineFunctions :: MonadFreshNames m => Prog SOACS -> m (Prog SOACS) -aggInlineFunctions prog = +-- It is more efficient to shrink the program as soon as possible, +-- rather than wait until it has balooned after full inlining. This +-- is the inverse rate at which we perform full simplification after +-- inlining. For the other steps we just do copy propagation. The +-- simplification rates used have been determined heuristically and +-- are probably not optimal for any given program. +inlineFunctions :: + MonadFreshNames m => + Int -> + CallGraph -> + S.Set Name -> + Prog SOACS -> + m (Prog SOACS) +inlineFunctions simplify_rate cg what_should_be_inlined prog = do let Prog consts funs = prog - in uncurry Prog . fmap (filter keep) - <$> recurse 0 (ST.fromScope (addScopeWisdom (scopeOf consts)), consts, funs) - where - fdmap fds = - M.fromList $ zip (map funDefName fds) fds + vtable = ST.fromScope (addScopeWisdom (scopeOf consts)) - cg = buildCallGraph prog - noninlined = findNoninlined prog + uncurry Prog <$> recurse (1, vtable) (consts, funs) what_should_be_inlined + where + fdmap fds = M.fromList $ zip (map funDefName fds) fds - noCallsTo which fundec = - not $ any (`S.member` which) $ allCalledBy (funDefName fundec) cg + noCallsTo which from = S.null $ allCalledBy from cg `S.intersection` which - -- The inverse rate at which we perform full simplification - -- after inlining. For the other steps we just do copy - -- propagation. The rate here has been determined - -- heuristically and is probably not optimal for any given - -- program. - simplifyRate :: Int - simplifyRate = 4 + recurse (i, vtable) (consts, funs) to_inline = do + let (to_inline_now, to_inline_later) = + S.partition (noCallsTo to_inline) to_inline + (dont_inline_in, to_inline_in) = + partition (noCallsTo to_inline_now . funDefName) funs - -- We apply simplification after every round of inlining, - -- because it is more efficient to shrink the program as soon - -- as possible, rather than wait until it has balooned after - -- full inlining. - recurse i (vtable, consts, funs) = do - let remaining = S.fromList $ map funDefName funs - (to_be_inlined, maybe_inline_in) = - partition (noCallsTo remaining) funs - (not_to_inline_in, to_inline_in) = - partition - ( noCallsTo - (S.fromList $ map funDefName to_be_inlined) - ) - maybe_inline_in - keep_although_inlined = filter keep to_be_inlined - if null to_be_inlined - then return (consts, funs) + if null to_inline_now + then pure (consts, funs) else do + let inlinemap = + fdmap $ filter ((`S.member` to_inline_now) . funDefName) dont_inline_in (vtable', consts') <- - if any ((`calledByConsts` cg) . funDefName) to_be_inlined + if any (`calledByConsts` cg) to_inline_now then simplifyConsts . performCSEOnStms True - =<< inlineInStms (fdmap to_be_inlined) consts + =<< inlineInStms inlinemap consts else pure (vtable, consts) let simplifyFun' fd - | i `rem` simplifyRate == 0 = + | i `rem` simplify_rate == 0 = copyPropagateInFun simpleSOACS vtable' . performCSEOnFunDef True =<< simplifyFun vtable' fd | otherwise = copyPropagateInFun simpleSOACS vtable' fd - let onFun = - simplifyFun' - <=< inlineInFunDef (fdmap to_be_inlined) + onFun = simplifyFun' <=< inlineInFunDef inlinemap + to_inline_in' <- parMapM onFun to_inline_in - fmap (keep_although_inlined <>) - <$> recurse - (i + 1) - (vtable', consts', not_to_inline_in <> to_inline_in') - keep fd = - isJust (funDefEntryPoint fd) - || funDefName fd `S.member` noninlined + recurse + (i + 1, vtable') + (consts', dont_inline_in <> to_inline_in') + to_inline_later +calledOnce :: CallGraph -> S.Set Name +calledOnce = S.fromList . map fst . filter ((== 1) . snd) . M.toList . numOccurences + +inlineBecauseTiny :: Prog SOACS -> S.Set Name +inlineBecauseTiny = foldMap onFunDef . progFuns + where + onFunDef fd + | length (bodyStms (funDefBody fd)) < 2 + || "inline" `inAttrs` funDefAttrs fd = + S.singleton (funDefName fd) + | otherwise = mempty + +-- Conservative inlining of functions that are called just once, or +-- have #[inline] on them. +consInlineFunctions :: MonadFreshNames m => Prog SOACS -> m (Prog SOACS) +consInlineFunctions prog = + inlineFunctions 4 cg (calledOnce cg <> inlineBecauseTiny prog) prog + where + cg = buildCallGraph prog + +aggInlineFunctions :: MonadFreshNames m => Prog SOACS -> m (Prog SOACS) +aggInlineFunctions prog = + inlineFunctions 3 cg (S.fromList $ map funDefName $ progFuns prog) prog + where + cg = buildCallGraph prog + -- | @inlineInFunDef constf fdmap caller@ inlines in @calleer@ the -- functions in @fdmap@ that are called as @constf@. At this point the -- preconditions are that if @fdmap@ is not empty, and, more @@ -129,40 +144,35 @@ inlineFunction :: MonadFreshNames m => - Pattern -> + Pat -> StmAux dec -> [(SubExp, Diet)] -> (Safety, SrcLoc, [SrcLoc]) -> FunDef SOACS -> - m [Stm] + m (Stms SOACS) inlineFunction pat aux args (safety, loc, locs) fun = do Body _ stms res <- - renameBody $ - mkBody - (stmsFromList param_stms <> stmsFromList body_stms) - (bodyResult (funDefBody fun)) - let res_stms = - certify (stmAuxCerts aux) - <$> zipWith bindSubExp (patternIdents pat) res - pure $ stmsToList stms <> res_stms + renameBody $ mkBody (param_stms <> body_stms) (bodyResult (funDefBody fun)) + pure $ stms <> stmsFromList (zipWith bindSubExpRes (patIdents pat) res) where param_stms = - zipWith - bindSubExp - (map paramIdent $ funDefParams fun) - (map fst args) + stmsFromList $ + certify (stmAuxCerts aux) + <$> zipWith bindSubExp (map paramIdent $ funDefParams fun) (map fst args) body_stms = - stmsToList $ - addLocations (stmAuxAttrs aux) safety (filter notmempty (loc : locs)) $ - bodyStms $ funDefBody fun + addLocations (stmAuxAttrs aux) safety (filter notmempty (loc : locs)) $ + bodyStms $ funDefBody fun -- Note that the sizes of arrays may not be correct at this -- point - it is crucial that we run copy propagation before -- the type checker sees this! bindSubExp ident se = - mkLet [] [ident] $ BasicOp $ SubExp se + mkLet [ident] $ BasicOp $ SubExp se + bindSubExpRes ident (SubExpRes cs se) = + certify cs $ bindSubExp ident se + notmempty = (/= mempty) . locOf inlineInStms :: @@ -185,16 +195,16 @@ not $ "noinline" `inAttrs` funDefAttrs fd, not $ "noinline" `inAttrs` stmAuxAttrs aux = (<>) <$> inlineFunction pat aux args what fd <*> inline rest + inline (stm@(Let _ _ BasicOp {}) : rest) = + (oneStm stm <>) <$> inline rest inline (stm : rest) = - (:) <$> onStm stm <*> inline rest + (<>) <$> (oneStm <$> onStm stm) <*> inline rest inline [] = pure mempty onBody (Body dec stms res) = - Body dec . stmsFromList <$> inline (stmsToList stms) <*> pure res - - onStm (Let pat aux e) = - Let pat aux <$> mapExpM inliner e + Body dec <$> inline (stmsToList stms) <*> pure res + onStm (Let pat aux e) = Let pat aux <$> mapExpM inliner e inliner = identityMapper @@ -203,10 +213,7 @@ } onSOAC = - mapSOACM - identitySOACMapper - { mapOnSOACLambda = onLambda - } + mapSOACM identitySOACMapper {mapOnSOACLambda = onLambda} onLambda (Lambda params body ret) = Lambda params <$> onBody body <*> pure ret @@ -260,15 +267,34 @@ bodyStms body } +-- | Remove functions not ultimately called from an entry point or a +-- constant. +removeDeadFunctionsF :: Prog SOACS -> Prog SOACS +removeDeadFunctionsF prog = + let cg = buildCallGraph prog + live_funs = filter ((`isFunInCallGraph` cg) . funDefName) $ progFuns prog + in prog {progFuns = live_funs} + -- | Inline all functions and remove the resulting dead functions. -inlineFunctions :: Pass SOACS SOACS -inlineFunctions = +inlineAggressively :: Pass SOACS SOACS +inlineAggressively = Pass - { passName = "Inline functions", - passDescription = "Inline and remove resulting dead functions.", - passFunction = copyPropagateInProg simpleSOACS <=< aggInlineFunctions + { passName = "Inline aggressively", + passDescription = "Aggressively inline and remove resulting dead functions.", + passFunction = + copyPropagateInProg simpleSOACS . removeDeadFunctionsF <=< aggInlineFunctions } +-- | Inline some functions and remove the resulting dead functions. +inlineConservatively :: Pass SOACS SOACS +inlineConservatively = + Pass + { passName = "Inline conservatively", + passDescription = "Conservatively inline and remove resulting dead functions.", + passFunction = + copyPropagateInProg simpleSOACS . removeDeadFunctionsF <=< consInlineFunctions + } + -- | @removeDeadFunctions prog@ removes the functions that are unreachable from -- the main function from the program. removeDeadFunctions :: Pass SOACS SOACS @@ -276,12 +302,5 @@ Pass { passName = "Remove dead functions", passDescription = "Remove the functions that are unreachable from entry points", - passFunction = return . pass + passFunction = pure . removeDeadFunctionsF } - where - pass prog = - let cg = buildCallGraph prog - live_funs = - filter ((`isFunInCallGraph` cg) . funDefName) $ - progFuns prog - in prog {progFuns = live_funs} diff --git a/src/Futhark/Optimise/ReuseAllocations.hs b/src/Futhark/Optimise/ReuseAllocations.hs --- a/src/Futhark/Optimise/ReuseAllocations.hs +++ b/src/Futhark/Optimise/ReuseAllocations.hs @@ -18,7 +18,7 @@ import qualified Data.Set as S import qualified Futhark.Analysis.Interference as Interference import qualified Futhark.Analysis.LastUse as LastUse -import Futhark.Binder.Class +import Futhark.Builder.Class import Futhark.Construct import Futhark.IR.GPUMem import qualified Futhark.Optimise.ReuseAllocations.GreedyColoring as GreedyColoring @@ -30,13 +30,13 @@ type Allocs = Map VName (SubExp, Space) getAllocsStm :: Stm GPUMem -> Allocs -getAllocsStm (Let (Pattern [] [PatElem name _]) _ (Op (Alloc se sp))) = +getAllocsStm (Let (Pat [PatElem name _]) _ (Op (Alloc se sp))) = M.singleton name (se, sp) getAllocsStm (Let _ _ (Op (Alloc _ _))) = error "impossible" getAllocsStm (Let _ _ (If _ then_body else_body _)) = foldMap getAllocsStm (bodyStms then_body) <> foldMap getAllocsStm (bodyStms else_body) -getAllocsStm (Let _ _ (DoLoop _ _ _ body)) = +getAllocsStm (Let _ _ (DoLoop _ _ body)) = foldMap getAllocsStm (bodyStms body) getAllocsStm _ = mempty @@ -51,7 +51,7 @@ foldMap getAllocsStm (kernelBodyStms body) setAllocsStm :: Map VName SubExp -> Stm GPUMem -> Stm GPUMem -setAllocsStm m stm@(Let (Pattern [] [PatElem name _]) _ (Op (Alloc _ _))) +setAllocsStm m stm@(Let (Pat [PatElem name _]) _ (Op (Alloc _ _))) | Just s <- M.lookup name m = stm {stmExp = BasicOp $ SubExp s} setAllocsStm _ stm@(Let _ _ (Op (Alloc _ _))) = stm @@ -66,14 +66,10 @@ (else_body {bodyStms = setAllocsStm m <$> bodyStms else_body}) dec } -setAllocsStm m stm@(Let _ _ (DoLoop ctx vals form body)) = +setAllocsStm m stm@(Let _ _ (DoLoop merge form body)) = stm { stmExp = - DoLoop - ctx - vals - form - (body {bodyStms = setAllocsStm m <$> bodyStms body}) + DoLoop merge form (body {bodyStms = setAllocsStm m <$> bodyStms body}) } setAllocsStm _ stm = stm @@ -94,7 +90,7 @@ SegHist lvl sp segbinops tps $ body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body} -maxSubExp :: MonadBinder m => Set SubExp -> m SubExp +maxSubExp :: MonadBuilder m => Set SubExp -> m SubExp maxSubExp = helper . S.toList where helper (s1 : s2 : sexps) = do @@ -110,16 +106,13 @@ definedInExp (If _ then_body else_body _) = foldMap definedInStm (bodyStms then_body) <> foldMap definedInStm (bodyStms else_body) -definedInExp (DoLoop _ _ _ body) = +definedInExp (DoLoop _ _ body) = foldMap definedInStm $ bodyStms body definedInExp _ = mempty definedInStm :: Stm GPUMem -> Set VName -definedInStm Let {stmPattern = Pattern ctx vals, stmExp} = - let definedInside = - ctx <> vals - & fmap patElemName - & S.fromList +definedInStm Let {stmPat = Pat merge, stmExp} = + let definedInside = merge & fmap patElemName & S.fromList in definedInExp stmExp <> definedInside definedInSegOp :: SegOp lvl GPUMem -> Set VName @@ -138,7 +131,7 @@ isKernelInvariant _ _ = True onKernelBodyStms :: - MonadBinder m => + MonadBuilder m => SegOp lvl GPUMem -> (Stms GPUMem -> m (Stms GPUMem)) -> m (SegOp lvl GPUMem) @@ -155,11 +148,11 @@ stms <- f $ kernelBodyStms body return $ SegHist lvl space binops ts $ body {kernelBodyStms = stms} --- | This is the actual optimiser. Given an interference graph and a `SegOp`, +-- | This is the actual optimiser. Given an interference graph and a @SegOp@, -- replace allocations and references to memory blocks inside with a (hopefully) -- reduced number of allocations. optimiseKernel :: - (MonadBinder m, Rep m ~ GPUMem) => + (MonadBuilder m, Rep m ~ GPUMem) => Interference.Graph VName -> SegOp lvl GPUMem -> m (SegOp lvl GPUMem) @@ -221,10 +214,10 @@ (else_body {bodyStms = else_body_stms}) dec } - helper stm@Let {stmExp = DoLoop ctx vals form body} = + helper stm@Let {stmExp = DoLoop merge form body} = inScopeOf stm $ do stms <- f `onKernels` bodyStms body - return $ stm {stmExp = DoLoop ctx vals form (body {bodyStms = stms})} + return $ stm {stmExp = DoLoop merge form (body {bodyStms = stms})} helper stm = inScopeOf stm $ return stm @@ -252,4 +245,4 @@ PassM (Stms GPUMem) onStms graph scope stms = do let m = localScope scope $ optimiseKernel graph `onKernels` stms - fmap fst $ modifyNameSource $ runState (runBinderT m mempty) + fmap fst $ modifyNameSource $ runState (runBuilderT m mempty) diff --git a/src/Futhark/Optimise/ReuseAllocations/GreedyColoring.hs b/src/Futhark/Optimise/ReuseAllocations/GreedyColoring.hs --- a/src/Futhark/Optimise/ReuseAllocations/GreedyColoring.hs +++ b/src/Futhark/Optimise/ReuseAllocations/GreedyColoring.hs @@ -2,18 +2,16 @@ module Futhark.Optimise.ReuseAllocations.GreedyColoring (colorGraph, Coloring) where import Data.Function ((&)) -import Data.Map (Map, (!?)) import qualified Data.Map as M import Data.Maybe (fromMaybe) -import Data.Set (Set) import qualified Data.Set as S import qualified Futhark.Analysis.Interference as Interference -- | A map of values to their color, identified by an integer. -type Coloring a = Map a Int +type Coloring a = M.Map a Int -- | A map of values to the set "neighbors" in the graph -type Neighbors a = Map a (Set a) +type Neighbors a = M.Map a (S.Set a) -- | Computes the neighbor map of a graph. neighbors :: Ord a => Interference.Graph a -> Neighbors a @@ -26,9 +24,9 @@ ) M.empty -firstAvailable :: Eq space => Map Int space -> Set Int -> Int -> space -> (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 !? i) of + case (i `S.member` xs, spaces M.!? i) of (False, Just sp') | sp' == sp -> (spaces, i) (False, Nothing) -> (M.insert i sp spaces, i) _ -> firstAvailable spaces xs (i + 1) sp @@ -37,24 +35,24 @@ (Ord a, Eq space) => Neighbors a -> (a, space) -> - (Map Int space, Coloring a) -> - (Map Int space, Coloring a) + (M.Map Int space, Coloring a) -> + (M.Map Int space, Coloring a) colorNode nbs (x, sp) (spaces, coloring) = let nb_colors = - foldMap (maybe S.empty S.singleton . (coloring !?)) $ - fromMaybe mempty (nbs !? x) + foldMap (maybe S.empty S.singleton . (coloring M.!?)) $ + fromMaybe mempty (nbs M.!? x) (spaces', color) = firstAvailable spaces nb_colors 0 sp in (spaces', M.insert x color coloring) --- | Graph coloring that takes into account the `space` of values. Two values +-- | Graph coloring that takes into account the @space@ of values. Two values -- can only share the same color if they live in the same space. The result is -- map from each color to a space and a map from each value in the input graph -- to it's new color. colorGraph :: (Ord a, Ord space) => - Map a space -> + M.Map a space -> Interference.Graph a -> - (Map Int space, Coloring a) + (M.Map Int space, Coloring a) colorGraph spaces graph = let nodes = S.fromList $ M.toList spaces nbs = neighbors graph 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 @@ -77,7 +77,7 @@ import Futhark.IR.Prop.Aliases import Futhark.Optimise.Simplify.Rep import Futhark.Optimise.Simplify.Rule -import Futhark.Util (nubOrd, splitFromEnd) +import Futhark.Util (nubOrd) data HoistBlockers rep = HoistBlockers { -- | Blocker for hoisting out of parallel loops. @@ -111,12 +111,12 @@ envVtable = mempty } -type Protect m = SubExp -> Pattern (Rep m) -> Op (Rep m) -> Maybe (m ()) +type Protect m = SubExp -> Pat (Rep m) -> Op (Rep m) -> Maybe (m ()) data SimpleOps rep = SimpleOps { mkExpDecS :: ST.SymbolTable (Wise rep) -> - Pattern (Wise rep) -> + Pat (Wise rep) -> Exp (Wise rep) -> SimpleM rep (ExpDec (Wise rep)), mkBodyS :: @@ -127,7 +127,7 @@ -- | Make a hoisted Op safe. The SubExp is a boolean -- that is true when the value of the statement will -- actually be used. - protectHoistedOpS :: Protect (Binder (Wise rep)), + protectHoistedOpS :: Protect (Builder (Wise rep)), opUsageS :: Op (Wise rep) -> UT.UsageTable, simplifyOpS :: SimplifyOp rep (Op rep) } @@ -135,7 +135,7 @@ type SimplifyOp rep op = op -> SimpleM rep (OpWithWisdom op, Stms (Wise rep)) bindableSimpleOps :: - (SimplifiableRep rep, Bindable rep) => + (SimplifiableRep rep, Buildable rep) => SimplifyOp rep (Op rep) -> SimpleOps rep bindableSimpleOps = @@ -149,7 +149,7 @@ = SimpleM ( ReaderT (SimpleOps rep, Env rep) - (State (VNameSource, Bool, Certificates)) + (State (VNameSource, Bool, Certs)) a ) deriving @@ -157,7 +157,7 @@ Functor, Monad, MonadReader (SimpleOps rep, Env rep), - MonadState (VNameSource, Bool, Certificates) + MonadState (VNameSource, Bool, Certs) ) instance MonadFreshNames (SimpleM rep) where @@ -207,7 +207,7 @@ SimpleM rep a localVtable f = local $ \(ops, env) -> (ops, env {envVtable = f $ envVtable env}) -collectCerts :: SimpleM rep a -> SimpleM rep (a, Certificates) +collectCerts :: SimpleM rep a -> SimpleM rep (a, Certs) collectCerts m = do x <- m (a, b, cs) <- get @@ -219,7 +219,7 @@ changed :: SimpleM rep () changed = modify $ \(src, _, cs) -> (src, True, cs) -usedCerts :: Certificates -> SimpleM rep () +usedCerts :: Certs -> SimpleM rep () usedCerts cs = modify $ \(a, b, c) -> (a, b, cs <> c) -- | Indicate in the symbol table that we have descended into a loop. @@ -244,7 +244,7 @@ bindMerge :: SimplifiableRep rep => - [(FParam (Wise rep), SubExp, SubExp)] -> + [(FParam (Wise rep), SubExp, SubExpRes)] -> SimpleM rep a -> SimpleM rep a bindMerge = localVtable . ST.insertLoopMerge @@ -269,7 +269,7 @@ protectIfHoisted cond side m = do (x, stms) <- m ops <- asks $ protectHoistedOpS . fst - runBinder $ do + runBuilder $ do if not $ all (safeExp . stmExp) stms then do cond' <- @@ -288,14 +288,13 @@ protectLoopHoisted :: SimplifiableRep rep => [(FParam (Wise rep), SubExp)] -> - [(FParam (Wise rep), SubExp)] -> LoopForm (Wise rep) -> SimpleM rep (a, Stms (Wise rep)) -> SimpleM rep (a, Stms (Wise rep)) -protectLoopHoisted ctx val form m = do +protectLoopHoisted merge form m = do (x, stms) <- m ops <- asks $ protectHoistedOpS . fst - runBinder $ do + runBuilder $ do if not $ all (safeExp . stmExp) stms then do is_nonempty <- checkIfNonEmpty @@ -307,7 +306,7 @@ case form of WhileLoop cond | Just (_, cond_init) <- - find ((== cond) . paramName . fst) $ ctx ++ val -> + find ((== cond) . paramName . fst) merge -> return cond_init | otherwise -> return $ constant True -- infinite loop ForLoop _ it bound _ -> @@ -315,26 +314,16 @@ BasicOp $ CmpOp (CmpSlt it) (intConst it 0) bound protectIf :: - MonadBinder m => + MonadBuilder m => Protect m -> (Exp (Rep m) -> Bool) -> SubExp -> Stm (Rep m) -> m () -protectIf - _ - _ - taken - ( Let - pat - aux - (If cond taken_body untaken_body (IfDec if_ts IfFallback)) - ) = do - cond' <- letSubExp "protect_cond_conj" $ BasicOp $ BinOp LogAnd taken cond - auxing aux $ - letBind pat $ - If cond' taken_body untaken_body $ - IfDec if_ts IfFallback +protectIf _ _ taken (Let pat aux (If cond taken_body untaken_body (IfDec if_ts IfFallback))) = do + cond' <- letSubExp "protect_cond_conj" $ BasicOp $ BinOp LogAnd taken cond + auxing aux . letBind pat $ + If cond' taken_body untaken_body $ IfDec if_ts IfFallback protectIf _ _ taken (Let pat aux (BasicOp (Assert cond msg loc))) = do not_taken <- letSubExp "loop_not_taken" $ BasicOp $ UnOp Not taken cond' <- letSubExp "protect_assert_disj" $ BasicOp $ BinOp LogOr not_taken cond @@ -350,15 +339,10 @@ Nothing -> do taken_body <- eBody [pure e] untaken_body <- - eBody $ - map - (emptyOfType $ patternContextNames pat) - (patternValueTypes pat) - if_ts <- expTypesFromPattern pat - auxing aux $ - letBind pat $ - If taken taken_body untaken_body $ - IfDec if_ts IfFallback + eBody $ map (emptyOfType $ patNames pat) (patTypes pat) + if_ts <- expTypesFromPat pat + auxing aux . letBind pat $ + If taken taken_body untaken_body $ IfDec if_ts IfFallback protectIf _ _ _ stm = addStm stm @@ -382,7 +366,7 @@ makeSafe _ = Nothing -emptyOfType :: MonadBinder 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 {} = @@ -401,7 +385,7 @@ -- further optimisation.. notWorthHoisting :: ASTRep rep => BlockPred rep notWorthHoisting _ _ (Let pat _ e) = - not (safeExp e) && any ((> 0) . arrayRank) (patternTypes pat) + not (safeExp e) && any ((> 0) . arrayRank) (patTypes pat) hoistStms :: SimplifiableRep rep => @@ -479,7 +463,7 @@ (blocked, Right need) provides :: Stm rep -> [VName] -provides = patternNames . stmPattern +provides = patNames . stmPat expandUsage :: (ASTRep rep, Aliased rep) => @@ -490,7 +474,7 @@ UT.UsageTable expandUsage usageInStm vtable utable stm@(Let pat _ e) = UT.expand (`ST.lookupAliases` vtable) (usageInStm stm <> usageThroughAliases) - <> ( if any (`UT.isSize` utable) (patternNames pat) + <> ( if any (`UT.isSize` utable) (patNames pat) then UT.sizeUsages (freeIn e) else mempty ) @@ -499,7 +483,7 @@ usageThroughAliases = mconcat $ mapMaybe usageThroughBindeeAliases $ - zip (patternNames pat) (patternAliases pat) + zip (patNames pat) (patAliases pat) usageThroughBindeeAliases (name, aliases) = do uses <- UT.lookup name utable return $ mconcat $ map (`UT.usage` uses) $ namesToList aliases @@ -522,7 +506,7 @@ andAlso p1 p2 body vtable need = p1 body vtable need && p2 body vtable need isConsumed :: BlockPred rep -isConsumed _ utable = any (`UT.isConsumed` utable) . patternNames . stmPattern +isConsumed _ utable = any (`UT.isConsumed` utable) . patNames . stmPat isOp :: BlockPred rep isOp _ _ (Let _ _ Op {}) = True @@ -534,7 +518,7 @@ Result -> SimpleM rep (Body (Wise rep)) constructBody stms res = - fmap fst . runBinder . buildBody_ $ do + fmap fst . runBuilder . buildBody_ $ do addStms stms pure res @@ -634,7 +618,7 @@ isNotHoistableBnd _ _ (Let _ _ (BasicOp ArrayLit {})) = False isNotHoistableBnd _ _ (Let _ _ (BasicOp SubExp {})) = False isNotHoistableBnd _ usages (Let pat _ _) - | any (`UT.isSize` usages) $ patternNames pat = + | any (`UT.isSize` usages) $ patNames pat = False isNotHoistableBnd _ _ stm | is_alloc_fun stm = False @@ -675,40 +659,16 @@ -- | Simplify a single 'Result'. The @[Diet]@ only covers the value -- elements, because the context cannot be consumed. simplifyResult :: - SimplifiableRep rep => - [Diet] -> - Result -> - SimpleM rep (Result, UT.UsageTable) + SimplifiableRep rep => [Diet] -> Result -> SimpleM rep (Result, UT.UsageTable) simplifyResult ds res = do - let (ctx_res, val_res) = splitFromEnd (length ds) res - -- Copy propagation is a little trickier here, because there is no - -- place to put the certificates when copy-propagating a certified - -- statement. However, for results in the *context*, it is OK to - -- just throw away the certificates, because for the program to be - -- type-correct, those statements must anyway be used (or - -- copy-propagated into) the statements producing the value result. - (ctx_res', _ctx_res_cs) <- collectCerts $ mapM simplify ctx_res - val_res' <- mapM simplify' val_res - - let consumption = consumeResult $ zip ds val_res' - res' = ctx_res' <> val_res' + res' <- mapM simplify res + let consumption = consumeResult $ zip ds res' return (res', UT.usages (freeIn res') <> consumption) - where - simplify' (Var name) = do - bnd <- ST.lookupSubExp name <$> askVtable - case bnd of - Just (Constant v, cs) - | cs == mempty -> return $ Constant v - Just (Var id', cs) - | cs == mempty -> return $ Var id' - _ -> return $ Var name - simplify' (Constant v) = - return $ Constant v isDoLoopResult :: Result -> UT.UsageTable isDoLoopResult = mconcat . map checkForVar where - checkForVar (Var ident) = UT.inResultUsage ident + checkForVar (SubExpRes _ (Var ident)) = UT.inResultUsage ident checkForVar _ = mempty simplifyStms :: @@ -722,7 +682,7 @@ Just (Let pat (StmAux stm_cs attrs dec) e, stms') -> do stm_cs' <- simplify stm_cs ((e', e_stms), e_cs) <- collectCerts $ simplifyExp e - (pat', pat_cs) <- collectCerts $ simplifyPattern pat + (pat', pat_cs) <- collectCerts $ simplifyPat pat let cs = stm_cs' <> e_cs <> pat_cs inspectStms e_stms $ inspectStm (mkWiseLetStm pat' (StmAux cs attrs dec) e') $ @@ -778,16 +738,12 @@ fbranch' <- simplifyBody ds fbranch (tbranch'', fbranch'', hoisted) <- hoistCommon cond' ifsort tbranch' fbranch' return (If cond' tbranch'' fbranch'' $ IfDec ts' ifsort, hoisted) -simplifyExp (DoLoop ctx val form loopbody) = do - let (ctxparams, ctxinit) = unzip ctx - (valparams, valinit) = unzip val - ctxparams' <- mapM (traverse simplify) ctxparams - ctxinit' <- mapM simplify ctxinit - valparams' <- mapM (traverse simplify) valparams - valinit' <- mapM simplify valinit - let ctx' = zip ctxparams' ctxinit' - val' = zip valparams' valinit' - diets = map (diet . paramDeclType) valparams' +simplifyExp (DoLoop merge form loopbody) = do + let (params, args) = unzip merge + params' <- mapM (traverse simplify) params + args' <- mapM simplify args + let merge' = zip params' args' + diets = map (diet . paramDeclType) params' (form', boundnames, wrapbody) <- case form of ForLoop loopvar it boundexp loopvars -> do boundexp' <- simplify boundexp @@ -799,7 +755,7 @@ ( form', namesFromList (loopvar : map paramName loop_params') <> fparamnames, bindLoopVar loopvar it boundexp' - . protectLoopHoisted ctx' val' form' + . protectLoopHoisted merge' form' . bindArrayLParams loop_params' ) WhileLoop cond -> do @@ -807,31 +763,30 @@ return ( WhileLoop cond', fparamnames, - protectLoopHoisted ctx' val' (WhileLoop cond') + protectLoopHoisted merge' (WhileLoop cond') ) seq_blocker <- asksEngineEnv $ blockHoistSeq . envHoistBlockers ((loopstms, loopres), hoisted) <- - enterLoop $ - consumeMerge $ - bindMerge (zipWith withRes (ctx' ++ val') (bodyResult loopbody)) $ - wrapbody $ - blockIf - ( hasFree boundnames `orIf` isConsumed - `orIf` seq_blocker - `orIf` notWorthHoisting - ) - $ do - ((res, uses), stms) <- simplifyBody diets loopbody - return ((res, uses <> isDoLoopResult res), stms) + enterLoop . consumeMerge $ + bindMerge (zipWith withRes merge' (bodyResult loopbody)) $ + wrapbody $ + blockIf + ( hasFree boundnames `orIf` isConsumed + `orIf` seq_blocker + `orIf` notWorthHoisting + ) + $ do + ((res, uses), stms) <- simplifyBody diets loopbody + return ((res, uses <> isDoLoopResult res), stms) loopbody' <- constructBody loopstms loopres - return (DoLoop ctx' val' form' loopbody', hoisted) + return (DoLoop merge' form' loopbody', hoisted) where fparamnames = - namesFromList (map (paramName . fst) $ ctx ++ val) + namesFromList (map (paramName . fst) merge) consumeMerge = localVtable $ flip (foldl' (flip ST.consume)) $ namesToList consumed_by_merge consumed_by_merge = - freeIn $ map snd $ filter (unique . paramDeclType . fst) val + freeIn $ map snd $ filter (unique . paramDeclType . fst) merge withRes (p, x) y = (p, x, y) simplifyExp (Op op) = do (op', stms) <- simplifyOp op @@ -896,7 +851,7 @@ Simplifiable (BranchType rep), CanBeWise (Op rep), ST.IndexOp (OpWithWisdom (Op rep)), - BinderOps (Wise rep), + BuilderOps (Wise rep), IsOp (Op rep) ) @@ -939,14 +894,18 @@ simplify (Constant v) = return $ Constant v -simplifyPattern :: +instance Simplifiable SubExpRes where + simplify (SubExpRes cs se) = do + cs' <- simplify cs + (se', se_cs) <- collectCerts $ simplify se + pure $ SubExpRes (se_cs <> cs') se' + +simplifyPat :: (SimplifiableRep rep, Simplifiable dec) => - PatternT dec -> - SimpleM rep (PatternT dec) -simplifyPattern pat = - Pattern - <$> mapM inspect (patternContextElements pat) - <*> mapM inspect (patternValueElements pat) + PatT dec -> + SimpleM rep (PatT dec) +simplifyPat (Pat xs) = + Pat <$> mapM inspect xs where inspect (PatElem name rep) = PatElem name <$> simplify rep @@ -991,6 +950,9 @@ 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 + simplify = traverse simplify + simplifyLambda :: SimplifiableRep rep => Lambda rep -> @@ -1023,20 +985,20 @@ rettype' <- simplify rettype return (Lambda params' body' rettype', hoisted) -consumeResult :: [(Diet, SubExp)] -> UT.UsageTable +consumeResult :: [(Diet, SubExpRes)] -> UT.UsageTable consumeResult = mconcat . map inspect where - inspect (Consume, se) = + inspect (Consume, SubExpRes _ se) = mconcat $ map UT.consumedUsage $ namesToList $ subExpAliases se inspect _ = mempty -instance Simplifiable Certificates where - simplify (Certificates ocs) = Certificates . nubOrd . concat <$> mapM check ocs +instance Simplifiable Certs where + simplify (Certs ocs) = Certs . nubOrd . concat <$> mapM check ocs where check idd = do vv <- ST.lookupSubExp idd <$> askVtable case vv of - Just (Constant _, Certificates cs) -> return cs + Just (Constant _, Certs cs) -> return cs Just (Var idd', _) -> return [idd'] _ -> return [idd] 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 @@ -12,11 +12,11 @@ removeLambdaWisdom, removeFunDefWisdom, removeExpWisdom, - removePatternWisdom, + removePatWisdom, removeBodyWisdom, removeScopeWisdom, addScopeWisdom, - addWisdomToPattern, + addWisdomToPat, mkWiseBody, mkWiseLetStm, mkWiseExpDec, @@ -30,7 +30,7 @@ import qualified Data.Kind import qualified Data.Map.Strict as M import Futhark.Analysis.Rephrase -import Futhark.Binder +import Futhark.Builder import Futhark.IR import Futhark.IR.Aliases ( AliasDec (..), @@ -127,8 +127,8 @@ runReaderT m scope instance (ASTRep rep, CanBeWise (Op rep)) => ASTRep (Wise rep) where - expTypesFromPattern = - withoutWisdom . expTypesFromPattern . removePatternWisdom + expTypesFromPat = + withoutWisdom . expTypesFromPat . removePatWisdom instance Pretty VarWisdom where ppr _ = ppr () @@ -187,18 +187,17 @@ removeExpWisdom :: CanBeWise (Op rep) => Exp (Wise rep) -> Exp rep removeExpWisdom = runIdentity . rephraseExp removeWisdom -removePatternWisdom :: PatternT (VarWisdom, a) -> PatternT a -removePatternWisdom = runIdentity . rephrasePattern (return . snd) +removePatWisdom :: PatT (VarWisdom, a) -> PatT a +removePatWisdom = runIdentity . rephrasePat (return . snd) -addWisdomToPattern :: +addWisdomToPat :: (ASTRep rep, CanBeWise (Op rep)) => - Pattern rep -> + Pat rep -> Exp (Wise rep) -> - Pattern (Wise rep) -addWisdomToPattern pat e = - Pattern (map f ctx) (map f val) + Pat (Wise rep) +addWisdomToPat pat e = + Pat $ map f $ Aliases.mkPatAliases pat e where - (ctx, val) = Aliases.mkPatternAliases pat e f pe = let (als, dec) = patElemDec pe in pe `setPatElemDec` (VarWisdom als, dec) @@ -221,17 +220,17 @@ mkWiseLetStm :: (ASTRep rep, CanBeWise (Op rep)) => - Pattern rep -> + Pat rep -> StmAux (ExpDec rep) -> Exp (Wise rep) -> Stm (Wise rep) mkWiseLetStm pat (StmAux cs attrs dec) e = - let pat' = addWisdomToPattern pat e + let pat' = addWisdomToPat pat e in Let pat' (StmAux cs attrs $ mkWiseExpDec pat' dec e) e mkWiseExpDec :: (ASTRep rep, CanBeWise (Op rep)) => - Pattern (Wise rep) -> + Pat (Wise rep) -> ExpDec rep -> Exp (Wise rep) -> ExpDec (Wise rep) @@ -242,17 +241,12 @@ expdec ) -instance - ( Bindable rep, - CanBeWise (Op rep) - ) => - Bindable (Wise rep) - where - mkExpPat ctx val e = - addWisdomToPattern (mkExpPat ctx val $ removeExpWisdom e) e +instance (Buildable rep, CanBeWise (Op rep)) => Buildable (Wise rep) where + mkExpPat ids e = + addWisdomToPat (mkExpPat ids $ removeExpWisdom e) e mkExpDec pat e = - mkWiseExpDec pat (mkExpDec (removePatternWisdom pat) $ removeExpWisdom e) e + mkWiseExpDec pat (mkExpDec (removePatWisdom pat) $ removeExpWisdom e) e mkLetNames names e = do env <- asksScope removeScopeWisdom 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 @@ -58,11 +58,11 @@ import Control.Monad.State import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Analysis.UsageTable as UT -import Futhark.Binder +import Futhark.Builder import Futhark.IR -- | The monad in which simplification rules are evaluated. -newtype RuleM rep a = RuleM (BinderT rep (StateT VNameSource Maybe) a) +newtype RuleM rep a = RuleM (BuilderT rep (StateT VNameSource Maybe) a) deriving ( Functor, Applicative, @@ -72,7 +72,7 @@ LocalScope rep ) -instance (ASTRep rep, BinderOps rep) => MonadBinder (RuleM rep) where +instance (ASTRep rep, BuilderOps rep) => MonadBuilder (RuleM rep) where type Rep (RuleM rep) = rep mkExpDecM pat e = RuleM $ mkExpDecM pat e mkBodyM bnds res = RuleM $ mkBodyM bnds res @@ -90,7 +90,7 @@ Maybe (Stms rep, VNameSource) simplify _ _ Skip = Nothing simplify scope src (Simplify (RuleM m)) = - runStateT (runBinderT_ m scope) src + runStateT (runBuilderT_ m scope) src cannotSimplify :: RuleM rep a cannotSimplify = RuleM $ lift $ lift Nothing @@ -110,7 +110,7 @@ type RuleBasicOp rep a = ( a -> - Pattern rep -> + Pat rep -> StmAux (ExpDec rep) -> BasicOp -> Rule rep @@ -118,7 +118,7 @@ type RuleIf rep a = a -> - Pattern rep -> + Pat rep -> StmAux (ExpDec rep) -> ( SubExp, BodyT rep, @@ -129,10 +129,9 @@ type RuleDoLoop rep a = a -> - Pattern rep -> + Pat rep -> StmAux (ExpDec rep) -> ( [(FParam rep, SubExp)], - [(FParam rep, SubExp)], LoopForm rep, BodyT rep ) -> @@ -140,7 +139,7 @@ type RuleOp rep a = a -> - Pattern rep -> + Pat rep -> StmAux (ExpDec rep) -> Op rep -> Rule rep @@ -290,8 +289,8 @@ 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 ctx val form body)) = - f a pat aux (ctx, val, form, body) +applyRule (RuleDoLoop f) a (Let pat aux (DoLoop merge form body)) = + f a pat aux (merge, form, body) applyRule (RuleIf f) a (Let pat aux (If cond tbody fbody ifsort)) = f a pat aux (cond, tbody, fbody, ifsort) applyRule (RuleOp f) a (Let pat aux (Op op)) = 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 @@ -37,7 +37,7 @@ import Futhark.Optimise.Simplify.Rules.Loop import Futhark.Util -topDownRules :: BinderOps rep => [TopDownRule rep] +topDownRules :: BuilderOps rep => [TopDownRule rep] topDownRules = [ RuleGeneric constantFoldPrimFun, RuleIf ruleIf, @@ -45,7 +45,7 @@ RuleGeneric withAccTopDown ] -bottomUpRules :: BinderOps rep => [BottomUpRule rep] +bottomUpRules :: BuilderOps rep => [BottomUpRule rep] bottomUpRules = [ RuleIf removeDeadBranchResult, RuleGeneric withAccBottomUp, @@ -55,15 +55,15 @@ -- | A set of standard simplification rules. These assume pure -- functional semantics, and so probably should not be applied after -- memory block merging. -standardRules :: (BinderOps rep, Aliased rep) => RuleBook rep +standardRules :: (BuilderOps rep, Aliased rep) => RuleBook rep standardRules = ruleBook topDownRules bottomUpRules <> loopRules <> basicOpRules -- | Turn @copy(x)@ into @x@ iff @x@ is not used after this copy -- statement and it can be consumed. -- -- This simplistic rule is only valid before we introduce memory. -removeUnnecessaryCopy :: (BinderOps rep, Aliased rep) => BottomUpRuleBasicOp rep -removeUnnecessaryCopy (vtable, used) (Pattern [] [d]) _ (Copy v) +removeUnnecessaryCopy :: (BuilderOps rep, Aliased rep) => BottomUpRuleBasicOp rep +removeUnnecessaryCopy (vtable, used) (Pat [d]) _ (Copy v) | not (v `UT.isConsumed` used), (not (v `UT.used` used) && consumable) || not (patElemName d `UT.isConsumed` used) = Simplify $ letBindNames [patElemName d] $ BasicOp $ SubExp $ Var v @@ -78,13 +78,13 @@ consumableFParam = Just . maybe False (unique . declTypeOf) . ST.entryFParam consumableStm e = do - pat <- stmPattern <$> ST.entryStm e - pe <- find ((== v) . patElemName) (patternElements pat) + pat <- stmPat <$> ST.entryStm e + pe <- find ((== v) . patElemName) (patElems pat) guard $ aliasesOf pe == mempty pure True removeUnnecessaryCopy _ _ _ _ = Skip -constantFoldPrimFun :: BinderOps 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, @@ -98,32 +98,32 @@ isConst _ = Nothing constantFoldPrimFun _ _ = Skip -simplifyIndex :: BinderOps rep => BottomUpRuleBasicOp rep -simplifyIndex (vtable, used) pat@(Pattern [] [pe]) (StmAux cs attrs _) (Index idd inds) +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 $ do res <- m attributing attrs $ case res of SubExpResult cs' se -> certifying (cs <> cs') $ - letBindNames (patternNames pat) $ BasicOp $ SubExp se + letBindNames (patNames pat) $ BasicOp $ SubExp se IndexResult extra_cs idd' inds' -> certifying (cs <> extra_cs) $ - letBindNames (patternNames pat) $ BasicOp $ Index idd' inds' + letBindNames (patNames pat) $ BasicOp $ Index idd' inds' where consumed = patElemName pe `UT.isConsumed` used seType (Var v) = ST.lookupType v vtable seType (Constant v) = Just $ Prim $ primValueType v simplifyIndex _ _ _ _ = Skip -ruleIf :: BinderOps rep => TopDownRuleIf rep +ruleIf :: BuilderOps rep => TopDownRuleIf rep ruleIf _ pat _ (e1, tb, fb, IfDec _ ifsort) | Just branch <- checkBranch, ifsort /= IfFallback || isCt1 e1 = Simplify $ do let ses = bodyResult branch addStms $ bodyStms branch sequence_ - [ letBindNames [patElemName p] $ BasicOp $ SubExp se - | (p, se) <- zip (patternElements pat) ses + [ certifying cs $ letBindNames [patElemName p] $ BasicOp $ SubExp se + | (p, SubExpRes cs se) <- zip (patElems pat) ses ] where checkBranch @@ -141,18 +141,18 @@ pat _ ( cond, - Body _ tstms [Constant (BoolValue True)], - Body _ fstms [se], + Body _ tstms [SubExpRes tcs (Constant (BoolValue True))], + Body _ fstms [SubExpRes fcs se], IfDec ts _ ) | null tstms, null fstms, [Prim Bool] <- map extTypeOf ts = - Simplify $ letBind pat $ BasicOp $ BinOp LogOr cond se + Simplify $ certifying (tcs <> fcs) $ letBind pat $ BasicOp $ BinOp LogOr cond se -- When type(x)==bool, if c then x else y == (c && x) || (!c && y) ruleIf _ pat _ (cond, tb, fb, IfDec ts _) - | Body _ tstms [tres] <- tb, - Body _ fstms [fres] <- fb, + | Body _ tstms [SubExpRes tcs tres] <- tb, + Body _ fstms [SubExpRes fcs fres] <- fb, all (safeExp . stmExp) $ tstms <> fstms, all ((== Prim Bool) . extTypeOf) ts = Simplify $ do addStms tstms @@ -166,20 +166,19 @@ (pure $ BasicOp $ UnOp Not cond) (pure $ BasicOp $ SubExp fres) ) - letBind pat e + certifying (tcs <> fcs) $ letBind pat e ruleIf _ pat _ (_, tbranch, _, IfDec _ IfFallback) - | null $ patternContextNames pat, - all (safeExp . stmExp) $ bodyStms tbranch = Simplify $ do + | all (safeExp . stmExp) $ bodyStms tbranch = Simplify $ do let ses = bodyResult tbranch addStms $ bodyStms tbranch sequence_ - [ letBindNames [patElemName p] $ BasicOp $ SubExp se - | (p, se) <- zip (patternElements pat) ses + [ certifying cs $ letBindNames [patElemName p] $ BasicOp $ SubExp se + | (p, SubExpRes cs se) <- zip (patElems pat) ses ] ruleIf _ pat _ (cond, tb, fb, _) - | Body _ _ [Constant (IntValue t)] <- tb, - Body _ _ [Constant (IntValue f)] <- fb = - if oneIshInt t && zeroIshInt f + | Body _ _ [SubExpRes tcs (Constant (IntValue t))] <- tb, + Body _ _ [SubExpRes fcs (Constant (IntValue f))] <- fb = + if oneIshInt t && zeroIshInt f && tcs == mempty && fcs == mempty then Simplify $ letBind pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond @@ -192,85 +191,72 @@ ruleIf _ _ _ _ = Skip -- | Move out results of a conditional expression whose computation is --- either invariant to the branches (only done for results in the --- context), or the same in both branches. -hoistBranchInvariant :: BinderOps rep => TopDownRuleIf rep +-- either invariant to the branches (only done for results used for +-- existentials), or the same in both branches. +hoistBranchInvariant :: BuilderOps rep => TopDownRuleIf rep hoistBranchInvariant _ pat _ (cond, tb, fb, IfDec ret ifsort) = Simplify $ do let tses = bodyResult tb fses = bodyResult fb (hoistings, (pes, ts, res)) <- - fmap (fmap unzip3 . partitionEithers) $ - mapM branchInvariant $ - zip3 - (patternElements pat) - (map Left [0 .. num_ctx -1] ++ map Right ret) - (zip tses fses) + fmap (fmap unzip3 . partitionEithers) . mapM branchInvariant $ + zip4 [0 ..] (patElems pat) ret (zip tses fses) let ctx_fixes = catMaybes hoistings (tses', fses') = unzip res tb' = tb {bodyResult = tses'} fb' = fb {bodyResult = fses'} - ret' = foldr (uncurry fixExt) (rights ts) ctx_fixes - (ctx_pes, val_pes) = splitFromEnd (length ret') pes + ret' = foldr (uncurry fixExt) ts ctx_fixes if not $ null hoistings -- Was something hoisted? then do -- We may have to add some reshapes if we made the type -- less existential. tb'' <- reshapeBodyResults tb' $ map extTypeOf ret' fb'' <- reshapeBodyResults fb' $ map extTypeOf ret' - letBind (Pattern ctx_pes val_pes) $ - If cond tb'' fb'' (IfDec ret' ifsort) + letBind (Pat pes) $ If cond tb'' fb'' (IfDec ret' ifsort) else cannotSimplify where - num_ctx = length $ patternContextElements pat bound_in_branches = - namesFromList $ - concatMap (patternNames . stmPattern) $ - bodyStms tb <> bodyStms fb - mem_sizes = freeIn $ filter (isMem . patElemType) $ patternElements pat + namesFromList . concatMap (patNames . stmPat) $ + bodyStms tb <> bodyStms fb invariant Constant {} = True invariant (Var v) = not $ v `nameIn` bound_in_branches - isMem Mem {} = True - isMem _ = False - sizeOfMem v = v `nameIn` mem_sizes - - branchInvariant (pe, t, (tse, fse)) + branchInvariant (i, pe, t, (tse, fse)) -- Do both branches return the same value? | tse == fse = do - letBindNames [patElemName pe] $ BasicOp $ SubExp tse - hoisted pe t + certifying (resCerts tse <> resCerts fse) $ + letBindNames [patElemName pe] $ BasicOp $ SubExp $ resSubExp tse + hoisted i pe -- Do both branches return values that are free in the -- branch, and are we not the only pattern element? The -- latter is to avoid infinite application of this rule. - | invariant tse, - invariant fse, - patternSize pat > 1, - Prim _ <- patElemType pe, - not $ sizeOfMem $ patElemName pe = do - bt <- expTypesFromPattern $ Pattern [] [pe] + | invariant $ resSubExp tse, + invariant $ resSubExp fse, + patSize pat > 1, + Prim _ <- patElemType pe = do + bt <- expTypesFromPat $ Pat [pe] letBindNames [patElemName pe] - =<< ( If cond <$> resultBodyM [tse] - <*> resultBodyM [fse] + =<< ( If cond <$> resultBodyM [resSubExp tse] + <*> resultBodyM [resSubExp fse] <*> pure (IfDec bt ifsort) ) - hoisted pe t + hoisted i pe | otherwise = - return $ Right (pe, t, (tse, fse)) + pure $ Right (pe, t, (tse, fse)) - hoisted pe (Left i) = return $ Left $ Just (i, Var $ patElemName pe) - hoisted _ Right {} = return $ Left Nothing + hoisted i pe = pure $ Left $ Just (i, Var $ patElemName pe) reshapeBodyResults body rets = buildBody_ $ do ses <- bodyBind body let (ctx_ses, val_ses) = splitFromEnd (length rets) ses (ctx_ses ++) <$> zipWithM reshapeResult val_ses rets - reshapeResult (Var v) t@Array {} = do + reshapeResult (SubExpRes cs (Var v)) t@Array {} = do v_t <- lookupType v let newshape = arrayDims $ removeExistentials t v_t - if newshape /= arrayDims v_t - then letSubExp "branch_ctx_reshaped" $ shapeCoerce newshape v - else return $ Var v + SubExpRes cs + <$> if newshape /= arrayDims v_t + then letSubExp "branch_ctx_reshaped" (shapeCoerce newshape v) + else pure $ Var v reshapeResult se _ = return se @@ -278,12 +264,12 @@ -- 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 :: BinderOps rep => BottomUpRuleIf rep +removeDeadBranchResult :: BuilderOps rep => BottomUpRuleIf rep removeDeadBranchResult (_, used) pat _ (e1, tb, fb, IfDec rettype ifsort) - | -- Only if there is no existential context... - patternSize pat == length rettype, + | -- Only if there is no existential binding... + not $ any (`nameIn` foldMap freeIn (patElems pat)) (patNames pat), -- Figure out which of the names in 'pat' are used... - patused <- map (`UT.isUsedDirectly` used) $ patternNames pat, + patused <- map (`UT.isUsedDirectly` used) $ patNames pat, -- If they are not all used, then this rule applies. not (and patused) = -- Remove the parts of the branch-results that correspond to dead @@ -295,17 +281,17 @@ pick = map snd . filter fst . zip patused tb' = tb {bodyResult = pick tses} fb' = fb {bodyResult = pick fses} - pat' = pick $ patternElements pat + pat' = pick $ patElems pat rettype' = pick rettype - in Simplify $ letBind (Pattern [] pat') $ If e1 tb' fb' $ IfDec rettype' ifsort + in Simplify $ letBind (Pat pat') $ If e1 tb' fb' $ IfDec rettype' ifsort | otherwise = Skip -withAccTopDown :: BinderOps 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 - forM_ (zip (patternNames pat) lam_res) $ \(v, se) -> - letBindNames [v] $ BasicOp $ SubExp se + forM_ (zip (patNames pat) lam_res) $ \(v, SubExpRes cs se) -> + certifying cs $ letBindNames [v] $ BasicOp $ SubExp se -- Identify those results in 'lam' that are free and move them out. withAccTopDown vtable (Let pat aux (WithAcc inputs lam)) = Simplify . auxing aux $ do let (cert_params, acc_params) = @@ -313,7 +299,7 @@ (acc_res, nonacc_res) = splitFromEnd num_nonaccs $ bodyResult $ lambdaBody lam (acc_pes, nonacc_pes) = - splitFromEnd num_nonaccs $ patternElements pat + splitFromEnd num_nonaccs $ patElems pat -- Look at accumulator results. (acc_pes', inputs', params', acc_res') <- @@ -335,38 +321,41 @@ mkLambda (cert_params' ++ acc_params') $ bodyBind $ (lambdaBody lam) {bodyResult = acc_res' <> nonacc_res'} - letBind (Pattern [] (concat acc_pes' <> nonacc_pes')) $ WithAcc inputs' lam' + letBind (Pat (concat acc_pes' <> nonacc_pes')) $ WithAcc inputs' lam' where num_nonaccs = length (lambdaReturnType lam) - length inputs inputArrs (_, arrs, _) = length arrs - tryMoveAcc (pes, (_, arrs, _), (_, acc_p), Var v) - | paramName acc_p == v = do + tryMoveAcc (pes, (_, arrs, _), (_, acc_p), SubExpRes cs (Var v)) + | paramName acc_p == v, + cs == mempty = do forM_ (zip pes arrs) $ \(pe, arr) -> letBindNames [patElemName pe] $ BasicOp $ SubExp $ Var arr pure Nothing tryMoveAcc x = pure $ Just x - tryMoveNonAcc (pe, Var v) - | v `ST.elem` vtable = do + tryMoveNonAcc (pe, SubExpRes cs (Var v)) + | v `ST.elem` vtable, + cs == mempty = do letBindNames [patElemName pe] $ BasicOp $ SubExp $ Var v pure Nothing - tryMoveNonAcc (pe, Constant v) = do - letBindNames [patElemName pe] $ BasicOp $ SubExp $ Constant v - pure Nothing + tryMoveNonAcc (pe, SubExpRes cs (Constant v)) + | cs == mempty = do + letBindNames [patElemName pe] $ BasicOp $ SubExp $ Constant v + pure Nothing tryMoveNonAcc x = pure $ Just x withAccTopDown _ _ = Skip -withAccBottomUp :: BinderOps rep => BottomUpRuleGeneric rep +withAccBottomUp :: BuilderOps rep => BottomUpRuleGeneric rep -- Eliminate dead results. withAccBottomUp (_, utable) (Let pat aux (WithAcc inputs lam)) - | not $ all (`UT.used` utable) $ patternNames pat = Simplify $ do + | not $ all (`UT.used` utable) $ patNames pat = Simplify $ do let (acc_res, nonacc_res) = splitFromEnd num_nonaccs $ bodyResult $ lambdaBody lam (acc_pes, nonacc_pes) = - splitFromEnd num_nonaccs $ patternElements pat + splitFromEnd num_nonaccs $ patElems pat (cert_params, acc_params) = splitAt (length inputs) $ lambdaParams lam @@ -392,7 +381,7 @@ void $ bodyBind $ lambdaBody lam pure $ acc_res' ++ nonacc_res' - auxing aux $ letBind (Pattern [] pes') $ WithAcc inputs' lam' + auxing aux $ letBind (Pat pes') $ WithAcc inputs' lam' where num_nonaccs = length (lambdaReturnType lam) - length inputs inputArrs (_, arrs, _) = length arrs 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 @@ -4,7 +4,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-incomplete-patterns -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates #-} --- | Some simplification rules for 'BasicOp'. +-- | Some simplification rules for t'BasicOp'. module Futhark.Optimise.Simplify.Rules.BasicOp ( basicOpRules, ) @@ -35,7 +35,7 @@ | ArgReplicate [SubExp] SubExp | ArgVar VName -toConcatArg :: ST.SymbolTable rep -> VName -> (ConcatArg, Certificates) +toConcatArg :: ST.SymbolTable rep -> VName -> (ConcatArg, Certs) toConcatArg vtable v = case ST.lookupBasicOp v vtable of Just (ArrayLit ses _, cs) -> @@ -46,9 +46,9 @@ (ArgVar v, mempty) fromConcatArg :: - MonadBinder m => + MonadBuilder m => Type -> - (ConcatArg, Certificates) -> + (ConcatArg, Certs) -> m VName fromConcatArg t (ArgArrayLit ses, cs) = certifying cs $ letExp "concat_lit" $ BasicOp $ ArrayLit ses $ rowType t @@ -61,9 +61,9 @@ pure v fuseConcatArg :: - [(ConcatArg, Certificates)] -> - (ConcatArg, Certificates) -> - [(ConcatArg, Certificates)] + [(ConcatArg, Certs)] -> + (ConcatArg, Certs) -> + [(ConcatArg, Certs)] fuseConcatArg xs (ArgArrayLit [], _) = xs fuseConcatArg xs (ArgReplicate [w] se, cs) @@ -79,7 +79,7 @@ fuseConcatArg xs y = y : xs -simplifyConcat :: BinderOps 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, @@ -142,7 +142,7 @@ forSingleArray ys = ys simplifyConcat _ _ _ _ = Skip -ruleBasicOp :: BinderOps 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' @@ -150,22 +150,21 @@ defOf = (`ST.lookupExp` vtable) seType (Var v) = ST.lookupType v vtable seType (Constant v) = Just $ Prim $ primValueType v -ruleBasicOp vtable pat _ (Update src _ (Var v)) +ruleBasicOp vtable pat _ (Update _ src _ (Var v)) | Just (BasicOp Scratch {}, _) <- ST.lookupExp v vtable = Simplify $ letBind pat $ BasicOp $ SubExp $ Var src -- If we are writing a single-element slice from some array, and the -- element of that array can be computed as a PrimExp based on the -- index, let's just write that instead. -ruleBasicOp vtable pat aux (Update src [DimSlice i n s] (Var v)) +ruleBasicOp vtable pat aux (Update safety src (Slice [DimSlice i n s]) (Var v)) | isCt1 n, isCt1 s, Just (ST.Indexed cs e) <- ST.index v [intConst Int64 0] vtable = Simplify $ do e' <- toSubExp "update_elem" e - auxing aux $ - certifying cs $ - letBind pat $ BasicOp $ Update src [DimFix i] e' -ruleBasicOp vtable pat _ (Update dest destis (Var v)) + auxing aux . certifying cs $ + letBind pat $ BasicOp $ Update safety src (Slice [DimFix i]) e' +ruleBasicOp vtable pat _ (Update _ dest destis (Var v)) | Just (e, _) <- ST.lookupExp v vtable, arrayFrom e = Simplify $ letBind pat $ BasicOp $ SubExp $ Var dest @@ -182,7 +181,7 @@ True arrayFrom _ = False -ruleBasicOp vtable pat _ (Update dest is se) +ruleBasicOp vtable pat _ (Update _ dest is se) | Just dest_t <- ST.lookupType dest vtable, isFullSlice (arrayShape dest_t) is = Simplify $ case se of @@ -192,8 +191,8 @@ BasicOp $ Reshape (map DimNew $ arrayDims dest_t) v letBind pat $ BasicOp $ Copy v_reshaped _ -> letBind pat $ BasicOp $ ArrayLit [se] $ rowType dest_t -ruleBasicOp vtable pat (StmAux cs1 attrs _) (Update dest1 is1 (Var v1)) - | Just (Update dest2 is2 se2, cs2) <- ST.lookupBasicOp v1 vtable, +ruleBasicOp vtable pat (StmAux cs1 attrs _) (Update safety1 dest1 is1 (Var v1)) + | Just (Update safety2 dest2 is2 se2, cs2) <- ST.lookupBasicOp v1 vtable, Just (Copy v3, cs3) <- ST.lookupBasicOp dest2 vtable, Just (Index v4 is4, cs4) <- ST.lookupBasicOp v3 vtable, is4 == is1, @@ -201,7 +200,7 @@ Simplify $ certifying (cs1 <> cs2 <> cs3 <> cs4) $ do is5 <- subExpSlice $ sliceSlice (primExpSlice is1) (primExpSlice is2) - attributing attrs $ letBind pat $ BasicOp $ Update dest1 is5 se2 + attributing attrs $ letBind pat $ BasicOp $ Update (max safety1 safety2) dest1 is5 se2 ruleBasicOp vtable pat _ (CmpOp (CmpEq t) se1 se2) | Just m <- simplifyWith se1 se2 = Simplify m | Just m <- simplifyWith se2 se1 = Simplify m @@ -210,7 +209,7 @@ | Just bnd <- ST.lookupStm v vtable, If p tbranch fbranch _ <- stmExp bnd, Just (y, z) <- - returns v (stmPattern bnd) tbranch fbranch, + returns v (stmPat bnd) tbranch fbranch, not $ boundInBody tbranch `namesIntersect` freeIn y, not $ boundInBody fbranch `namesIntersect` freeIn z = Just $ do eq_x_y <- @@ -229,10 +228,9 @@ Nothing returns v ifpat tbranch fbranch = - fmap snd $ - find ((== v) . patElemName . fst) $ - zip (patternValueElements ifpat) $ - zip (bodyResult tbranch) (bodyResult fbranch) + fmap snd . find ((== v) . patElemName . fst) $ + zip (patElems ifpat) $ + zip (map resSubExp (bodyResult tbranch)) (map resSubExp (bodyResult fbranch)) ruleBasicOp _ pat _ (Replicate (Shape []) se@Constant {}) = Simplify $ letBind pat $ BasicOp $ SubExp se ruleBasicOp _ pat _ (Replicate (Shape []) (Var v)) = Simplify $ do @@ -270,12 +268,14 @@ (map pe64 inds) new_inds' <- mapM (toSubExp "new_index") new_inds - certifying idd_cs $ - auxing aux $ - letBind pat $ BasicOp $ Index idd2 $ map DimFix new_inds' -ruleBasicOp _ pat _ (BinOp (Pow t) e1 e2) - | e1 == intConst t 2 = - Simplify $ letBind pat $ BasicOp $ BinOp (Shl t) (intConst t 1) e2 + certifying idd_cs . auxing aux $ + letBind pat $ BasicOp $ Index idd2 $ Slice $ map DimFix new_inds' + +-- Copying an iota is pointless; just make it an iota instead. +ruleBasicOp vtable pat aux (Copy v) + | Just (Iota n x s it, v_cs) <- ST.lookupBasicOp v vtable = + Simplify . certifying v_cs . auxing aux $ + letBind pat $ BasicOp $ Iota n x s it -- Handle identity permutation. ruleBasicOp _ pat _ (Rearrange perm v) | sort perm == perm = @@ -283,10 +283,8 @@ ruleBasicOp vtable pat aux (Rearrange perm v) | Just (BasicOp (Rearrange perm2 e), v_cs) <- ST.lookupExp v vtable = -- Rearranging a rearranging: compose the permutations. - Simplify $ - certifying v_cs $ - auxing aux $ - letBind pat $ BasicOp $ Rearrange (perm `rearrangeCompose` perm2) e + Simplify . certifying v_cs . auxing aux $ + letBind pat $ BasicOp $ Rearrange (perm `rearrangeCompose` perm2) e ruleBasicOp vtable pat aux (Rearrange perm v) | Just (BasicOp (Rotate offsets v2), v_cs) <- ST.lookupExp v vtable, Just (BasicOp (Rearrange perm3 v3), v2_cs) <- ST.lookupExp v2 vtable = Simplify $ do @@ -340,20 +338,19 @@ -- 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. -ruleBasicOp vtable pat aux (Update arr_x slice_x (Var v)) - | Just _ <- sliceIndices slice_x, - Just (Index arr_y slice_y, cs_y) <- ST.lookupBasicOp v vtable, +ruleBasicOp 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, ST.available arr_y vtable, -- XXX: we should check for proper aliasing here instead. arr_y /= arr_x, Just (slice_x_bef, DimFix i, []) <- focusNth (length slice_x - 1) slice_x, Just (slice_y_bef, DimFix j, []) <- focusNth (length slice_y - 1) slice_y = Simplify $ do - let slice_x' = slice_x_bef ++ [DimSlice i (intConst Int64 1) (intConst Int64 1)] - slice_y' = slice_y_bef ++ [DimSlice j (intConst Int64 1) (intConst Int64 1)] + let slice_x' = Slice $ slice_x_bef ++ [DimSlice i (intConst Int64 1) (intConst Int64 1)] + slice_y' = Slice $ slice_y_bef ++ [DimSlice j (intConst Int64 1) (intConst Int64 1)] v' <- letExp (baseString v ++ "_slice") $ BasicOp $ Index arr_y slice_y' - certifying cs_y $ - auxing aux $ - letBind pat $ BasicOp $ Update arr_x slice_x' $ Var v' + certifying cs_y . auxing aux $ + letBind pat $ BasicOp $ Update safety arr_x slice_x' $ Var v' -- Simplify away 0<=i when 'i' is from a loop of form 'for i < n'. ruleBasicOp vtable pat aux (CmpOp CmpSle {} x y) @@ -372,20 +369,30 @@ | isCt0 y, maybe False ST.entryIsSize $ ST.lookup x vtable = Simplify $ auxing aux $ letBind pat $ BasicOp $ SubExp $ constant False +-- Remove certificates for variables whose definition already contain +-- that certificate. +ruleBasicOp vtable pat aux (SubExp (Var v)) + | cs <- unCerts $ stmAuxCerts aux, + not $ null cs, + Just v_cs <- unCerts . stmCerts <$> ST.lookupStm v vtable, + cs' <- filter (`notElem` v_cs) cs, + cs' /= cs = + Simplify . certifying (Certs cs') $ + letBind pat $ BasicOp $ SubExp $ Var v ruleBasicOp _ _ _ _ = Skip -topDownRules :: BinderOps rep => [TopDownRule rep] +topDownRules :: BuilderOps rep => [TopDownRule rep] topDownRules = [ RuleBasicOp ruleBasicOp ] -bottomUpRules :: BinderOps rep => [BottomUpRule rep] +bottomUpRules :: BuilderOps rep => [BottomUpRule rep] bottomUpRules = [ RuleBasicOp simplifyConcat ] --- | A set of simplification rules for 'BasicOp's. Includes rules +-- | A set of simplification rules for t'BasicOp's. Includes rules -- from "Futhark.Optimise.Simplify.Rules.Simple". -basicOpRules :: (BinderOps rep, Aliased rep) => RuleBook rep +basicOpRules :: (BuilderOps rep, Aliased rep) => RuleBook rep basicOpRules = ruleBook topDownRules bottomUpRules <> loopRules 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 @@ -39,9 +39,9 @@ -- | @foldClosedForm look foldfun accargs arrargs@ determines whether -- each of the results of @foldfun@ can be expressed in a closed form. foldClosedForm :: - (ASTRep rep, BinderOps rep) => + (ASTRep rep, BuilderOps rep) => VarLookup rep -> - Pattern rep -> + Pat rep -> Lambda rep -> [SubExp] -> [VName] -> @@ -49,13 +49,13 @@ foldClosedForm look pat lam accs arrs = do inputsize <- arraysSize 0 <$> mapM lookupType arrs - t <- case patternTypes pat of + t <- case patTypes pat of [Prim t] -> return t _ -> cannotSimplify closedBody <- checkResults - (patternNames pat) + (patNames pat) inputsize mempty Int64 @@ -78,8 +78,8 @@ -- | @loopClosedForm pat respat merge bound bodys@ determines whether -- the do-loop can be expressed in a closed form. loopClosedForm :: - (ASTRep rep, BinderOps rep) => - Pattern rep -> + (ASTRep rep, BuilderOps rep) => + Pat rep -> [(FParam rep, SubExp)] -> Names -> IntType -> @@ -87,7 +87,7 @@ Body rep -> RuleM rep () loopClosedForm pat merge i it bound body = do - t <- case patternTypes pat of + t <- case patTypes pat of [Prim t] -> return t _ -> cannotSimplify @@ -118,7 +118,7 @@ knownBnds = M.fromList $ zip mergenames mergeexp checkResults :: - BinderOps rep => + BuilderOps rep => [VName] -> SubExp -> Names -> @@ -133,7 +133,7 @@ ((), bnds) <- collectStms $ zipWithM_ checkResult (zip pat res) (zip accparams accs) - mkBodyM bnds $ map Var pat + mkBodyM bnds $ varsRes pat where bndMap = makeBindMap body (accparams, _) = splitAt (length accs) params @@ -141,8 +141,9 @@ nonFree = boundInBody body <> namesFromList params <> untouchable - checkResult (p, Var v) (accparam, acc) - | Just (BasicOp (BinOp bop x y)) <- M.lookup v bndMap = do + checkResult (p, SubExpRes _ (Var v)) (accparam, acc) + | Just (BasicOp (BinOp bop x y)) <- M.lookup v bndMap, + x /= y = do -- One of x,y must be *this* accumulator, and the other must -- be something that is free in the body. let isThisAccum = (== Var accparam) @@ -157,8 +158,8 @@ case bop of LogAnd -> letBindNames [p] $ BasicOp $ BinOp LogAnd this el - Add t w | Just properly_typed_size <- properIntSize t -> do - size' <- properly_typed_size + Add t w -> do + size' <- asIntS t size letBindNames [p] =<< eBinOp (Add t w) @@ -179,12 +180,6 @@ | v `nameIn` nonFree = M.lookup v knownBnds asFreeSubExp se = Just se - properIntSize Int64 = Just $ return size - properIntSize t = - Just $ - letSubExp "converted_size" $ - BasicOp $ ConvOp (SExt it t) size - properFloatSize t = Just $ letSubExp "converted_size" $ @@ -218,6 +213,6 @@ makeBindMap :: Body rep -> M.Map VName (Exp rep) makeBindMap = M.fromList . mapMaybe isSingletonStm . stmsToList . bodyStms where - isSingletonStm (Let pat _ e) = case patternNames pat of + isSingletonStm (Let pat _ e) = case patNames pat of [v] -> Just (v, e) _ -> Nothing 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 @@ -23,42 +23,43 @@ isCt0 (Constant v) = zeroIsh v isCt0 _ = False --- | Some index expressions can be simplified to 'SubExp's, while +-- | Some index expressions can be simplified to t'SubExp's, while -- others produce another index expression (which may be further -- simplifiable). data IndexResult - = IndexResult Certificates VName (Slice SubExp) - | SubExpResult Certificates SubExp + = IndexResult Certs VName (Slice SubExp) + | SubExpResult Certs SubExp -- | Try to simplify an index operation. simplifyIndexing :: - MonadBinder m => + MonadBuilder m => ST.SymbolTable (Rep m) -> TypeLookup -> VName -> Slice SubExp -> Bool -> Maybe (m IndexResult) -simplifyIndexing vtable seType idd inds consuming = +simplifyIndexing vtable seType idd (Slice inds) consuming = case defOf idd of _ | Just t <- seType (Var idd), - inds == fullSlice t [] -> + Slice inds == fullSlice t [] -> Just $ pure $ SubExpResult mempty $ Var idd - | Just inds' <- sliceIndices inds, + | Just inds' <- sliceIndices (Slice inds), Just (ST.Indexed cs e) <- ST.index idd inds' vtable, worthInlining e, - all (`ST.elem` vtable) (unCertificates cs) -> + all (`ST.elem` vtable) (unCerts cs) -> Just $ SubExpResult cs <$> toSubExp "index_primexp" e - | Just inds' <- sliceIndices inds, + | Just inds' <- sliceIndices (Slice inds), Just (ST.IndexedArray cs arr inds'') <- ST.index idd inds' vtable, all (worthInlining . untyped) inds'', - all (`ST.elem` vtable) (unCertificates cs) -> + all (`ST.elem` vtable) (unCerts cs) -> Just $ - IndexResult cs arr . map DimFix + IndexResult cs arr . Slice . map DimFix <$> mapM (toSubExp "index_primexp") inds'' Nothing -> Nothing - Just (SubExp (Var v), cs) -> Just $ pure $ IndexResult cs v inds + Just (SubExp (Var v), cs) -> + Just $ pure $ IndexResult cs v $ Slice inds Just (Iota _ x s to_it, cs) | [DimFix ii] <- inds, Just (Prim (IntType from_it)) <- seType ii -> @@ -101,17 +102,23 @@ DimFix <$> adjustI i o d adjust (DimSlice i n s, o, d) = DimSlice <$> adjustI i o d <*> pure n <*> pure s - IndexResult cs a <$> mapM adjust (zip3 inds offsets dims) + IndexResult cs a . Slice <$> mapM adjust (zip3 inds offsets dims) where rotateAndSlice r DimSlice {} = not $ isCt0 r rotateAndSlice _ _ = False Just (Index aa ais, cs) -> Just $ IndexResult cs aa - <$> subExpSlice (sliceSlice (primExpSlice ais) (primExpSlice inds)) + <$> subExpSlice (sliceSlice (primExpSlice ais) (primExpSlice (Slice inds))) Just (Replicate (Shape [_]) (Var vv), cs) - | [DimFix {}] <- inds, not consuming -> Just $ pure $ SubExpResult cs $ Var vv - | DimFix {} : is' <- inds, not consuming -> Just $ pure $ IndexResult cs vv is' + | [DimFix {}] <- inds, + not consuming, + ST.available vv vtable -> + Just $ pure $ SubExpResult cs $ Var vv + | DimFix {} : is' <- inds, + not consuming, + ST.available vv vtable -> + Just $ pure $ IndexResult cs vv $ Slice is' Just (Replicate (Shape [_]) val@(Constant _), cs) | [DimFix {}] <- inds, not consuming -> Just $ pure $ SubExpResult cs val Just (Replicate (Shape ds) v, cs) @@ -120,14 +127,14 @@ ds' /= ds -> Just $ do arr <- letExp "smaller_replicate" $ BasicOp $ Replicate (Shape ds') v - return $ IndexResult cs arr $ ds_inds' ++ rest_inds + return $ IndexResult cs arr $ Slice $ ds_inds' ++ rest_inds where index DimFix {} = Nothing index (DimSlice _ n s) = Just (n, DimSlice (constant (0 :: Int64)) n s) Just (Rearrange perm src, cs) | rearrangeReach perm <= length (takeWhile isIndex inds) -> let inds' = rearrangeShape (rearrangeInverse perm) inds - in Just $ pure $ IndexResult cs src inds' + in Just $ pure $ IndexResult cs src $ Slice inds' where isIndex DimFix {} = True isIndex _ = False @@ -136,25 +143,27 @@ length inds == length dims, -- It is generally not safe to simplify a slice of a copy, -- because the result may be used in an in-place update of the - -- original. - Just _ <- mapM dimFix inds, + -- original. But we know this can only happen if the original + -- is bound the same depth as we are! + all (isJust . dimFix) inds + || maybe True ((ST.loopDepth vtable /=) . ST.entryDepth) (ST.lookup src vtable), not consuming, ST.available src vtable -> - Just $ pure $ IndexResult cs src inds + Just $ pure $ IndexResult cs src $ Slice inds Just (Reshape newshape src, cs) | Just newdims <- shapeCoercion newshape, Just olddims <- arrayDims <$> seType (Var src), changed_dims <- zipWith (/=) newdims olddims, not $ or $ drop (length inds) changed_dims -> - Just $ pure $ IndexResult cs src inds + Just $ pure $ IndexResult cs src $ Slice inds | Just newdims <- shapeCoercion newshape, Just olddims <- arrayDims <$> seType (Var src), length newshape == length inds, length olddims == length newdims -> - Just $ pure $ IndexResult cs src inds + Just $ pure $ IndexResult cs src $ Slice inds Just (Reshape [_] v2, cs) | Just [_] <- arrayDims <$> seType (Var v2) -> - Just $ pure $ IndexResult cs v2 inds + Just $ pure $ IndexResult cs v2 $ Slice inds Just (Concat d x xs _, cs) | -- HACK: simplifying the indexing of an N-array concatenation -- is going to produce an N-deep if expression, which is bad @@ -166,7 +175,7 @@ not $ any isConcat $ x : xs, Just (ibef, DimFix i, iaft) <- focusNth d inds, Just (Prim res_t) <- - (`setArrayDims` sliceDims inds) + (`setArrayDims` sliceDims (Slice inds)) <$> ST.lookupType x vtable -> Just $ do x_len <- arraySize d <$> lookupType x xs_lens <- mapM (fmap (arraySize d) . lookupType) xs @@ -178,15 +187,16 @@ let xs_and_starts = reverse $ zip xs starts let mkBranch [] = - letSubExp "index_concat" $ BasicOp $ Index x $ ibef ++ DimFix i : iaft + letSubExp "index_concat" $ BasicOp $ Index x $ Slice $ ibef ++ DimFix i : iaft mkBranch ((x', start) : xs_and_starts') = do cmp <- letSubExp "index_concat_cmp" $ BasicOp $ CmpOp (CmpSle Int64) start i (thisres, thisbnds) <- collectStms $ do i' <- letSubExp "index_concat_i" $ BasicOp $ BinOp (Sub Int64 OverflowWrap) i start - letSubExp "index_concat" $ BasicOp $ Index x' $ ibef ++ DimFix i' : iaft - thisbody <- mkBodyM thisbnds [thisres] + letSubExp "index_concat" . BasicOp . Index x' $ + Slice $ ibef ++ DimFix i' : iaft + thisbody <- mkBodyM thisbnds [subExpRes thisres] (altres, altbnds) <- collectStms $ mkBranch xs_and_starts' - altbody <- mkBodyM altbnds [altres] + altbody <- mkBodyM altbnds [subExpRes altres] letSubExp "index_concat_branch" $ If cmp thisbody altbody $ IfDec [primBodyType res_t] IfNormal @@ -196,7 +206,7 @@ Just se <- maybeNth i ses -> case inds' of [] -> Just $ pure $ SubExpResult cs se - _ | Var v2 <- se -> Just $ pure $ IndexResult cs v2 inds' + _ | Var v2 <- se -> Just $ pure $ IndexResult cs v2 $ Slice inds' _ -> Nothing -- Indexing single-element arrays. We know the index must be 0. _ @@ -204,7 +214,7 @@ isCt1 $ arraySize 0 t, DimFix i : inds' <- inds, not $ isCt0 i -> - Just . pure . IndexResult mempty idd $ + Just . pure . IndexResult mempty idd . Slice $ DimFix (constant (0 :: Int64)) : inds' _ -> Nothing where 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 @@ -4,6 +4,7 @@ module Futhark.Optimise.Simplify.Rules.Loop (loopRules) where import Control.Monad +import Data.Bifunctor (second) import Data.List (partition) import Data.Maybe import Futhark.Analysis.DataDependencies @@ -25,18 +26,13 @@ -- 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 :: BinderOps rep => BottomUpRuleDoLoop rep -removeRedundantMergeVariables (_, used) pat aux (ctx, val, form, body) - | not $ all (usedAfterLoop . fst) val, - null ctx -- FIXME: things get tricky if we can remove all vals - -- but some ctxs are still used. We take the easy way - -- out for now. - = - let (ctx_es, val_es) = splitAt (length ctx) $ bodyResult body - necessaryForReturned = +removeRedundantMergeVariables :: BuilderOps rep => BottomUpRuleDoLoop rep +removeRedundantMergeVariables (_, used) pat aux (merge, form, body) + | not $ all (usedAfterLoop . fst) merge = + let necessaryForReturned = findNecessaryForReturned usedAfterLoopOrInForm - (zip (map fst $ ctx ++ val) $ ctx_es ++ val_es) + (zip (map fst merge) (map resSubExp $ bodyResult body)) (dataDependencies body) resIsNecessary ((v, _), _) = @@ -45,33 +41,18 @@ || referencedInPat v || referencedInForm v - (keep_ctx, discard_ctx) = - partition resIsNecessary $ zip ctx ctx_es (keep_valpart, discard_valpart) = partition (resIsNecessary . snd) $ - zip (patternValueElements pat) $ zip val val_es + zip (patElems pat) $ zip merge $ bodyResult body (keep_valpatelems, keep_val) = unzip keep_valpart (_discard_valpatelems, discard_val) = unzip discard_valpart - (ctx', ctx_es') = unzip keep_ctx - (val', val_es') = unzip keep_val - - body' = body {bodyResult = ctx_es' ++ val_es'} - free_in_keeps = freeIn keep_valpatelems + (merge', val_es') = unzip keep_val - stillUsedContext pat_elem = - patElemName pat_elem - `nameIn` ( free_in_keeps - <> freeIn (filter (/= pat_elem) $ patternContextElements pat) - ) + body' = body {bodyResult = val_es'} - pat' = - pat - { patternValueElements = keep_valpatelems, - patternContextElements = - filter stillUsedContext $ patternContextElements pat - } - in if ctx' ++ val' == ctx ++ val + pat' = Pat keep_valpatelems + in if merge' == merge then Skip else Simplify $ do -- We can't just remove the bindings in 'discard', since the loop @@ -80,17 +61,16 @@ -- removal will eventually get rid of them. Some care is -- necessary to handle unique bindings. body'' <- insertStmsM $ do - mapM_ (uncurry letBindNames) $ dummyStms discard_ctx mapM_ (uncurry letBindNames) $ dummyStms discard_val - return body' - auxing aux $ letBind pat' $ DoLoop ctx' val' form body'' + pure body' + auxing aux $ letBind pat' $ DoLoop merge' form body'' where - pat_used = map (`UT.isUsedDirectly` used) $ patternValueNames pat - used_vals = map fst $ filter snd $ zip (map (paramName . fst) val) pat_used + pat_used = map (`UT.isUsedDirectly` used) $ patNames pat + used_vals = map fst $ filter snd $ zip (map (paramName . fst) merge) pat_used usedAfterLoop = flip elem used_vals . paramName usedAfterLoopOrInForm p = usedAfterLoop p || paramName p `nameIn` freeIn form - patAnnotNames = freeIn $ map fst $ ctx ++ val + patAnnotNames = freeIn $ map fst merge referencedInPat = (`nameIn` patAnnotNames) . paramName referencedInForm = (`nameIn` freeIn form) . paramName @@ -105,44 +85,27 @@ -- 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 :: BinderOps rep => TopDownRuleDoLoop rep -hoistLoopInvariantMergeVariables vtable pat aux (ctx, val, form, loopbody) = +hoistLoopInvariantMergeVariables :: BuilderOps rep => TopDownRuleDoLoop rep +hoistLoopInvariantMergeVariables vtable pat aux (merge, form, loopbody) = do -- Figure out which of the elements of loopresult are -- loop-invariant, and hoist them out. + let explpat = zip (patElems pat) $ map (paramName . fst) merge case foldr checkInvariance ([], explpat, [], []) $ - zip3 (patternNames pat) merge res of + zip3 (patNames pat) merge res of ([], _, _, _) -> -- Nothing is invariant. Skip (invariant, explpat', merge', res') -> Simplify $ do -- We have moved something invariant out of the loop. let loopbody' = loopbody {bodyResult = res'} - invariantShape :: (a, VName) -> Bool - invariantShape (_, shapemerge) = - shapemerge - `elem` map (paramName . fst) merge' - (implpat', implinvariant) = partition invariantShape implpat - implinvariant' = [(patElemIdent p, Var v) | (p, v) <- implinvariant] - implpat'' = map fst implpat' explpat'' = map fst explpat' - (ctx', val') = splitAt (length implpat') merge' - forM_ (invariant ++ implinvariant') $ \(v1, v2) -> + forM_ invariant $ \(v1, v2) -> letBindNames [identName v1] $ BasicOp $ SubExp v2 - auxing aux $ - letBind (Pattern implpat'' explpat'') $ - DoLoop ctx' val' form loopbody' + auxing aux $ letBind (Pat explpat'') $ DoLoop merge' form loopbody' where - merge = ctx ++ val res = bodyResult loopbody - implpat = - zip (patternContextElements pat) $ - map (paramName . fst) ctx - explpat = - zip (patternValueElements pat) $ - map (paramName . fst) val - - namesOfMergeParams = namesFromList $ map (paramName . fst) $ ctx ++ val + namesOfMergeParams = namesFromList $ map (paramName . fst) merge removeFromResult (mergeParam, mergeInit) explpat' = case partition ((== paramName mergeParam) . snd) explpat' of @@ -174,13 +137,13 @@ -- parameter, where all existential parameters are already -- known to be invariant isInvariant - | Var v2 <- resExp, + | Var v2 <- resSubExp resExp, paramName mergeParam == v2 = allExistentialInvariant (namesFromList $ map (identName . fst) invariant) mergeParam -- (1) The result is identical to the initial parameter value. - | mergeInit == resExp = True + | mergeInit == resSubExp resExp = True -- (2) The initial parameter value is equal to an outer -- loop parameter 'P', where the initial value of 'P' is -- equal to 'resExp', AND 'resExp' ultimately becomes the @@ -189,7 +152,7 @@ -- would not be too hard to generalise. | Var init_v <- mergeInit, Just (p_init, p_res) <- ST.lookupLoopParam init_v vtable, - p_init == resExp, + p_init == resSubExp resExp, p_res == Var pat_name = True | otherwise = False @@ -206,13 +169,13 @@ not (name `nameIn` namesOfMergeParams) || name `nameIn` namesOfInvariant -simplifyClosedFormLoop :: BinderOps rep => TopDownRuleDoLoop rep -simplifyClosedFormLoop _ pat _ ([], val, ForLoop i it bound [], body) = +simplifyClosedFormLoop :: BuilderOps rep => TopDownRuleDoLoop rep +simplifyClosedFormLoop _ pat _ (val, ForLoop i it bound [], body) = Simplify $ loopClosedForm pat val (oneName i) it bound body simplifyClosedFormLoop _ _ _ _ = Skip -simplifyLoopVariables :: (BinderOps rep, Aliased rep) => TopDownRuleDoLoop rep -simplifyLoopVariables vtable pat aux (ctx, val, form@(ForLoop i it num_iters loop_vars), body) +simplifyLoopVariables :: (BuilderOps rep, Aliased rep) => TopDownRuleDoLoop 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 -- Check if the simplifications throw away more information than @@ -226,13 +189,8 @@ body' <- buildBody_ $ do addStms $ mconcat body_prefix_stms bodyBind body - auxing aux $ - letBind pat $ - DoLoop - ctx - val - (ForLoop i it num_iters $ catMaybes maybe_loop_vars) - body' + let form' = ForLoop i it num_iters $ catMaybes maybe_loop_vars + auxing aux $ letBind pat $ DoLoop merge form' body' where seType (Var v) | v == i = Just $ Prim $ IntType it @@ -247,7 +205,7 @@ vtable' seType arr - (DimFix (Var i) : fullSlice (paramType p) []) + (Slice (DimFix (Var i) : unSlice (fullSlice (paramType p) []))) $ paramName p `nameIn` consumed_in_body -- We only want this simplification if the result does not refer @@ -257,7 +215,7 @@ onLoopVar (p, arr) (Just m) = do (x, x_stms) <- collectStms m case x of - IndexResult cs arr' slice + IndexResult cs arr' (Slice slice) | not $ any ((i `nameIn`) . freeIn) x_stms, DimFix (Var j) : slice' <- slice, j == i, @@ -266,10 +224,8 @@ w <- arraySize 0 <$> lookupType arr' for_in_partial <- certifying cs $ - letExp "for_in_partial" $ - BasicOp $ - Index arr' $ - DimSlice (intConst Int64 0) w (intConst Int64 1) : slice' + letExp "for_in_partial" . BasicOp . Index arr' . Slice $ + DimSlice (intConst Int64 0) w (intConst Int64 1) : slice' return (Just (p, for_in_partial), mempty) SubExpResult cs se | all (notIndex . stmExp) x_stms -> do @@ -290,8 +246,8 @@ -- instead. We then move the sign extension inside the loop instead. -- This addresses loops of the form @for i in x.. TopDownRuleDoLoop rep -narrowLoopType vtable pat aux (ctx, val, ForLoop i Int64 n [], body) +narrowLoopType :: (BuilderOps rep) => TopDownRuleDoLoop rep +narrowLoopType vtable pat aux (merge, ForLoop i Int64 n [], body) | Just (n', it', cs) <- smallerType = Simplify $ do i' <- newVName $ baseString i @@ -299,9 +255,7 @@ body' <- insertStmsM . inScopeOf form' $ do letBindNames [i] $ BasicOp $ ConvOp (SExt it' Int64) (Var i') pure body - auxing aux $ - certifying cs $ - letBind pat $ DoLoop ctx val form' body' + auxing aux $ certifying cs $ letBind pat $ DoLoop merge form' body' where smallerType | Var n' <- n, @@ -315,28 +269,26 @@ narrowLoopType _ _ _ _ = Skip unroll :: - BinderOps rep => + BuilderOps rep => Integer -> - [(FParam rep, SubExp)] -> + [(FParam rep, SubExpRes)] -> (VName, IntType, Integer) -> [(LParam rep, VName)] -> Body rep -> - RuleM rep [SubExp] + RuleM rep [SubExpRes] unroll n merge (iv, it, i) loop_vars body | i >= n = return $ map snd merge | otherwise = do iter_body <- insertStmsM $ do - forM_ merge $ \(mergevar, mergeinit) -> - letBindNames [paramName mergevar] $ BasicOp $ SubExp mergeinit + forM_ merge $ \(mergevar, SubExpRes cs mergeinit) -> + certifying cs $ letBindNames [paramName mergevar] $ BasicOp $ SubExp mergeinit letBindNames [iv] $ BasicOp $ SubExp $ intConst it i forM_ loop_vars $ \(p, arr) -> - letBindNames [paramName p] $ - BasicOp $ - Index arr $ - DimFix (intConst Int64 i) : fullSlice (paramType p) [] + letBindNames [paramName p] . BasicOp . Index arr . Slice $ + DimFix (intConst Int64 i) : unSlice (fullSlice (paramType p) []) -- Some of the sizes in the types here might be temporarily wrong -- until copy propagation fixes it up. @@ -348,17 +300,17 @@ let merge' = zip (map fst merge) $ bodyResult iter_body' unroll n merge' (iv, it, i + 1) loop_vars body -simplifyKnownIterationLoop :: BinderOps rep => TopDownRuleDoLoop rep -simplifyKnownIterationLoop _ pat aux (ctx, val, ForLoop i it (Constant iters) loop_vars, body) +simplifyKnownIterationLoop :: BuilderOps rep => TopDownRuleDoLoop 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 - res <- unroll (valueIntegral n) (ctx ++ val) (i, it, 0) loop_vars body - forM_ (zip (patternNames pat) res) $ \(v, se) -> - letBindNames [v] $ BasicOp $ SubExp se + res <- unroll (valueIntegral n) (map (second subExpRes) merge) (i, it, 0) loop_vars body + forM_ (zip (patNames pat) res) $ \(v, SubExpRes cs se) -> + certifying cs $ letBindNames [v] $ BasicOp $ SubExp se simplifyKnownIterationLoop _ _ _ _ = Skip -topDownRules :: (BinderOps rep, Aliased rep) => [TopDownRule rep] +topDownRules :: (BuilderOps rep, Aliased rep) => [TopDownRule rep] topDownRules = [ RuleDoLoop hoistLoopInvariantMergeVariables, RuleDoLoop simplifyClosedFormLoop, @@ -367,11 +319,11 @@ RuleDoLoop narrowLoopType ] -bottomUpRules :: BinderOps rep => [BottomUpRule rep] +bottomUpRules :: BuilderOps rep => [BottomUpRule rep] bottomUpRules = [ RuleDoLoop removeRedundantMergeVariables ] -- | Standard loop simplification rules. -loopRules :: (BinderOps rep, Aliased rep) => RuleBook rep +loopRules :: (BuilderOps rep, Aliased rep) => RuleBook rep loopRules = ruleBook topDownRules bottomUpRules diff --git a/src/Futhark/Optimise/Simplify/Rules/Simple.hs b/src/Futhark/Optimise/Simplify/Rules/Simple.hs --- a/src/Futhark/Optimise/Simplify/Rules/Simple.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Simple.hs @@ -14,14 +14,14 @@ import Futhark.IR -- | A function that, given a variable name, returns its definition. -type VarLookup rep = VName -> Maybe (Exp rep, Certificates) +type VarLookup rep = VName -> Maybe (Exp rep, Certs) -- | A function that, given a subexpression, returns its type. type TypeLookup = SubExp -> Maybe Type -- | A simple rule is a top-down rule that can be expressed as a pure -- function. -type SimpleRule rep = VarLookup rep -> TypeLookup -> BasicOp -> Maybe (BasicOp, Certificates) +type SimpleRule rep = VarLookup rep -> TypeLookup -> BasicOp -> Maybe (BasicOp, Certs) isCt1 :: SubExp -> Bool isCt1 (Constant v) = oneIsh v @@ -60,18 +60,18 @@ | Just res <- doBinOp op v1 v2 = constRes res simplifyBinOp look _ (BinOp Add {} e1 e2) - | isCt0 e1 = subExpRes e2 - | isCt0 e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e2 + | isCt0 e2 = resIsSubExp e1 -- x+(y-x) => y | Var v2 <- e2, Just (BasicOp (BinOp Sub {} e2_a e2_b), cs) <- look v2, e2_b == e1 = Just (SubExp e2_a, cs) simplifyBinOp _ _ (BinOp FAdd {} e1 e2) - | isCt0 e1 = subExpRes e2 - | isCt0 e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e2 + | isCt0 e2 = resIsSubExp e1 simplifyBinOp look _ (BinOp sub@(Sub t _) e1 e2) - | isCt0 e2 = subExpRes e1 + | isCt0 e2 = resIsSubExp e1 -- Cases for simplifying (a+b)-b and permutations. -- (e1_a+e1_b)-e1_a == e1_b @@ -95,17 +95,17 @@ e2_b == e1 = Just (BinOp sub (intConst t 0) e2_a, cs) simplifyBinOp _ _ (BinOp FSub {} e1 e2) - | isCt0 e2 = subExpRes e1 + | isCt0 e2 = resIsSubExp e1 simplifyBinOp _ _ (BinOp Mul {} e1 e2) - | isCt0 e1 = subExpRes e1 - | isCt0 e2 = subExpRes e2 - | isCt1 e1 = subExpRes e2 - | isCt1 e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e1 + | isCt0 e2 = resIsSubExp e2 + | isCt1 e1 = resIsSubExp e2 + | isCt1 e2 = resIsSubExp e1 simplifyBinOp _ _ (BinOp FMul {} e1 e2) - | isCt0 e1 = subExpRes e1 - | isCt0 e2 = subExpRes e2 - | isCt1 e1 = subExpRes e2 - | isCt1 e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e1 + | isCt0 e2 = resIsSubExp e2 + | isCt1 e1 = resIsSubExp e2 + | isCt1 e2 = resIsSubExp e1 simplifyBinOp look _ (BinOp (SMod t _) e1 e2) | isCt1 e2 = constRes $ IntValue $ intValue t (0 :: Int) | e1 == e2 = constRes $ IntValue $ intValue t (0 :: Int) @@ -114,48 +114,51 @@ e4 == e2 = Just (SubExp e1, v1_cs) simplifyBinOp _ _ (BinOp SDiv {} e1 e2) - | isCt0 e1 = subExpRes e1 - | isCt1 e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e1 + | isCt1 e2 = resIsSubExp e1 | isCt0 e2 = Nothing simplifyBinOp _ _ (BinOp SDivUp {} e1 e2) - | isCt0 e1 = subExpRes e1 - | isCt1 e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e1 + | isCt1 e2 = resIsSubExp e1 | isCt0 e2 = Nothing simplifyBinOp _ _ (BinOp FDiv {} e1 e2) - | isCt0 e1 = subExpRes e1 - | isCt1 e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e1 + | isCt1 e2 = resIsSubExp e1 | isCt0 e2 = Nothing simplifyBinOp _ _ (BinOp (SRem t _) e1 e2) | isCt1 e2 = constRes $ IntValue $ intValue t (0 :: Int) | e1 == e2 = constRes $ IntValue $ intValue t (1 :: Int) simplifyBinOp _ _ (BinOp SQuot {} e1 e2) - | isCt1 e2 = subExpRes e1 + | isCt1 e2 = resIsSubExp e1 | isCt0 e2 = Nothing +simplifyBinOp _ _ (BinOp (Pow t) e1 e2) + | e1 == intConst t 2 = + Just (BinOp (Shl t) (intConst t 1) e2, mempty) simplifyBinOp _ _ (BinOp (FPow t) e1 e2) - | isCt0 e2 = subExpRes $ floatConst t 1 - | isCt0 e1 || isCt1 e1 || isCt1 e2 = subExpRes e1 + | isCt0 e2 = resIsSubExp $ floatConst t 1 + | isCt0 e1 || isCt1 e1 || isCt1 e2 = resIsSubExp e1 simplifyBinOp _ _ (BinOp (Shl t) e1 e2) - | isCt0 e2 = subExpRes e1 - | isCt0 e1 = subExpRes $ intConst t 0 + | isCt0 e2 = resIsSubExp e1 + | isCt0 e1 = resIsSubExp $ intConst t 0 simplifyBinOp _ _ (BinOp AShr {} e1 e2) - | isCt0 e2 = subExpRes e1 + | isCt0 e2 = resIsSubExp e1 simplifyBinOp _ _ (BinOp (And t) e1 e2) - | isCt0 e1 = subExpRes $ intConst t 0 - | isCt0 e2 = subExpRes $ intConst t 0 - | e1 == e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp $ intConst t 0 + | isCt0 e2 = resIsSubExp $ intConst t 0 + | e1 == e2 = resIsSubExp e1 simplifyBinOp _ _ (BinOp Or {} e1 e2) - | isCt0 e1 = subExpRes e2 - | isCt0 e2 = subExpRes e1 - | e1 == e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e2 + | isCt0 e2 = resIsSubExp e1 + | e1 == e2 = resIsSubExp e1 simplifyBinOp _ _ (BinOp (Xor t) e1 e2) - | isCt0 e1 = subExpRes e2 - | isCt0 e2 = subExpRes e1 - | e1 == e2 = subExpRes $ intConst t 0 + | isCt0 e1 = resIsSubExp e2 + | isCt0 e2 = resIsSubExp e1 + | e1 == e2 = resIsSubExp $ intConst t 0 simplifyBinOp defOf _ (BinOp LogAnd e1 e2) | isCt0 e1 = constRes $ BoolValue False | isCt0 e2 = constRes $ BoolValue False - | isCt1 e1 = subExpRes e2 - | isCt1 e2 = subExpRes e1 + | isCt1 e1 = resIsSubExp e2 + | isCt1 e2 = resIsSubExp e1 | Var v <- e1, Just (BasicOp (UnOp Not e1'), v_cs) <- defOf v, e1' == e2 = @@ -165,8 +168,8 @@ e2' == e1 = Just (SubExp $ Constant $ BoolValue False, v_cs) simplifyBinOp defOf _ (BinOp LogOr e1 e2) - | isCt0 e1 = subExpRes e2 - | isCt0 e2 = subExpRes e1 + | isCt0 e1 = resIsSubExp e2 + | isCt0 e2 = resIsSubExp e1 | isCt1 e1 = constRes $ BoolValue True | isCt1 e2 = constRes $ BoolValue True | Var v <- e1, @@ -179,7 +182,7 @@ Just (SubExp $ Constant $ BoolValue True, v_cs) simplifyBinOp defOf _ (BinOp (SMax it) e1 e2) | e1 == e2 = - subExpRes e1 + resIsSubExp e1 | Var v1 <- e1, Just (BasicOp (BinOp (SMax _) e1_1 e1_2), v1_cs) <- defOf v1, e1_1 == e2 = @@ -198,11 +201,11 @@ Just (BinOp (SMax it) e2_1 e1, v2_cs) simplifyBinOp _ _ _ = Nothing -constRes :: PrimValue -> Maybe (BasicOp, Certificates) +constRes :: PrimValue -> Maybe (BasicOp, Certs) constRes = Just . (,mempty) . SubExp . Constant -subExpRes :: SubExp -> Maybe (BasicOp, Certificates) -subExpRes = Just . (,mempty) . SubExp +resIsSubExp :: SubExp -> Maybe (BasicOp, Certs) +resIsSubExp = Just . (,mempty) . SubExp simplifyUnOp :: SimpleRule rep simplifyUnOp _ _ (UnOp op (Constant v)) = @@ -219,7 +222,7 @@ simplifyConvOp _ _ (ConvOp op se) | (from, to) <- convOpType op, from == to = - subExpRes se + resIsSubExp se simplifyConvOp lookupVar _ (ConvOp (SExt t2 t1) (Var v)) | Just (BasicOp (ConvOp (SExt t3 _) se), v_cs) <- lookupVar v, t2 >= t3 = @@ -255,7 +258,7 @@ | Just t <- seType $ Var v, newDims newshape == arrayDims t -- No-op reshape. = - subExpRes $ Var v + resIsSubExp $ Var v simplifyIdentityReshape _ _ _ = Nothing simplifyReshapeReshape :: SimpleRule rep @@ -301,7 +304,7 @@ simplifyReshapeIndex defOf _ (Reshape newshape v) | Just ds <- shapeCoercion newshape, Just (BasicOp (Index v' slice), v_cs) <- defOf v, - slice' <- reshapeSlice slice ds, + slice' <- Slice $ reshapeSlice (unSlice slice) ds, slice' /= slice = Just (Index v' slice', v_cs) simplifyReshapeIndex _ _ _ = Nothing @@ -309,13 +312,13 @@ -- If we are updating a slice with the result of a size coercion, we -- instead use the original array and update the slice dimensions. simplifyUpdateReshape :: SimpleRule rep -simplifyUpdateReshape defOf seType (Update dest slice (Var v)) +simplifyUpdateReshape defOf seType (Update safety dest slice (Var v)) | Just (BasicOp (Reshape newshape v'), v_cs) <- defOf v, Just _ <- shapeCoercion newshape, Just ds <- arrayDims <$> seType (Var v'), - slice' <- reshapeSlice slice ds, + slice' <- Slice $ reshapeSlice (unSlice slice) ds, slice' /= slice = - Just (Update dest slice' $ Var v', v_cs) + Just (Update safety dest slice' $ Var v', v_cs) simplifyUpdateReshape _ _ _ = Nothing improveReshape :: SimpleRule rep @@ -369,6 +372,6 @@ VarLookup rep -> TypeLookup -> BasicOp -> - Maybe (BasicOp, Certificates) + Maybe (BasicOp, Certs) applySimpleRules defOf seType op = msum [rule defOf seType op | rule <- simpleRules] 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 @@ -101,7 +101,7 @@ sunkHere v stm = v `nameIn` free_in_stms && all (`ST.available` vtable) (namesToList (freeIn stm)) - sunk = namesFromList $ foldMap (patternNames . stmPattern) sunk_stms + sunk = namesFromList $ foldMap (patNames . stmPat) sunk_stms optimiseStms :: Constraints rep => @@ -125,7 +125,7 @@ optimiseStms' _ _ [] = ([], mempty) optimiseStms' vtable sinking (stm : stms) | BasicOp Index {} <- stmExp stm, - [pe] <- patternElements (stmPattern stm), + [pe] <- patElems (stmPat stm), primType $ patElemType pe, maybe True (== 1) $ M.lookup (patElemName pe) multiplicities = let (stms', sunk) = 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 @@ -77,7 +77,7 @@ case maybe_tiled of Just (host_stms, tiling, tiledBody) -> do (res', stms') <- - runBinder $ mapM (tilingTileReturns tiling) =<< tiledBody mempty mempty + runBuilder $ mapM (tilingTileReturns tiling) =<< tiledBody mempty mempty return ( host_stms, ( tilingLevel tiling, @@ -90,7 +90,7 @@ | otherwise = return (mempty, (lvl, initial_kspace, kbody)) where - isSimpleResult (Returns _ se) = Just se + isSimpleResult (Returns _ cs se) = Just $ SubExpRes cs se isSimpleResult _ = Nothing tileInBody :: @@ -125,7 +125,7 @@ (tiling2d $ reverse $ zip top_gtids_rev top_kdims_rev) initial_lvl res_ts - (stmPattern stm_to_tile) + (stmPat stm_to_tile) (gtid_x, gtid_y) (kdim_x, kdim_y) w @@ -147,7 +147,7 @@ (tiling1d $ reverse top_space_rev) initial_lvl res_ts - (stmPattern stm_to_tile) + (stmPat stm_to_tile) gtid kdim w @@ -156,7 +156,7 @@ poststms' stms_res -- Tiling inside for-loop. - | DoLoop [] merge (ForLoop i it bound []) loopbody <- stmExp stm_to_tile, + | DoLoop merge (ForLoop i it bound []) loopbody <- stmExp stm_to_tile, (prestms', poststms') <- preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms) = do let branch_variant' = @@ -189,7 +189,7 @@ (freeIn loopbody <> freeIn merge) tiled res_ts - (stmPattern stm_to_tile) + (stmPat stm_to_tile) (stmAux stm_to_tile) merge i @@ -224,7 +224,7 @@ used stm = any (`nameIn` used_in_stm_variant) $ - patternNames $ stmPattern stm + patNames $ stmPat stm (prelude_used, prelude_not_used) = Seq.partition used prelude @@ -255,21 +255,21 @@ (invariant_prestms, precomputed_variant_prestms, recomputed_variant_prestms) where invariantTo names stm = - case patternNames (stmPattern stm) of + case patNames (stmPat stm) of [] -> True -- Does not matter. v : _ -> not $ any (`nameIn` names) $ namesToList $ M.findWithDefault mempty v variance consumed v = v `nameIn` consumed_in_prestms - consumedStm stm = any consumed (patternNames (stmPattern stm)) + consumedStm stm = any consumed (patNames (stmPat stm)) later_consumed = namesFromList $ - concatMap (patternNames . stmPattern) $ + concatMap (patNames . stmPat) $ stmsToList $ Seq.filter consumedStm prestms groupInvariant stm = invariantTo private stm - && not (any (`nameIn` later_consumed) (patternNames (stmPattern stm))) + && not (any (`nameIn` later_consumed) (patNames (stmPat stm))) && invariantTo later_consumed stm (invariant_prestms, variant_prestms) = Seq.partition groupInvariant prestms @@ -284,14 +284,14 @@ mustBeInlinedExp _ = False mustBeInlined stm = mustBeInlinedExp (stmExp stm) - && any (`nameIn` used_after) (patternNames (stmPattern stm)) + && any (`nameIn` used_after) (patNames (stmPat stm)) must_be_inlined = namesFromList $ - concatMap (patternNames . stmPattern) $ + concatMap (patNames . stmPat) $ stmsToList $ Seq.filter mustBeInlined variant_prestms recompute stm = - any (`nameIn` must_be_inlined) (patternNames (stmPattern stm)) + any (`nameIn` must_be_inlined) (patNames (stmPat stm)) || not (invariantTo must_be_inlined stm) (recomputed_variant_prestms, precomputed_variant_prestms) = Seq.partition recompute variant_prestms @@ -342,7 +342,7 @@ Names -> (Stms GPU, Tiling, TiledBody) -> [Type] -> - Pattern GPU -> + Pat GPU -> StmAux (ExpDec GPU) -> [(FParam GPU, SubExp)] -> VName -> @@ -392,21 +392,19 @@ certifying (stmAuxCerts aux) $ tilingSegMap tiling "tiled_loopinit" (scalarLevel tiling) ResultPrivate $ \in_bounds slice -> - fmap (map Var) $ + fmap varsRes $ protectOutOfBounds "loopinit" in_bounds merge_ts $ do addPrivStms slice inloop_privstms addPrivStms slice privstms - return mergeinits + return $ subExpsRes mergeinits let merge' = zip mergeparams' mergeinit' let indexMergeParams slice = localScope (scopeOfFParams mergeparams') $ forM_ (zip mergeparams mergeparams') $ \(to, from) -> - letBindNames [paramName to] $ - BasicOp $ - Index (paramName from) $ - fullSlice (paramType from) slice + letBindNames [paramName to] . BasicOp . Index (paramName from) $ + fullSlice (paramType from) slice private' = private <> namesFromList (map paramName mergeparams ++ map paramName mergeparams') @@ -415,12 +413,12 @@ PrivStms mempty indexMergeParams <> privstms <> inloop_privstms loopbody' <- - localScope (scopeOfFParams mergeparams') . runBodyBinder $ + localScope (scopeOfFParams mergeparams') . runBodyBuilder $ resultBody . map Var <$> tiledBody private' privstms' accs' <- letTupExp "tiled_inside_loop" $ - DoLoop [] merge' (ForLoop i it bound []) loopbody' + DoLoop merge' (ForLoop i it bound []) loopbody' postludeGeneric tiling (privstms <> inloop_privstms) pat accs' poststms poststms_res res_ts @@ -432,21 +430,21 @@ filter (`notElem` unSegSpace (tilingSpace tiling)) $ unSegSpace initial_space -doPrelude :: Tiling -> PrivStms -> Stms GPU -> [VName] -> Binder GPU [VName] +doPrelude :: Tiling -> PrivStms -> Stms GPU -> [VName] -> Builder GPU [VName] doPrelude tiling privstms prestms prestms_live = -- Create a SegMap that takes care of the prelude for every thread. tilingSegMap tiling "prelude" (scalarLevel tiling) ResultPrivate $ \in_bounds slice -> do ts <- mapM lookupType prestms_live - fmap (map Var) $ + fmap varsRes $ protectOutOfBounds "pre" in_bounds ts $ do addPrivStms slice privstms addStms prestms - pure $ map Var prestms_live + pure $ varsRes prestms_live liveSet :: FreeIn a => Stms GPU -> a -> Names liveSet stms after = - namesFromList (concatMap (patternNames . stmPattern) stms) + namesFromList (concatMap (patNames . stmPat) stms) `namesIntersection` freeIn after tileable :: @@ -498,7 +496,7 @@ -- The atual tile size may be smaller for the last tile, so we have to -- be careful now. sliceUntiled :: - MonadBinder m => + MonadBuilder m => VName -> SubExp -> SubExp -> @@ -521,7 +519,7 @@ privStms :: Stms GPU -> PrivStms privStms stms = PrivStms stms $ const $ return () -addPrivStms :: Slice SubExp -> PrivStms -> Binder GPU () +addPrivStms :: [DimIndex SubExp] -> PrivStms -> Builder GPU () addPrivStms local_slice (PrivStms stms readPrelude) = do readPrelude local_slice addStms stms @@ -536,7 +534,7 @@ instance Monoid PrivStms where mempty = privStms mempty -type ReadPrelude = Slice SubExp -> Binder GPU () +type ReadPrelude = [DimIndex SubExp] -> Builder GPU () data ProcessTileArgs = ProcessTileArgs { processPrivStms :: PrivStms, @@ -567,8 +565,8 @@ String -> SegLevel -> ResultManifest -> - (PrimExp VName -> Slice SubExp -> Binder GPU [SubExp]) -> - Binder GPU [VName], + (PrimExp VName -> [DimIndex SubExp] -> Builder GPU Result) -> + Builder GPU [VName], -- The boolean PrimExp indicates whether they are in-bounds. tilingReadTile :: @@ -576,22 +574,22 @@ PrivStms -> SubExp -> [InputArray] -> - Binder GPU [InputTile], + Builder GPU [InputTile], tilingProcessTile :: ProcessTileArgs -> - Binder GPU [VName], + Builder GPU [VName], tilingProcessResidualTile :: ResidualTileArgs -> - Binder GPU [VName], - tilingTileReturns :: VName -> Binder GPU KernelResult, + Builder GPU [VName], + tilingTileReturns :: VName -> Builder GPU KernelResult, tilingSpace :: SegSpace, tilingTileShape :: Shape, tilingLevel :: SegLevel, - tilingNumWholeTiles :: Binder GPU SubExp + tilingNumWholeTiles :: Builder GPU SubExp } type DoTiling gtids kdims = - SegLevel -> gtids -> kdims -> SubExp -> Binder GPU Tiling + SegLevel -> gtids -> kdims -> SubExp -> Builder GPU Tiling scalarLevel :: Tiling -> SegLevel scalarLevel tiling = @@ -603,8 +601,8 @@ String -> PrimExp VName -> [Type] -> - Binder GPU [SubExp] -> - Binder GPU [VName] + Builder GPU Result -> + Builder GPU [VName] protectOutOfBounds desc in_bounds ts m = do -- This is more complicated than you might expect, because we need -- to be able to produce a blank accumulator, which eBlank cannot @@ -612,7 +610,7 @@ -- an accumulator of type 'acc_t', then a unique variable of type -- 'acc_t' must also be free in the body. This means we can find it -- based just on the type. - m_body <- insertStmsM $ resultBody <$> m + m_body <- insertStmsM $ mkBody mempty <$> m let m_body_free = namesToList $ freeIn m_body t_to_v <- filter (isAcc . fst) @@ -626,16 +624,16 @@ postludeGeneric :: Tiling -> PrivStms -> - Pattern GPU -> + Pat GPU -> [VName] -> Stms GPU -> Result -> [Type] -> - Binder GPU [VName] + Builder GPU [VName] postludeGeneric tiling privstms pat accs' poststms poststms_res res_ts = tilingSegMap tiling "thread_res" (scalarLevel tiling) ResultPrivate $ \in_bounds slice -> do -- Read our per-thread result from the tiled loop. - forM_ (zip (patternNames pat) accs') $ \(us, everyone) -> do + forM_ (zip (patNames pat) accs') $ \(us, everyone) -> do everyone_t <- lookupType everyone letBindNames [us] $ BasicOp $ Index everyone $ fullSlice everyone_t slice @@ -644,19 +642,19 @@ -- The privstms may still be necessary for the result. addPrivStms slice privstms return poststms_res - else fmap (map Var) $ + else fmap varsRes $ protectOutOfBounds "postlude" in_bounds res_ts $ do addPrivStms slice privstms addStms poststms return poststms_res -type TiledBody = Names -> PrivStms -> Binder GPU [VName] +type TiledBody = Names -> PrivStms -> Builder GPU [VName] tileGeneric :: DoTiling gtids kdims -> SegLevel -> [Type] -> - Pattern GPU -> + Pat GPU -> gtids -> kdims -> SubExp -> @@ -666,13 +664,13 @@ Result -> TileM (Stms GPU, Tiling, TiledBody) tileGeneric doTiling initial_lvl res_ts pat gtids kdims w form inputs poststms poststms_res = do - (tiling, tiling_stms) <- runBinder $ doTiling initial_lvl gtids kdims w + (tiling, tiling_stms) <- runBuilder $ doTiling initial_lvl gtids kdims w return (tiling_stms, tiling, tiledBody tiling) where (red_comm, red_lam, red_nes, map_lam) = form - tiledBody :: Tiling -> Names -> PrivStms -> Binder GPU [VName] + tiledBody :: Tiling -> Names -> PrivStms -> Builder GPU [VName] tiledBody tiling _private privstms = do let tile_shape = tilingTileShape tiling @@ -683,11 +681,11 @@ mergeinits <- tilingSegMap tiling "mergeinit" (scalarLevel tiling) ResultPrivate $ \in_bounds slice -> -- Constant neutral elements (a common case) do not need protection from OOB. if freeIn red_nes == mempty - then return red_nes - else fmap (map Var) $ + then return $ subExpsRes red_nes + else fmap varsRes $ protectOutOfBounds "neutral" in_bounds (lambdaReturnType red_lam) $ do addPrivStms slice privstms - return red_nes + return $ subExpsRes red_nes merge <- forM (zip (lambdaParams red_lam) mergeinits) $ \(p, mergeinit) -> (,) @@ -698,7 +696,7 @@ tile_id <- newVName "tile_id" let loopform = ForLoop tile_id Int64 num_whole_tiles [] - loopbody <- renameBody <=< runBodyBinder $ + loopbody <- renameBody <=< runBodyBuilder $ inScopeOf loopform $ localScope (scopeOfFParams $ map fst merge) $ do -- Collectively read a tile. @@ -712,7 +710,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" $ DoLoop merge loopform loopbody -- We possibly have to traverse a residual tile. red_lam' <- renameLambda red_lam @@ -733,7 +731,7 @@ arr_t <- lookupType arr letBindNames [v] $ BasicOp $ Index arr $ fullSlice arr_t slice -tileReturns :: [(VName, SubExp)] -> [(SubExp, SubExp)] -> VName -> Binder GPU KernelResult +tileReturns :: [(VName, SubExp)] -> [(SubExp, SubExp)] -> VName -> Builder GPU KernelResult tileReturns dims_on_top dims arr = do let unit_dims = replicate (length dims_on_top) (intConst Int64 1) arr_t <- lookupType arr @@ -744,7 +742,7 @@ let new_shape = unit_dims ++ arrayDims arr_t letExp (baseString arr) $ BasicOp $ Reshape (map DimNew new_shape) arr let tile_dims = zip (map snd dims_on_top) unit_dims ++ dims - return $ TileReturns tile_dims arr' + return $ TileReturns mempty tile_dims arr' is1DTileable :: VName -> M.Map VName Names -> VName -> InputArray is1DTileable gtid variance arr @@ -758,7 +756,7 @@ VName -> VName -> VName -> - Binder GPU () + Builder GPU () reconstructGtids1D group_size gtid gid ltid = letBindNames [gtid] =<< toExp (le64 gid * pe64 (unCount group_size) + le64 ltid) @@ -773,7 +771,7 @@ PrivStms -> SubExp -> [InputArray] -> - Binder GPU [InputTile] + Builder GPU [InputTile] readTile1D tile_size gid gtid num_groups group_size kind privstms tile_id inputs = fmap (inputsToTiles inputs) . segMap1D "full_tile" lvl ResultNoSimplify @@ -792,8 +790,8 @@ let readTileElem arr = -- No need for fullSlice because we are tiling only prims. - letExp "tile_elem" (BasicOp $ Index arr [DimFix j]) - fmap (map Var) $ + letExp "tile_elem" (BasicOp $ Index arr $ Slice [DimFix j]) + fmap varsRes $ case kind of TilePartial -> letTupExp "pre" @@ -814,7 +812,7 @@ Count NumGroups SubExp -> Count GroupSize SubExp -> ProcessTileArgs -> - Binder GPU [VName] + Builder GPU [VName] processTile1D gid gtid kdim tile_size num_groups group_size tile_args = do let red_comm = processComm tile_args privstms = processPrivStms tile_args @@ -832,7 +830,7 @@ -- OK because the parallel semantics are not used after this -- point). thread_accs <- forM accs $ \acc -> - letSubExp "acc" $ BasicOp $ Index acc [DimFix $ Var ltid] + letSubExp "acc" $ BasicOp $ Index acc $ Slice [DimFix $ Var ltid] let sliceTile (InputTiled _ arr) = pure arr sliceTile (InputUntiled arr) = @@ -841,7 +839,7 @@ tiles' <- mapM sliceTile tiles let form' = redomapSOAC [Reduce red_comm red_lam thread_accs] map_lam - fmap (map Var) $ + fmap varsRes $ letTupExp "acc" =<< eIf (toExp $ le64 gtid .<. pe64 kdim) @@ -858,7 +856,7 @@ Count NumGroups SubExp -> Count GroupSize SubExp -> ResidualTileArgs -> - Binder GPU [VName] + Builder GPU [VName] processResidualTile1D gid gtid kdim tile_size num_groups group_size args = do -- The number of residual elements that are not covered by -- the whole tiles. @@ -881,7 +879,7 @@ num_whole_tiles = residualNumWholeTiles args w = residualInputSize args - nonemptyTile residual_input = runBodyBinder $ do + nonemptyTile residual_input = runBodyBuilder $ do -- Collectively construct a tile. Threads that are out-of-bounds -- provide a blank dummy value. full_tiles <- @@ -902,7 +900,7 @@ let slice = DimSlice (intConst Int64 0) residual_input (intConst Int64 1) InputTiled perm - <$> letExp "partial_tile" (BasicOp $ Index tile [slice]) + <$> letExp "partial_tile" (BasicOp $ Index tile $ Slice [slice]) tiles <- mapM sliceTile full_tiles @@ -989,7 +987,7 @@ (VName, VName) -> (VName, VName) -> (VName, VName) -> - Binder GPU () + Builder GPU () reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y) = do -- Reconstruct the original gtids from gid_x/gid_y and ltid_x/ltid_y. letBindNames [gtid_x] @@ -1008,7 +1006,7 @@ PrivStms -> SubExp -> [InputArray] -> - Binder GPU [InputTile] + Builder GPU [InputTile] readTile2D (kdim_x, kdim_y) (gtid_x, gtid_y) (gid_x, gid_y) tile_size num_groups group_size kind privstms tile_id inputs = fmap (inputsToTiles inputs) . segMap2D @@ -1033,10 +1031,8 @@ -- No need for fullSlice because we are tiling only prims. letExp "tile_elem" - ( BasicOp $ - Index - arr - [DimFix $ last $ rearrangeShape perm [i, j]] + ( BasicOp . Index arr $ + Slice [DimFix $ last $ rearrangeShape perm [i, j]] ) readTileElemIfInBounds (arr, perm) = do @@ -1053,10 +1049,10 @@ ] eIf (toExp $ pe64 idx .<. pe64 w .&&. othercheck) - (eBody [return $ BasicOp $ Index arr [DimFix idx]]) + (eBody [return $ BasicOp $ Index arr $ Slice [DimFix idx]]) (eBody [eBlank tile_t]) - fmap (map Var) $ + fmap varsRes $ case kind of TilePartial -> mapM (letExp "pre" <=< readTileElemIfInBounds) arrs_and_perms @@ -1080,7 +1076,7 @@ Count NumGroups SubExp -> Count GroupSize SubExp -> ProcessTileArgs -> - Binder GPU [VName] + Builder GPU [VName] processTile2D (gid_x, gid_y) (gtid_x, gtid_y) (kdim_x, kdim_y) tile_size num_groups group_size tile_args = do let privstms = processPrivStms tile_args red_comm = processComm tile_args @@ -1107,7 +1103,7 @@ -- OK because the parallel semantics are not used after this -- point). thread_accs <- forM accs $ \acc -> - letSubExp "acc" $ BasicOp $ Index acc [DimFix $ Var ltid_x, DimFix $ Var ltid_y] + letSubExp "acc" $ BasicOp $ Index acc $ Slice [DimFix $ Var ltid_x, DimFix $ Var ltid_y] let form' = redomapSOAC [Reduce red_comm red_lam thread_accs] map_lam sliceTile (InputUntiled arr) = @@ -1120,7 +1116,7 @@ tiles' <- mapM sliceTile tiles - fmap (map Var) $ + fmap varsRes $ letTupExp "acc" =<< eIf ( toExp $ le64 gtid_x .<. pe64 kdim_x .&&. le64 gtid_y .<. pe64 kdim_y @@ -1136,7 +1132,7 @@ Count NumGroups SubExp -> Count GroupSize SubExp -> ResidualTileArgs -> - Binder GPU [VName] + Builder GPU [VName] processResidualTile2D gids gtids @@ -1166,7 +1162,7 @@ num_whole_tiles = residualNumWholeTiles args w = residualInputSize args - nonemptyTile residual_input = renameBody <=< runBodyBinder $ do + nonemptyTile residual_input = renameBody <=< runBodyBuilder $ do -- Collectively construct a tile. Threads that are out-of-bounds -- provide a blank dummy value. full_tile <- @@ -1187,7 +1183,7 @@ tiles <- forM full_tile $ \case InputTiled perm tile' -> InputTiled perm - <$> letExp "partial_tile" (BasicOp $ Index tile' [slice, slice]) + <$> letExp "partial_tile" (BasicOp $ Index tile' (Slice [slice, slice])) InputUntiled arr -> pure $ InputUntiled arr @@ -1242,8 +1238,7 @@ reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y) f ( untyped $ - le64 gtid_x .<. pe64 kdim_x - .&&. le64 gtid_y .<. pe64 kdim_y + le64 gtid_x .<. pe64 kdim_x .&&. le64 gtid_y .<. pe64 kdim_y ) [DimFix $ Var ltid_x, DimFix $ Var ltid_y], tilingReadTile = readTile2D (kdim_x, kdim_y) (gtid_x, gtid_y) (gid_x, gid_y) tile_size (segNumGroups lvl) (segGroupSize lvl), 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 @@ -25,23 +25,23 @@ String -> SegLevel -> ResultManifest -> - (VName -> Binder GPU [SubExp]) -> - Binder GPU [VName] + (VName -> Builder GPU Result) -> + Builder GPU [VName] segMap1D desc lvl manifest f = do ltid <- newVName "ltid" ltid_flat <- newVName "ltid_flat" let space = SegSpace ltid_flat [(ltid, unCount $ segGroupSize lvl)] - ((ts, res), stms) <- localScope (scopeOfSegSpace space) . runBinder $ do + ((ts, res), stms) <- localScope (scopeOfSegSpace space) . runBuilder $ do res <- f ltid - ts <- mapM subExpType res + ts <- mapM subExpResType res return (ts, res) Body _ stms' res' <- renameBody $ mkBody stms res + let ret (SubExpRes cs se) = Returns manifest cs se letTupExp desc $ - Op $ - SegOp $ - SegMap lvl space ts $ KernelBody () stms' $ map (Returns manifest) res' + Op . SegOp $ + SegMap lvl space ts $ KernelBody () stms' $ map ret res' segMap2D :: String -> -- desc @@ -49,24 +49,24 @@ ResultManifest -> -- manifest (SubExp, SubExp) -> -- (dim_x, dim_y) ( (VName, VName) -> -- f - Binder GPU [SubExp] + Builder GPU Result ) -> - Binder GPU [VName] + Builder GPU [VName] segMap2D desc lvl manifest (dim_y, dim_x) f = do ltid_xx <- newVName "ltid_x" ltid_flat <- newVName "ltid_flat" ltid_yy <- newVName "ltid_y" let segspace = SegSpace ltid_flat [(ltid_yy, dim_y), (ltid_xx, dim_x)] - ((ts, res), stms) <- localScope (scopeOfSegSpace segspace) . runBinder $ do + ((ts, res), stms) <- localScope (scopeOfSegSpace segspace) . runBuilder $ do res <- f (ltid_yy, ltid_xx) - ts <- mapM subExpType res + ts <- mapM subExpResType res return (ts, res) + let ret (SubExpRes cs se) = Returns manifest cs se letTupExp desc <=< renameExp $ - Op $ - SegOp $ - SegMap lvl segspace ts $ KernelBody () stms $ map (Returns manifest) res + Op . SegOp $ + SegMap lvl segspace ts $ KernelBody () stms $ map ret res segMap3D :: String -> -- desc @@ -74,9 +74,9 @@ ResultManifest -> -- manifest (SubExp, SubExp, SubExp) -> -- (dim_z, dim_y, dim_x) ( (VName, VName, VName) -> -- f - Binder GPU [SubExp] + Builder GPU Result ) -> - Binder GPU [VName] + Builder GPU [VName] segMap3D desc lvl manifest (dim_z, dim_y, dim_x) f = do ltid_x <- newVName "ltid_x" ltid_flat <- newVName "ltid_flat" @@ -84,15 +84,15 @@ ltid_z <- newVName "ltid_z" let segspace = SegSpace ltid_flat [(ltid_z, dim_z), (ltid_y, dim_y), (ltid_x, dim_x)] - ((ts, res), stms) <- localScope (scopeOfSegSpace segspace) . runBinder $ do + ((ts, res), stms) <- localScope (scopeOfSegSpace segspace) . runBuilder $ do res <- f (ltid_z, ltid_y, ltid_x) - ts <- mapM subExpType res + ts <- mapM subExpResType res return (ts, res) + let ret (SubExpRes cs se) = Returns manifest cs se letTupExp desc <=< renameExp $ - Op $ - SegOp $ - SegMap lvl segspace ts $ KernelBody () stms $ map (Returns manifest) res + Op . SegOp $ + SegMap lvl segspace ts $ KernelBody () stms $ map ret res segScatter2D :: String -> -- desc @@ -100,20 +100,20 @@ VName -> SegLevel -> -- lvl (SubExp, SubExp) -> -- (dim_y, dim_x) - ((VName, VName) -> Binder GPU (SubExp, SubExp)) -> -- f - Binder GPU [VName] + ((VName, VName) -> Builder GPU (SubExp, SubExp)) -> -- f + Builder GPU [VName] segScatter2D desc arr_size updt_arr lvl (dim_x, dim_y) f = do ltid_x <- newVName "ltid_x" ltid_y <- newVName "ltid_y" ltid_flat <- newVName "ltid_flat" let segspace = SegSpace ltid_flat [(ltid_x, dim_x), (ltid_y, dim_y)] - ((t_v, res_v, res_i), stms) <- runBinder $ do + ((t_v, res_v, res_i), stms) <- runBuilder $ do (res_v, res_i) <- f (ltid_x, ltid_y) t_v <- subExpType res_v return (t_v, res_v, res_i) - let ret = WriteReturns (Shape [arr_size]) updt_arr [([DimFix res_i], res_v)] + let ret = WriteReturns mempty (Shape [arr_size]) updt_arr [(Slice [DimFix res_i], res_v)] let body = KernelBody () stms [ret] letTupExp desc <=< renameExp $ Op $ SegOp $ SegMap lvl segspace [t_v] body @@ -148,7 +148,7 @@ defVarianceInStm :: VarianceTable -> Stm GPU -> VarianceTable defVarianceInStm variance bnd = - foldl' add variance $ patternNames $ stmPattern bnd + foldl' add variance $ patNames $ stmPat bnd where add variance' v = M.insert v binding_variance variance' look variance' v = oneName v <> M.findWithDefault mempty v variance' 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 @@ -61,7 +61,7 @@ type UnstreamM rep = ReaderT (Scope rep) (State VNameSource) type OnOp rep = - Pattern rep -> StmAux (ExpDec rep) -> Op rep -> UnstreamM rep [Stm rep] + Pat rep -> StmAux (ExpDec rep) -> Op rep -> UnstreamM rep [Stm rep] optimiseStms :: ASTRep rep => @@ -137,7 +137,7 @@ pure [Let pat aux $ Op $ ParOp par_op' op'] onMCOp stage pat aux (MC.OtherOp soac) | sequentialise stage soac = do - stms <- runBinder_ $ FOT.transformSOAC pat soac + stms <- runBuilder_ $ FOT.transformSOAC pat soac fmap concat $ localScope (scopeOf stms) $ mapM (optimiseStm (onMCOp stage)) $ stmsToList stms @@ -158,7 +158,7 @@ onHostOp :: Stage -> OnOp GPU onHostOp stage pat aux (GPU.OtherOp soac) | sequentialise stage soac = do - stms <- runBinder_ $ FOT.transformSOAC pat soac + stms <- runBuilder_ $ FOT.transformSOAC pat soac fmap concat $ localScope (scopeOf stms) $ mapM (optimiseStm (onHostOp stage)) $ stmsToList stms 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 @@ -96,11 +96,12 @@ (Left e, _) -> throwError e where - bindRes pe se = Let (Pattern [] [pe]) (defAux ()) $ BasicOp $ SubExp se + bindRes pe (SubExpRes cs se) = + certify cs $ Let (Pat [pe]) (defAux ()) $ BasicOp $ SubExp se useBranch b = bodyStms b - <> stmsFromList (zipWith bindRes (patternElements pat) (bodyResult b)) + <> stmsFromList (zipWith bindRes (patElems pat) (bodyResult b)) transformStm (Let pat aux e) = do (bnds, e') <- transformExp =<< mapExpM transform e return $ bnds <> oneStm (Let pat aux e') @@ -266,7 +267,7 @@ ExpandM (RebaseMap, Stms GPUMem) memoryRequirements lvl space kstms variant_allocs invariant_allocs = do (num_threads, num_threads_stms) <- - runBinder . letSubExp "num_threads" . BasicOp $ + runBuilder . letSubExp "num_threads" . BasicOp $ BinOp (Mul Int64 OverflowUndef) (unCount $ segNumGroups lvl) @@ -365,7 +366,7 @@ Names -> Stm GPUMem -> Writer Extraction (Maybe (Stm GPUMem)) -extractStmAllocations user bound_outside bound_kernel (Let (Pattern [] [patElem]) _ (Op (Alloc size space))) +extractStmAllocations user bound_outside bound_kernel (Let (Pat [patElem]) _ (Op (Alloc size space))) | expandable space && expandableSize size -- FIXME: the '&& notScalar space' part is a hack because we -- don't otherwise hoist the sizes out far enough, and we @@ -421,13 +422,13 @@ genericExpandedInvariantAllocations getNumUsers invariant_allocs = do -- We expand the invariant allocations by adding an inner dimension -- equal to the number of kernel threads. - (rebases, alloc_stms) <- runBinder $ mapM expand $ M.toList invariant_allocs + (rebases, alloc_stms) <- runBuilder $ mapM expand $ M.toList invariant_allocs return (alloc_stms, mconcat rebases) where expand (mem, (user, per_thread_size, space)) = do let num_users = fst $ getNumUsers user - allocpat = Pattern [] [PatElem mem $ MemMem space] + allocpat = Pat [PatElem mem $ MemMem space] total_size <- letExp "total_size" <=< toExp . product $ pe64 per_thread_size : map pe64 (shapeDims num_users) @@ -444,13 +445,13 @@ permuted_ixfun = IxFun.permute root_ixfun perm offset_ixfun = IxFun.slice permuted_ixfun $ - map DimFix user_ids ++ map untouched old_shape + Slice $ map DimFix user_ids ++ map untouched old_shape in offset_ixfun 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 $ + IxFun.slice root_ixfun . Slice $ map DimFix user_ids ++ map untouched old_shape in offset_ixfun @@ -505,7 +506,7 @@ return (slice_stms' <> stmsFromList alloc_bnds, mconcat rebases) where expand (mem, (offset, total_size, space)) = do - let allocpat = Pattern [] [PatElem mem $ MemMem space] + let allocpat = Pat [PatElem mem $ MemMem space] return ( Let allocpat (defAux ()) $ Op $ Alloc total_size space, M.singleton mem $ newBase offset @@ -521,11 +522,8 @@ pe64 size_per_thread `quot` primByteSize pt root_ixfun = IxFun.iota [elems_per_thread, num_threads'] offset_ixfun = - IxFun.slice - root_ixfun - [ DimSlice 0 num_threads' 1, - DimFix gtid - ] + IxFun.slice root_ixfun . Slice $ + [DimSlice 0 num_threads' 1, DimFix gtid] shapechange = if length old_shape == 1 then map DimCoercion old_shape @@ -558,6 +556,11 @@ askRebaseMap :: OffsetM RebaseMap askRebaseMap = OffsetM $ lift ask +localRebaseMap :: (RebaseMap -> RebaseMap) -> OffsetM a -> OffsetM a +localRebaseMap f (OffsetM m) = OffsetM $ do + scope <- ask + lift $ local f $ runReaderT m scope + lookupNewBase :: VName -> ([TPrimExp Int64 VName], PrimType) -> OffsetM (Maybe IxFun) lookupNewBase name x = do offsets <- askRebaseMap @@ -587,16 +590,13 @@ offsetMemoryInStm :: Stm GPUMem -> OffsetM (Scope GPUMem, Stm GPUMem) offsetMemoryInStm (Let pat dec e) = do - pat' <- offsetMemoryInPattern pat - e' <- localScope (scopeOfPattern pat') $ offsetMemoryInExp e + e' <- offsetMemoryInExp e + pat' <- offsetMemoryInPat pat =<< expReturns e' scope <- askScope -- Try to recompute the index function. Fall back to creating rebase -- operations with the RebaseMap. rts <- runReaderT (expReturns e') scope - let pat'' = - Pattern - (patternContextElements pat') - (zipWith pick (patternValueElements pat') rts) + let pat'' = Pat $ zipWith pick (patElems pat') rts stm = Let pat'' dec e' let scope' = scopeOf stm <> scope return (scope', stm) @@ -618,24 +618,20 @@ inst Ext {} = Nothing inst (Free x) = return x -offsetMemoryInPattern :: Pattern GPUMem -> OffsetM (Pattern GPUMem) -offsetMemoryInPattern (Pattern ctx vals) = do - mapM_ inspectCtx ctx - Pattern ctx <$> mapM inspectVal vals +offsetMemoryInPat :: Pat GPUMem -> [ExpReturns] -> OffsetM (Pat GPUMem) +offsetMemoryInPat (Pat pes) rets = do + Pat <$> zipWithM onPE pes rets where - inspectVal patElem = do - new_dec <- offsetMemoryInMemBound $ patElemDec patElem - return patElem {patElemDec = new_dec} - inspectCtx patElem - | Mem space <- patElemType patElem, - expandable space = - throwError $ - unwords - [ "Cannot deal with existential memory block", - pretty (patElemName patElem), - "when expanding inside kernels." - ] - | otherwise = return () + 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 + onPE pe _ = do + new_dec <- offsetMemoryInMemBound $ patElemDec pe + pure pe {patElemDec = new_dec} + unExt (Ext i) = patElemName (pes !! i) + unExt (Free v) = v offsetMemoryInParam :: Param (MemBound u) -> OffsetM (Param (MemBound u)) offsetMemoryInParam fparam = do @@ -645,23 +641,19 @@ offsetMemoryInMemBound :: MemBound u -> OffsetM (MemBound u) offsetMemoryInMemBound summary@(MemArray pt shape u (ArrayIn mem ixfun)) = do new_base <- lookupNewBase mem (IxFun.base ixfun, pt) - return $ - fromMaybe summary $ do - new_base' <- new_base - return $ MemArray pt shape u $ ArrayIn mem $ IxFun.rebase new_base' ixfun + return . fromMaybe summary $ do + new_base' <- new_base + return $ MemArray pt shape u $ ArrayIn mem $ IxFun.rebase new_base' ixfun offsetMemoryInMemBound summary = return 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) - return $ - fromMaybe br $ do - new_base' <- new_base - return $ - MemArray pt shape u $ - ReturnsInBlock mem $ - IxFun.rebase (fmap (fmap Free) new_base') ixfun + return . fromMaybe br $ do + new_base' <- new_base + return . MemArray pt shape u . ReturnsInBlock mem $ + IxFun.rebase (fmap (fmap Free) new_base') ixfun offsetMemoryInBodyReturns br = return br offsetMemoryInLambda :: Lambda GPUMem -> OffsetM (Lambda GPUMem) @@ -669,14 +661,34 @@ body <- offsetMemoryInBody $ lambdaBody lam return $ lam {lambdaBody = body} +-- A loop may have memory parameters, and those memory blocks may +-- be expanded. We assume (but do not check - FIXME) that if the +-- initial value of a loop parameter is an expanded memory block, +-- then so will the result be. +offsetMemoryInLoopParams :: + [(FParam GPUMem, SubExp)] -> + ([(FParam GPUMem, SubExp)] -> OffsetM a) -> + OffsetM a +offsetMemoryInLoopParams merge f = do + let (params, args) = unzip merge + localRebaseMap extend $ do + params' <- mapM offsetMemoryInParam params + f $ zip params' args + where + extend rm = foldl' onParamArg rm merge + onParamArg rm (param, Var arg) + | Just x <- M.lookup arg rm = + M.insert (paramName param) x rm + onParamArg rm _ = rm + offsetMemoryInExp :: Exp GPUMem -> OffsetM (Exp GPUMem) -offsetMemoryInExp (DoLoop ctx val form body) = do - let (ctxparams, ctxinit) = unzip ctx - (valparams, valinit) = unzip val - ctxparams' <- mapM offsetMemoryInParam ctxparams - valparams' <- mapM offsetMemoryInParam valparams - body' <- localScope (scopeOfFParams ctxparams' <> scopeOfFParams valparams' <> scopeOf form) (offsetMemoryInBody body) - return $ DoLoop (zip ctxparams' ctxinit) (zip valparams' valinit) form body' +offsetMemoryInExp (DoLoop merge form body) = do + offsetMemoryInLoopParams merge $ \merge' -> do + body' <- + localScope + (scopeOfFParams (map fst merge') <> scopeOf form) + (offsetMemoryInBody body) + return $ DoLoop merge' form body' offsetMemoryInExp e = mapExpM recurse e where recurse = @@ -714,16 +726,15 @@ | nested = throwError $ "Cannot handle nested allocation: " ++ pretty stm | otherwise = return Nothing unAllocStm _ (Let pat dec e) = - Just <$> (Let <$> unAllocPattern pat <*> pure dec <*> mapExpM unAlloc' e) + Just <$> (Let <$> unAllocPat pat <*> pure dec <*> mapExpM unAlloc' e) unAllocLambda (Lambda params body ret) = Lambda (unParams params) <$> unAllocBody body <*> pure ret unParams = mapMaybe $ traverse unMem - unAllocPattern pat@(Pattern ctx val) = - Pattern <$> maybe bad return (mapM (rephrasePatElem unMem) ctx) - <*> maybe bad return (mapM (rephrasePatElem unMem) val) + unAllocPat pat@(Pat merge) = + Pat <$> maybe bad return (mapM (rephrasePatElem unMem) merge) where bad = Left $ "Cannot handle memory in pattern " ++ pretty pat @@ -793,23 +804,22 @@ kernels_scope <- asks unAllocScope - (max_lam, _) <- flip runBinderT kernels_scope $ do + (max_lam, _) <- flip runBuilderT kernels_scope $ do xs <- replicateM num_sizes $ newParam "x" (Prim int64) ys <- replicateM num_sizes $ newParam "y" (Prim int64) (zs, stms) <- localScope (scopeOfLParams $ xs ++ ys) $ collectStms $ forM (zip xs ys) $ \(x, y) -> - letSubExp "z" $ BasicOp $ BinOp (SMax Int64) (Var $ paramName x) (Var $ paramName y) + fmap subExpRes . letSubExp "z" . BasicOp $ + BinOp (SMax Int64) (Var $ paramName x) (Var $ paramName y) return $ Lambda (xs ++ ys) (mkBody stms zs) i64s flat_gtid_lparam <- Param <$> newVName "flat_gtid" <*> pure (Prim (IntType Int64)) - (size_lam', _) <- flip runBinderT kernels_scope $ do + (size_lam', _) <- flip runBuilderT kernels_scope $ do params <- replicateM num_sizes $ newParam "x" (Prim int64) (zs, stms) <- localScope - ( scopeOfLParams params - <> scopeOfLParams [flat_gtid_lparam] - ) + (scopeOfLParams params <> scopeOfLParams [flat_gtid_lparam]) $ collectStms $ do -- Even though this SegRed is one-dimensional, we need to -- provide indexes corresponding to the original potentially @@ -822,17 +832,14 @@ zipWithM_ letBindNames (map pure kspace_gtids) =<< mapM toExp new_inds mapM_ addStm kstms' - return sizes + return $ subExpsRes sizes localScope (scopeOfSegSpace space) $ GPU.simplifyLambda (Lambda [flat_gtid_lparam] (Body () stms zs) i64s) - ((maxes_per_thread, size_sums), slice_stms) <- flip runBinderT kernels_scope $ do + ((maxes_per_thread, size_sums), slice_stms) <- flip runBuilderT kernels_scope $ do pat <- - basicPattern [] - <$> replicateM - num_sizes - (newIdent "max_per_thread" $ Prim int64) + basicPat <$> replicateM num_sizes (newIdent "max_per_thread" $ Prim int64) w <- letSubExp "size_slice_w" @@ -853,10 +860,10 @@ addStms =<< mapM renameStm =<< nonSegRed lvl pat w [red_op] size_lam' [thread_space_iota] - size_sums <- forM (patternNames pat) $ \threads_max -> + size_sums <- forM (patNames pat) $ \threads_max -> letExp "size_sum" $ BasicOp $ BinOp (Mul Int64 OverflowUndef) (Var threads_max) num_threads - return (patternNames pat, size_sums) + return (patNames pat, size_sums) return (slice_stms, maxes_per_thread, size_sums) 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 @@ -1,9 +1,9 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -17,7 +17,6 @@ ExpHint (..), defaultExpHints, Allocable, - Allocator (..), AllocM, AllocEnv (..), SizeSubst (..), @@ -27,6 +26,8 @@ arraySizeInBytesExp, mkLetNamesB', mkLetNamesB'', + dimAllocationSize, + ChunkMap, -- * Module re-exports @@ -44,7 +45,7 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer -import Data.List (foldl', partition, sort, zip4) +import Data.List (foldl', partition, zip4) import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S @@ -57,90 +58,23 @@ import Futhark.Optimise.Simplify.Rep (mkWiseBody) import Futhark.Pass import Futhark.Tools -import Futhark.Util (splitAt3, splitFromEnd, takeLast) - -data AllocStm - = SizeComputation VName (PrimExp VName) - | Allocation VName SubExp Space - | ArrayCopy VName VName - deriving (Eq, Ord, Show) - -bindAllocStm :: - (MonadBinder m, Op (Rep m) ~ MemOp inner) => - AllocStm -> - m () -bindAllocStm (SizeComputation name pe) = - letBindNames [name] =<< toExp (coerceIntPrimExp Int64 pe) -bindAllocStm (Allocation name size space) = - letBindNames [name] $ Op $ Alloc size space -bindAllocStm (ArrayCopy name src) = - letBindNames [name] $ BasicOp $ Copy src - -class - (MonadFreshNames m, LocalScope rep m, Mem rep) => - Allocator rep m - where - addAllocStm :: AllocStm -> m () - askDefaultSpace :: m Space - - default addAllocStm :: - ( Allocable fromrep rep, - m ~ AllocM fromrep rep - ) => - AllocStm -> - m () - addAllocStm (SizeComputation name se) = - letBindNames [name] =<< toExp (coerceIntPrimExp Int64 se) - addAllocStm (Allocation name size space) = - letBindNames [name] $ Op $ allocOp size space - addAllocStm (ArrayCopy name src) = - letBindNames [name] $ BasicOp $ Copy src - - -- | The subexpression giving the number of elements we should - -- allocate space for. See 'ChunkMap' comment. - dimAllocationSize :: SubExp -> m SubExp - default dimAllocationSize :: - m ~ AllocM fromrep rep => - SubExp -> - m SubExp - dimAllocationSize (Var v) = - -- It is important to recurse here, as the substitution may itself - -- be a chunk size. - maybe (return $ Var v) dimAllocationSize =<< asks (M.lookup v . chunkMap) - dimAllocationSize size = - return size - - -- | Get those names that are known to be constants at run-time. - askConsts :: m (S.Set VName) - - expHints :: Exp rep -> m [ExpHint] - expHints = defaultExpHints - -allocateMemory :: - Allocator rep m => - String -> - SubExp -> - Space -> - m VName -allocateMemory desc size space = do - v <- newVName desc - addAllocStm $ Allocation v size space - return v +import Futhark.Util (maybeNth, splitAt3, splitFromEnd, takeLast) -computeSize :: - Allocator rep m => - String -> - PrimExp VName -> - m SubExp -computeSize desc se = do - v <- newVName desc - addAllocStm $ SizeComputation v se - return $ Var v +-- | The subexpression giving the number of elements we should +-- allocate space for. See 'ChunkMap' comment. +dimAllocationSize :: ChunkMap -> SubExp -> SubExp +dimAllocationSize chunkmap (Var v) = + -- It is important to recurse here, as the substitution may itself + -- be a chunk size. + maybe (Var v) (dimAllocationSize chunkmap) $ M.lookup v chunkmap +dimAllocationSize _ size = + size -type Allocable fromrep torep = +type Allocable fromrep torep inner = ( PrettyRep fromrep, PrettyRep torep, - Mem torep, + Mem torep inner, + LetDec torep ~ LetDecMem, FParamInfo fromrep ~ DeclType, LParamInfo fromrep ~ Type, BranchType fromrep ~ ExtType, @@ -148,8 +82,8 @@ BodyDec fromrep ~ (), BodyDec torep ~ (), ExpDec torep ~ (), - SizeSubst (Op torep), - BinderOps torep + SizeSubst inner, + BuilderOps torep ) -- | A mapping from chunk names to their maximum size. XXX FIXME @@ -176,7 +110,7 @@ -- | Monad for adding allocations to an entire program. newtype AllocM fromrep torep a - = AllocM (BinderT torep (ReaderT (AllocEnv fromrep torep) (State VNameSource)) a) + = AllocM (BuilderT torep (ReaderT (AllocEnv fromrep torep) (State VNameSource)) a) deriving ( Applicative, Functor, @@ -187,33 +121,30 @@ MonadReader (AllocEnv fromrep torep) ) -instance - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => - MonadBinder (AllocM fromrep torep) - where +instance (Allocable fromrep torep inner) => MonadBuilder (AllocM fromrep torep) where type Rep (AllocM fromrep torep) = torep - mkExpDecM _ _ = return () + mkExpDecM _ _ = pure () mkLetNamesM names e = do - pat <- patternWithAllocations names e + def_space <- askDefaultSpace + chunkmap <- asks chunkMap + hints <- expHints e + pat <- patWithAllocations def_space chunkmap names e hints return $ Let pat (defAux ()) e - mkBodyM bnds res = return $ Body () bnds res + mkBodyM stms res = return $ Body () stms res addStms = AllocM . addStms collectStms (AllocM m) = AllocM $ collectStms m -instance - (Allocable fromrep torep) => - Allocator torep (AllocM fromrep torep) - where - expHints e = do - f <- asks envExpHints - f e - askDefaultSpace = asks allocSpace +expHints :: Exp torep -> AllocM fromrep torep [ExpHint] +expHints e = do + f <- asks envExpHints + f e - askConsts = asks envConsts +askDefaultSpace :: AllocM fromrep torep Space +askDefaultSpace = asks allocSpace runAllocM :: MonadFreshNames m => @@ -222,7 +153,7 @@ AllocM fromrep torep a -> m a runAllocM handleOp hints (AllocM m) = - fmap fst $ modifyNameSource $ runState $ runReaderT (runBinderT m mempty) env + fmap fst $ modifyNameSource $ runState $ runReaderT (runBuilderT m mempty) env where env = AllocEnv @@ -234,41 +165,6 @@ envExpHints = hints } --- | Monad for adding allocations to a single pattern. -newtype PatAllocM rep a - = PatAllocM - ( RWS - (Scope rep) - [AllocStm] - VNameSource - a - ) - deriving - ( Applicative, - Functor, - Monad, - HasScope rep, - LocalScope rep, - MonadWriter [AllocStm], - MonadFreshNames - ) - -instance Mem rep => Allocator rep (PatAllocM rep) where - addAllocStm = tell . pure - dimAllocationSize = return - askDefaultSpace = return DefaultSpace - askConsts = pure mempty - -runPatAllocM :: - MonadFreshNames m => - PatAllocM rep a -> - Scope rep -> - m (a, [AllocStm]) -runPatAllocM (PatAllocM m) mems = - modifyNameSource $ frob . runRWS m mems - where - frob (a, s, w) = ((a, w), s) - elemSize :: Num a => Type -> a elemSize = primByteSize . elemType @@ -276,157 +172,121 @@ arraySizeInBytesExp t = untyped $ foldl' (*) (elemSize t) $ map pe64 (arrayDims t) -arraySizeInBytesExpM :: Allocator rep m => Type -> m (PrimExp VName) -arraySizeInBytesExpM t = do - dims <- mapM dimAllocationSize (arrayDims t) - let dim_prod_i64 = product $ map pe64 dims +arraySizeInBytesExpM :: MonadBuilder m => ChunkMap -> Type -> m (PrimExp VName) +arraySizeInBytesExpM chunkmap t = do + let dim_prod_i64 = product $ map (pe64 . dimAllocationSize chunkmap) (arrayDims t) elm_size_i64 = elemSize t return $ BinOpExp (SMax Int64) (ValueExp $ IntValue $ Int64Value 0) $ - untyped $ - dim_prod_i64 * elm_size_i64 + untyped $ dim_prod_i64 * elm_size_i64 -arraySizeInBytes :: Allocator rep m => Type -> m SubExp -arraySizeInBytes = computeSize "bytes" <=< arraySizeInBytesExpM +arraySizeInBytes :: MonadBuilder m => ChunkMap -> Type -> m SubExp +arraySizeInBytes chunkmap = letSubExp "bytes" <=< toExp <=< arraySizeInBytesExpM chunkmap +allocForArray' :: + (MonadBuilder m, Op (Rep m) ~ MemOp inner) => + ChunkMap -> + Type -> + Space -> + m VName +allocForArray' chunkmap t space = do + size <- arraySizeInBytes chunkmap t + letExp "mem" $ Op $ Alloc size space + -- | Allocate memory for a value of the given type. allocForArray :: - Allocator rep m => + Allocable fromrep torep inner => Type -> Space -> - m VName + AllocM fromrep torep VName allocForArray t space = do - size <- arraySizeInBytes t - allocateMemory "mem" size space + chunkmap <- asks chunkMap + allocForArray' chunkmap t space allocsForStm :: - (Allocator rep m, ExpDec rep ~ ()) => - [Ident] -> + (Allocable fromrep torep inner) => [Ident] -> - Exp rep -> - m (Stm rep) -allocsForStm sizeidents validents e = do - rts <- expReturns e + Exp torep -> + AllocM fromrep torep (Stm torep) +allocsForStm idents e = do + def_space <- askDefaultSpace + chunkmap <- asks chunkMap hints <- expHints e - (ctxElems, valElems) <- allocsForPattern sizeidents validents rts hints - return $ Let (Pattern ctxElems valElems) (defAux ()) e + rts <- expReturns e + pes <- allocsForPat def_space chunkmap idents rts hints + dec <- mkExpDecM (Pat pes) e + pure $ Let (Pat pes) (defAux dec) e -patternWithAllocations :: - (Allocator rep m, ExpDec rep ~ ()) => +patWithAllocations :: + (MonadBuilder m, Mem (Rep m) inner) => + Space -> + ChunkMap -> [VName] -> - Exp rep -> - m (Pattern rep) -patternWithAllocations names e = do - (ts', sizes) <- instantiateShapes' =<< expExtType e - let identForBindage name t = - pure $ Ident name t - vals <- sequence [identForBindage name t | (name, t) <- zip names ts'] - stmPattern <$> allocsForStm sizes vals e + Exp (Rep m) -> + [ExpHint] -> + m (PatT LetDecMem) +patWithAllocations def_space chunkmap names e hints = do + ts' <- instantiateShapes' names <$> expExtType e + let idents = zipWith Ident names ts' + rts <- expReturns e + Pat <$> allocsForPat def_space chunkmap idents rts hints -allocsForPattern :: - Allocator rep m => - [Ident] -> +mkMissingIdents :: MonadFreshNames m => [Ident] -> [ExpReturns] -> m [Ident] +mkMissingIdents idents rts = + reverse <$> zipWithM f (reverse rts) (map Just (reverse idents) ++ repeat Nothing) + where + f _ (Just ident) = pure ident + f (MemMem space) Nothing = newIdent "ext_mem" $ Mem space + f _ Nothing = newIdent "ext" $ Prim int64 + +allocsForPat :: + (MonadBuilder m, Op (Rep m) ~ MemOp inner) => + Space -> + ChunkMap -> [Ident] -> [ExpReturns] -> [ExpHint] -> - m - ( [PatElem rep], - [PatElem rep] - ) -allocsForPattern sizeidents validents rts hints = do - let sizes' = [PatElem size $ MemPrim int64 | size <- map identName sizeidents] - (vals, (exts, mems)) <- - runWriterT $ - forM (zip3 validents rts hints) $ \(ident, rt, hint) -> do - let ident_shape = arrayShape $ identType ident - case rt of - MemPrim _ -> do - summary <- lift $ summaryForBindage (identType ident) hint - return $ PatElem (identName ident) summary - MemMem space -> - return $ - PatElem (identName ident) $ - MemMem space - MemArray bt _ u (Just (ReturnsInBlock mem extixfun)) -> do - (patels, ixfn) <- instantiateExtIxFun ident extixfun - tell (patels, []) - - return $ - PatElem (identName ident) $ - MemArray bt ident_shape u $ - ArrayIn mem ixfn - MemArray _ extshape _ Nothing - | Just _ <- knownShape extshape -> do - summary <- lift $ summaryForBindage (identType ident) hint - return $ PatElem (identName ident) summary - MemArray bt _ u (Just (ReturnsNewBlock space _ extixfn)) -> do - -- treat existential index function first - (patels, ixfn) <- instantiateExtIxFun ident extixfn - tell (patels, []) - - memid <- lift $ mkMemIdent ident space - tell ([], [PatElem (identName memid) $ MemMem space]) - return $ - PatElem (identName ident) $ - MemArray bt ident_shape u $ - ArrayIn (identName memid) ixfn - MemAcc acc ispace ts u -> - return $ PatElem (identName ident) $ MemAcc acc ispace ts u - _ -> error "Impossible case reached in allocsForPattern!" + m [PatElemT LetDecMem] +allocsForPat def_space chunkmap some_idents rts hints = do + idents <- mkMissingIdents some_idents rts - return - ( sizes' <> exts <> mems, - vals - ) + forM (zip3 idents rts hints) $ \(ident, rt, hint) -> do + let ident_shape = arrayShape $ identType ident + case rt of + MemPrim _ -> do + summary <- summaryForBindage def_space chunkmap (identType ident) hint + pure $ PatElem (identName ident) summary + MemMem space -> + pure $ PatElem (identName ident) $ MemMem space + MemArray bt _ u (Just (ReturnsInBlock mem extixfun)) -> do + let ixfn = instantiateExtIxFun idents extixfun + pure . PatElem (identName ident) . MemArray bt ident_shape u $ ArrayIn mem ixfn + MemArray _ extshape _ Nothing + | Just _ <- knownShape extshape -> do + summary <- summaryForBindage def_space chunkmap (identType ident) hint + pure $ PatElem (identName ident) summary + MemArray bt _ u (Just (ReturnsNewBlock _ i extixfn)) -> do + let ixfn = instantiateExtIxFun idents extixfn + pure . PatElem (identName ident) . MemArray bt ident_shape u $ + ArrayIn (getIdent idents i) ixfn + MemAcc acc ispace ts u -> + pure $ PatElem (identName ident) $ MemAcc acc ispace ts u + _ -> error "Impossible case reached in allocsForPat!" where knownShape = mapM known . shapeDims known (Free v) = Just v known Ext {} = Nothing - mkMemIdent :: (MonadFreshNames m) => Ident -> Space -> m Ident - mkMemIdent ident space = do - let memname = baseString (identName ident) <> "_mem" - newIdent memname $ Mem space - - instantiateExtIxFun :: - MonadFreshNames m => - Ident -> - ExtIxFun -> - m ([PatElemT (MemInfo d u ret)], IxFun) - instantiateExtIxFun idd ext_ixfn = do - let isAndPtps = - S.toList $ - foldMap onlyExts $ - foldMap (leafExpTypes . untyped) ext_ixfn - - -- Find the existentials that reuse the sizeidents, and - -- those that need new pattern elements. Assumes that the - -- Exts form a contiguous interval of integers. - let (size_exts, new_exts) = - span ((< length sizeidents) . fst) $ sort isAndPtps - (new_substs, patels) <- - fmap unzip $ - forM new_exts $ \(i, t) -> do - v <- newVName $ baseString (identName idd) <> "_ixfn" - return - ( (Ext i, LeafExp (Free v) t), - PatElem v $ MemPrim t - ) - let size_substs = - zipWith - ( \(i, t) ident -> - (Ext i, LeafExp (Free (identName ident)) t) - ) - size_exts - sizeidents - substs = M.fromList $ new_substs <> size_substs - ixfn <- instantiateIxFun $ IxFun.substituteInIxFun (fmap isInt64 substs) ext_ixfn - - return (patels, ixfn) + getIdent idents i = + case maybeNth i idents of + Just ident -> identName ident + Nothing -> + error $ "getIdent: Ext " <> show i <> " but pattern has " <> show (length idents) <> " elements: " <> pretty idents -onlyExts :: (Ext a, PrimType) -> S.Set (Int, PrimType) -onlyExts (Free _, _) = S.empty -onlyExts (Ext i, t) = S.singleton (i, t) + instantiateExtIxFun idents = fmap $ fmap inst + where + inst (Free v) = v + inst (Ext i) = getIdent idents i instantiateIxFun :: Monad m => ExtIxFun -> m IxFun instantiateIxFun = traverse $ traverse inst @@ -435,28 +295,29 @@ inst (Free x) = return x summaryForBindage :: - Allocator rep m => + (MonadBuilder m, Op (Rep m) ~ MemOp inner) => + Space -> + ChunkMap -> Type -> ExpHint -> m (MemBound NoUniqueness) -summaryForBindage (Prim bt) _ = +summaryForBindage _ _ (Prim bt) _ = return $ MemPrim bt -summaryForBindage (Mem space) _ = +summaryForBindage _ _ (Mem space) _ = return $ MemMem space -summaryForBindage (Acc acc ispace ts u) _ = +summaryForBindage _ _ (Acc acc ispace ts u) _ = return $ MemAcc acc ispace ts u -summaryForBindage t@(Array pt shape u) NoHint = do - m <- allocForArray t =<< askDefaultSpace +summaryForBindage def_space chunkmap t@(Array pt shape u) NoHint = do + m <- allocForArray' chunkmap t def_space return $ directIxFun pt shape u m t -summaryForBindage t@(Array pt _ _) (Hint ixfun space) = do +summaryForBindage _ _ t@(Array pt _ _) (Hint ixfun space) = do bytes <- - computeSize "bytes" $ - untyped $ - product - [ product $ IxFun.base ixfun, - fromIntegral (primByteSize pt :: Int64) - ] - m <- allocateMemory "mem" bytes space + letSubExp "bytes" <=< toExp . untyped $ + product + [ product $ IxFun.base ixfun, + fromIntegral (primByteSize pt :: Int64) + ] + m <- letExp "mem" $ Op $ Alloc bytes space return $ MemArray pt (arrayShape t) NoUniqueness $ ArrayIn m ixfun lookupMemSpace :: (HasScope rep m, Monad m) => VName -> m Space @@ -472,7 +333,7 @@ in MemArray bt shape u $ ArrayIn mem ixf allocInFParams :: - (Allocable fromrep torep) => + (Allocable fromrep torep inner) => [(FParam fromrep, Space)] -> ([FParam torep] -> AllocM fromrep torep a) -> AllocM fromrep torep a @@ -484,7 +345,7 @@ localScope summary $ m params' allocInFParam :: - (Allocable fromrep torep) => + (Allocable fromrep torep inner) => FParam fromrep -> Space -> WriterT @@ -507,86 +368,124 @@ return param {paramDec = MemAcc acc ispace ts u} allocInMergeParams :: - ( Allocable fromrep torep, - Allocator torep (AllocM fromrep torep) - ) => + (Allocable fromrep torep inner) => [(FParam fromrep, SubExp)] -> - ( [FParam torep] -> - [FParam torep] -> + ( [(FParam torep, SubExp)] -> ([SubExp] -> AllocM fromrep torep ([SubExp], [SubExp])) -> AllocM fromrep torep a ) -> AllocM fromrep torep a allocInMergeParams merge m = do - ((valparams, handle_loop_subexps), (ctx_params, mem_params)) <- - runWriterT $ unzip <$> mapM allocInMergeParam merge + ((valparams, valargs, handle_loop_subexps), (ctx_params, mem_params)) <- + runWriterT $ unzip3 <$> mapM allocInMergeParam merge let mergeparams' = ctx_params <> mem_params <> valparams summary = scopeOfFParams mergeparams' mk_loop_res ses = do - (valargs, (ctxargs, memargs)) <- + (ses', (ctxargs, memargs)) <- runWriterT $ zipWithM ($) handle_loop_subexps ses - return (ctxargs <> memargs, valargs) + return (ctxargs <> memargs, ses') - localScope summary $ m (ctx_params <> mem_params) valparams mk_loop_res + (valctx_args, valargs') <- mk_loop_res valargs + let merge' = + zip + (ctx_params <> mem_params <> valparams) + (valctx_args <> valargs') + localScope summary $ m merge' mk_loop_res where + param_names = namesFromList $ map (paramName . fst) merge + anyIsLoopParam names = names `namesIntersect` param_names + + scalarRes param_t v_mem_space v_ixfun (Var res) = do + -- Try really hard to avoid copying needlessly, but the result + -- _must_ be in ScalarSpace and have the right index function. + (res_mem, res_ixfun) <- lift $ lookupArraySummary res + res_mem_space <- lift $ lookupMemSpace res_mem + chunkmap <- asks chunkMap + (res_mem', res') <- + if (res_mem_space, res_ixfun) == (v_mem_space, v_ixfun) + then pure (res_mem, res) + else lift $ arrayWithIxFun chunkmap v_mem_space v_ixfun (fromDecl param_t) res + tell ([], [Var res_mem']) + pure $ Var res' + scalarRes _ _ _ se = pure se + allocInMergeParam :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => (Param DeclType, SubExp) -> WriterT ([FParam torep], [FParam torep]) (AllocM fromrep torep) - (FParam torep, SubExp -> WriterT ([SubExp], [SubExp]) (AllocM fromrep torep) SubExp) + ( FParam torep, + SubExp, + SubExp -> WriterT ([SubExp], [SubExp]) (AllocM fromrep torep) SubExp + ) allocInMergeParam (mergeparam, Var v) - | Array pt shape u <- paramDeclType mergeparam = do - (mem', _) <- lift $ lookupArraySummary v - mem_space <- lift $ lookupMemSpace mem' + | param_t@(Array pt shape u) <- paramDeclType mergeparam = do + (v_mem, v_ixfun) <- lift $ lookupArraySummary v + v_mem_space <- lift $ lookupMemSpace v_mem - (_, ext_ixfun, substs, _) <- lift $ existentializeArray mem_space v + -- Loop-invariant array parameters that are in scalar space + -- are special - we do not wish to existentialise their index + -- function at all (but the memory block is still existential). + case v_mem_space of + ScalarSpace {} -> + if anyIsLoopParam (freeIn shape) + then do + -- Arrays with loop-variant shape cannot be in scalar + -- space, so copy them elsewhere and try again. + (_, v') <- lift $ allocLinearArray DefaultSpace (baseString v) v + allocInMergeParam (mergeparam, Var v') + else do + mem_name <- newVName "mem_param" + tell ([], [Param mem_name $ MemMem v_mem_space]) - (ctx_params, param_ixfun_substs) <- - unzip - <$> mapM - ( \e -> do - let e_t = primExpType $ untyped e - vname <- lift $ newVName "ctx_param_ext" - return - ( Param vname $ MemPrim e_t, - fmap Free $ pe64 $ Var vname - ) - ) - substs + pure + ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn mem_name v_ixfun}, + Var v, + scalarRes param_t v_mem_space v_ixfun + ) + _ -> do + (v', ext_ixfun, substs, v_mem') <- + lift $ existentializeArray v_mem_space v + v_mem_space' <- lift $ lookupMemSpace v_mem' - tell (ctx_params, []) + (ctx_params, param_ixfun_substs) <- + fmap unzip . forM substs $ \e -> do + vname <- lift $ newVName "ctx_param_ext" + pure + ( Param vname $ MemPrim $ primExpType $ untyped e, + fmap Free $ pe64 $ Var vname + ) - param_ixfun <- - instantiateIxFun $ - IxFun.substituteInIxFun - (M.fromList $ zip (fmap Ext [0 ..]) param_ixfun_substs) - ext_ixfun + tell (ctx_params, []) - mem_name <- newVName "mem_param" - tell ([], [Param mem_name $ MemMem mem_space]) + param_ixfun <- + instantiateIxFun $ + IxFun.substituteInIxFun + (M.fromList $ zip (fmap Ext [0 ..]) param_ixfun_substs) + ext_ixfun - return - ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn mem_name param_ixfun}, - ensureArrayIn mem_space - ) - allocInMergeParam (mergeparam, _) = doDefault mergeparam =<< lift askDefaultSpace + mem_name <- newVName "mem_param" + tell ([], [Param mem_name $ MemMem v_mem_space']) - doDefault mergeparam space = do + pure + ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn mem_name param_ixfun}, + v', + ensureArrayIn v_mem_space' + ) + allocInMergeParam (mergeparam, se) = doDefault mergeparam se =<< lift askDefaultSpace + + doDefault mergeparam se space = do mergeparam' <- allocInFParam mergeparam space - return (mergeparam', linearFuncallArg (paramType mergeparam) space) + return (mergeparam', se, linearFuncallArg (paramType mergeparam) space) -- Returns the existentialized index function, the list of substituted values and the memory location. existentializeArray :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => Space -> VName -> AllocM fromrep torep (SubExp, ExtIxFun, [TPrimExp Int64 VName], VName) -existentializeArray ScalarSpace {} v = do - (mem', ixfun) <- lookupArraySummary v - return (Var v, fmap (fmap Free) ixfun, mempty, mem') existentializeArray space v = do (mem', ixfun) <- lookupArraySummary v sp <- lookupMemSpace mem' @@ -596,15 +495,28 @@ case (ext_ixfun', sp == space) of (Just x, True) -> return (Var v, x, substs', mem') _ -> do - (mem, subexp) <- allocLinearArray space (baseString v) v - ixfun' <- fromJust <$> subExpIxFun subexp + (mem, v') <- allocLinearArray space (baseString v) v + ixfun' <- fromJust <$> lookupIxFun v' let (ext_ixfun, substs) = runState (IxFun.existentialize ixfun') [] - return (subexp, fromJust ext_ixfun, substs, mem) + return (Var v', fromJust ext_ixfun, substs, mem) +arrayWithIxFun :: + (MonadBuilder m, Op (Rep m) ~ MemOp inner, LetDec (Rep m) ~ LetDecMem) => + ChunkMap -> + Space -> + IxFun -> + Type -> + VName -> + m (VName, VName) +arrayWithIxFun chunkmap space ixfun v_t v = do + let Array pt shape u = v_t + mem <- allocForArray' chunkmap v_t space + v_copy <- newVName $ baseString v <> "_scalcopy" + letBind (Pat [PatElem v_copy $ MemArray pt shape u $ ArrayIn mem ixfun]) $ BasicOp $ Copy v + pure (mem, v_copy) + ensureArrayIn :: - ( Allocable fromrep torep, - Allocator torep (AllocM fromrep torep) - ) => + (Allocable fromrep torep inner) => Space -> SubExp -> WriterT ([SubExp], [SubExp]) (AllocM fromrep torep) SubExp @@ -626,18 +538,16 @@ return sub_exp ensureDirectArray :: - ( Allocable fromrep torep, - Allocator torep (AllocM fromrep torep) - ) => + (Allocable fromrep torep inner) => Maybe Space -> VName -> - AllocM fromrep torep (VName, SubExp) + AllocM fromrep torep (VName, VName) ensureDirectArray space_ok v = do (mem, ixfun) <- lookupArraySummary v mem_space <- lookupMemSpace mem default_space <- askDefaultSpace if IxFun.isDirect ixfun && maybe True (== mem_space) space_ok - then return (mem, Var v) + then return (mem, v) else needCopy (fromMaybe default_space space_ok) where needCopy space = @@ -646,28 +556,26 @@ allocLinearArray space (baseString v) v allocLinearArray :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => Space -> String -> VName -> - AllocM fromrep torep (VName, SubExp) + AllocM fromrep torep (VName, VName) allocLinearArray space s v = do t <- lookupType v case t of Array pt shape u -> do mem <- allocForArray t space - v' <- newIdent (s ++ "_linear") t + v' <- newVName $ s <> "_linear" let ixfun = directIxFun pt shape u mem t - pat = Pattern [] [PatElem (identName v') ixfun] + pat = Pat [PatElem v' ixfun] addStm $ Let pat (defAux ()) $ BasicOp $ Copy v - return (mem, Var $ identName v') + return (mem, v') _ -> error $ "allocLinearArray: " ++ pretty t funcallArgs :: - ( Allocable fromrep torep, - Allocator torep (AllocM fromrep torep) - ) => + (Allocable fromrep torep inner) => [(SubExp, Diet)] -> AllocM fromrep torep [(SubExp, Diet)] funcallArgs args = do @@ -680,9 +588,7 @@ return $ map (,Observe) (ctx_args <> mem_and_size_args) <> valargs linearFuncallArg :: - ( Allocable fromrep torep, - Allocator torep (AllocM fromrep torep) - ) => + (Allocable fromrep torep inner) => Type -> Space -> SubExp -> @@ -690,14 +596,12 @@ linearFuncallArg Array {} space (Var v) = do (mem, arg') <- lift $ ensureDirectArray (Just space) v tell ([], [Var mem]) - return arg' + pure $ Var arg' linearFuncallArg _ _ arg = - return arg + pure arg explicitAllocationsGeneric :: - ( Allocable fromrep torep, - Allocator torep (AllocM fromrep torep) - ) => + (Allocable fromrep torep inner) => (Op fromrep -> AllocM fromrep torep (Op torep)) -> (Exp torep -> AllocM fromrep torep [ExpHint]) -> Pass fromrep torep @@ -709,19 +613,17 @@ runAllocM handleOp hints $ collectStms_ $ allocInStms stms $ pure () allocInFun consts (FunDef entry attrs fname rettype params fbody) = - runAllocM handleOp hints $ - inScopeOf consts $ - allocInFParams (zip params $ repeat DefaultSpace) $ \params' -> do - fbody' <- - allocInFunBody - (map (const $ Just DefaultSpace) rettype) - fbody - return $ FunDef entry attrs fname (memoryInDeclExtType rettype) params' fbody' + runAllocM handleOp hints . inScopeOf consts $ + allocInFParams (zip params $ repeat DefaultSpace) $ \params' -> do + (fbody', mem_rets) <- + allocInFunBody (map (const $ Just DefaultSpace) rettype) fbody + let rettype' = mem_rets ++ memoryInDeclExtType (length mem_rets) rettype + return $ FunDef entry attrs fname rettype' params' fbody' explicitAllocationsInStmsGeneric :: ( MonadFreshNames m, HasScope torep m, - Allocable fromrep torep + Allocable fromrep torep inner ) => (Op fromrep -> AllocM fromrep torep (Op torep)) -> (Exp torep -> AllocM fromrep torep [ExpHint]) -> @@ -732,70 +634,73 @@ runAllocM handleOp hints $ localScope scope $ collectStms_ $ allocInStms stms $ pure () -memoryInDeclExtType :: [DeclExtType] -> [FunReturns] -memoryInDeclExtType dets = evalState (mapM addMem dets) $ startOfFreeIDRange dets +memoryInDeclExtType :: Int -> [DeclExtType] -> [FunReturns] +memoryInDeclExtType k dets = evalState (mapM addMem dets) 0 where addMem (Prim t) = return $ MemPrim t addMem Mem {} = error "memoryInDeclExtType: too much memory" addMem (Array pt shape u) = do i <- get <* modify (+ 1) - return $ - MemArray pt shape u $ - ReturnsNewBlock DefaultSpace i $ - IxFun.iota $ map convert $ shapeDims shape + let shape' = fmap shift shape + return . MemArray pt shape' u . ReturnsNewBlock DefaultSpace i $ + IxFun.iota $ map convert $ shapeDims shape' addMem (Acc acc ispace ts u) = return $ MemAcc acc ispace ts u convert (Ext i) = le64 $ Ext i convert (Free v) = Free <$> pe64 v -startOfFreeIDRange :: [TypeBase ExtShape u] -> Int -startOfFreeIDRange = S.size . shapeContext + shift (Ext i) = Ext (i + k) + shift (Free x) = Free x bodyReturnMemCtx :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => - SubExp -> - AllocM fromrep torep [SubExp] -bodyReturnMemCtx Constant {} = + (Allocable fromrep torep inner) => + SubExpRes -> + AllocM fromrep torep [(SubExpRes, MemInfo ExtSize u MemReturn)] +bodyReturnMemCtx (SubExpRes _ Constant {}) = return [] -bodyReturnMemCtx (Var v) = do +bodyReturnMemCtx (SubExpRes _ (Var v)) = do info <- lookupMemInfo v case info of MemPrim {} -> return [] MemAcc {} -> return [] MemMem {} -> return [] -- should not happen - MemArray _ _ _ (ArrayIn mem _) -> return [Var mem] + MemArray _ _ _ (ArrayIn mem _) -> do + mem_info <- lookupMemInfo mem + case mem_info of + MemMem space -> + pure [(subExpRes $ Var mem, MemMem space)] + _ -> error $ "bodyReturnMemCtx: not a memory block: " ++ pretty mem allocInFunBody :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => [Maybe Space] -> Body fromrep -> - AllocM fromrep torep (Body torep) + AllocM fromrep torep (Body torep, [FunReturns]) allocInFunBody space_oks (Body _ bnds res) = - buildBody_ . allocInStms bnds $ do + buildBody . allocInStms bnds $ do res' <- zipWithM ensureDirect space_oks' res - let (ctx_res, val_res) = splitFromEnd num_vals res' - mem_ctx_res <- concat <$> mapM bodyReturnMemCtx val_res - pure $ ctx_res <> mem_ctx_res <> val_res + (mem_ctx_res, mem_ctx_rets) <- unzip . concat <$> mapM bodyReturnMemCtx res' + pure (mem_ctx_res <> res', mem_ctx_rets) where num_vals = length space_oks space_oks' = replicate (length res - num_vals) Nothing ++ space_oks ensureDirect :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => Maybe Space -> - SubExp -> - AllocM fromrep torep SubExp -ensureDirect space_ok se = do + SubExpRes -> + AllocM fromrep torep SubExpRes +ensureDirect space_ok (SubExpRes cs se) = do se_info <- subExpMemInfo se - case (se_info, se) of + SubExpRes cs <$> case (se_info, se) of (MemArray {}, Var v) -> do (_, v') <- ensureDirectArray space_ok v - return v' + pure $ Var v' _ -> - return se + pure se allocInStms :: - (Allocable fromrep torep) => + (Allocable fromrep torep inner) => Stms fromrep -> AllocM fromrep torep a -> AllocM fromrep torep a @@ -815,53 +720,40 @@ local f $ allocInStms' stms allocInStm :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => Stm fromrep -> AllocM fromrep torep () -allocInStm (Let (Pattern sizeElems valElems) _ e) = do - e' <- allocInExp e - let sizeidents = map patElemIdent sizeElems - validents = map patElemIdent valElems - bnd <- allocsForStm sizeidents validents e' - addStm bnd +allocInStm (Let (Pat pes) _ e) = + addStm =<< allocsForStm (map patElemIdent pes) =<< allocInExp e allocInLambda :: - Allocable fromrep torep => + Allocable fromrep torep inner => [LParam torep] -> Body fromrep -> AllocM fromrep torep (Lambda torep) allocInLambda params body = - mkLambda params . allocInStms (bodyStms body) $ - pure $ bodyResult body + mkLambda params . allocInStms (bodyStms body) $ pure $ bodyResult body allocInExp :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => Exp fromrep -> AllocM fromrep torep (Exp torep) -allocInExp (DoLoop ctx val form (Body () bodybnds bodyres)) = - allocInMergeParams ctx $ \_ ctxparams' _ -> - allocInMergeParams val $ - \new_ctx_params valparams' mk_loop_val -> do - form' <- allocInLoopForm form - localScope (scopeOf form') $ do - (valinit_ctx, valinit') <- mk_loop_val valinit - body' <- - buildBody_ . allocInStms bodybnds $ do - (val_ses, valres') <- mk_loop_val valres - pure $ ctxres ++ val_ses ++ valres' - return $ - DoLoop - (zip (ctxparams' ++ new_ctx_params) (ctxinit ++ valinit_ctx)) - (zip valparams' valinit') - form' - body' - where - (_ctxparams, ctxinit) = unzip ctx - (_valparams, valinit) = unzip val - (ctxres, valres) = splitAt (length ctx) bodyres +allocInExp (DoLoop merge form (Body () bodybnds bodyres)) = + allocInMergeParams merge $ \merge' mk_loop_val -> do + form' <- allocInLoopForm form + localScope (scopeOf form') $ do + body' <- + buildBody_ . allocInStms bodybnds $ do + (val_ses, valres') <- mk_loop_val $ map resSubExp bodyres + pure $ subExpsRes val_ses <> zipWith SubExpRes (map resCerts bodyres) valres' + pure $ DoLoop merge' form' body' allocInExp (Apply fname args rettype loc) = do args' <- funcallArgs args - return $ Apply fname args' (memoryInDeclExtType rettype) loc + -- We assume that every array is going to be in its own memory. + return $ Apply fname args' (mems ++ memoryInDeclExtType 0 rettype) loc + where + mems = replicate num_arrays (MemMem DefaultSpace) + num_arrays = length $ filter ((> 0) . arrayRank . declExtTypeOf) rettype allocInExp (If cond tbranch0 fbranch0 (IfDec rets ifsort)) = do let num_rets = length rets -- switch to the explicit-mem rep, but do nothing about results @@ -892,7 +784,7 @@ (\(se, _, i) k -> (i - k, se)) ind_ses0 [0 .. length ind_ses0 - 1] - rets'' = foldl (\acc (i, se) -> fixExt i se acc) trets ind_ses + rets'' = foldl (\acc (i, SubExpRes _ se) -> fixExt i se acc) trets ind_ses tbranch'' = tbranch' {bodyResult = r_then_ext ++ drop size_ext res_then} fbranch'' = fbranch' {bodyResult = r_else_ext ++ drop size_ext res_else} res_if_expr = If cond tbranch'' fbranch'' $ IfDec rets'' ifsort @@ -923,14 +815,14 @@ selectSub f (Just (ixfn, m)) = Just (ixfn, map f m) selectSub _ Nothing = Nothing allocInIfBody :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => Int -> Body fromrep -> AllocM fromrep torep (Body torep, [Maybe IxFun]) allocInIfBody num_vals (Body _ bnds res) = buildBody . allocInStms bnds $ do let (_, val_res) = splitFromEnd num_vals res - mem_ixfs <- mapM subExpIxFun val_res + mem_ixfs <- mapM (subExpIxFun . resSubExp) val_res pure (res, mem_ixfs) allocInExp (WithAcc inputs bodylam) = WithAcc <$> mapM onInput inputs <*> onLambda bodylam @@ -963,7 +855,7 @@ mkP p pt shape u mem ixfun is = Param p . MemArray pt shape u . ArrayIn mem . IxFun.slice ixfun $ - fmap (fmap pe64) $ is ++ map sliceDim (shapeDims shape) + fmap pe64 $ Slice $ is ++ map sliceDim (shapeDims shape) onXParam _ (Param p (Prim t)) _ = return $ Param p (MemPrim t) @@ -997,90 +889,93 @@ handle op } -subExpIxFun :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => - SubExp -> +lookupIxFun :: + (Allocable fromrep torep inner) => + VName -> AllocM fromrep torep (Maybe IxFun) -subExpIxFun Constant {} = return Nothing -subExpIxFun (Var v) = do +lookupIxFun v = do info <- lookupMemInfo v case info of MemArray _ptp _shp _u (ArrayIn _ ixf) -> return $ Just ixf _ -> return Nothing +subExpIxFun :: + (Allocable fromrep torep inner) => + SubExp -> + AllocM fromrep torep (Maybe IxFun) +subExpIxFun Constant {} = return Nothing +subExpIxFun (Var v) = lookupIxFun v + +shiftShapeExts :: Int -> MemInfo ExtSize u r -> MemInfo ExtSize u r +shiftShapeExts k (MemArray pt shape u returns) = + MemArray pt (fmap shift shape) u returns + where + shift (Ext i) = Ext (i + k) + shift (Free x) = Free x +shiftShapeExts _ ret = ret + addResCtxInIfBody :: - (Allocable fromrep torep, Allocator torep (AllocM fromrep torep)) => + (Allocable fromrep torep inner) => [ExtType] -> Body torep -> [Maybe Space] -> [Maybe (ExtIxFun, [TPrimExp Int64 VName])] -> AllocM fromrep torep (Body torep, [BodyReturns]) -addResCtxInIfBody ifrets (Body _ bnds res) spaces substs = do - let num_vals = length ifrets - (ctx_res, val_res) = splitFromEnd num_vals res - ((res', bodyrets'), all_body_stms) <- collectStms $ do - mapM_ addStm bnds - (val_res', ext_ses_res, mem_ctx_res, bodyrets, total_existentials) <- - foldM helper ([], [], [], [], length ctx_res) (zip4 ifrets val_res substs spaces) - return - ( ctx_res <> ext_ses_res <> mem_ctx_res <> val_res', - -- We need to adjust the ReturnsNewBlock existentials, because they - -- should always be numbered _after_ all other existentials in the - -- return values. - reverse $ fst $ foldl adjustNewBlockExistential ([], total_existentials) bodyrets - ) - body' <- mkBodyM all_body_stms res' - return (body', bodyrets') +addResCtxInIfBody ifrets (Body _ bnds res) spaces substs = buildBody $ do + mapM_ addStm bnds + (ctx, ctx_rets, res', res_rets, total_existentials) <- + foldM helper ([], [], [], [], 0) (zip4 ifrets res substs spaces) + pure + ( ctx <> res', + -- We need to adjust the existentials in shapes corresponding + -- to the previous type, because we added more existentials in + -- front. + ctx_rets ++ map (shiftShapeExts total_existentials) res_rets + ) where - helper (res_acc, ext_acc, ctx_acc, br_acc, k) (ifr, r, mbixfsub, sp) = + helper (ctx_acc, ctx_rets_acc, res_acc, res_rets_acc, k) (ifr, r, mbixfsub, sp) = case mbixfsub of Nothing -> do -- does NOT generalize/antiunify; ensure direct r' <- ensureDirect sp r - mem_ctx_r <- bodyReturnMemCtx r' - let body_ret = inspect ifr sp - return - ( res_acc ++ [r'], - ext_acc, - ctx_acc ++ mem_ctx_r, - br_acc ++ [body_ret], - k + (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r' + let body_ret = inspect k ifr sp + pure + ( ctx_acc ++ mem_ctx_ses, + ctx_rets_acc ++ mem_ctx_rets, + res_acc ++ [r'], + res_rets_acc ++ [body_ret], + k + length mem_ctx_ses ) Just (ixfn, m) -> do -- generalizes let i = length m ext_ses <- mapM (toSubExp "ixfn_exist") m - mem_ctx_r <- bodyReturnMemCtx r + (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r let sp' = fromMaybe DefaultSpace sp ixfn' = fmap (adjustExtPE k) ixfn exttp = case ifr of Array pt shp' u -> - MemArray pt shp' u $ - ReturnsNewBlock sp' 0 ixfn' + MemArray pt shp' u $ ReturnsNewBlock sp' (k + i) ixfn' _ -> error "Impossible case reached in addResCtxInIfBody" - return - ( res_acc ++ [r], - ext_acc ++ ext_ses, - ctx_acc ++ mem_ctx_r, - br_acc ++ [exttp], - k + i + pure + ( ctx_acc ++ subExpsRes ext_ses ++ mem_ctx_ses, + ctx_rets_acc ++ map (const (MemPrim int64)) ext_ses ++ mem_ctx_rets, + res_acc ++ [r], + res_rets_acc ++ [exttp], + k + i + 1 ) - adjustNewBlockExistential :: ([BodyReturns], Int) -> BodyReturns -> ([BodyReturns], Int) - adjustNewBlockExistential (acc, k) (MemArray pt shp u (ReturnsNewBlock space _ ixfun)) = - (MemArray pt shp u (ReturnsNewBlock space k ixfun) : acc, k + 1) - adjustNewBlockExistential (acc, k) x = (x : acc, k) - - inspect (Array pt shape u) space = + inspect k (Array pt shape u) space = let space' = fromMaybe DefaultSpace space bodyret = MemArray pt shape u $ - ReturnsNewBlock space' 0 $ + ReturnsNewBlock space' k $ IxFun.iota $ map convert $ shapeDims shape in bodyret - inspect (Acc acc ispace ts u) _ = MemAcc acc ispace ts u - inspect (Prim pt) _ = MemPrim pt - inspect (Mem space) _ = MemMem space + inspect _ (Acc acc ispace ts u) _ = MemAcc acc ispace ts u + inspect _ (Prim pt) _ = MemPrim pt + inspect _ (Mem space) _ = MemMem space convert (Ext i) = le64 (Ext i) convert (Free v) = Free <$> pe64 v @@ -1093,13 +988,12 @@ adjustExtPE k = fmap (adjustExtV k) mkSpaceOks :: - (Mem torep, LocalScope torep m) => + (Mem torep inner, LocalScope torep m) => Int -> Body torep -> m [Maybe Space] mkSpaceOks num_vals (Body _ stms res) = - inScopeOf stms $ - mapM mkSpaceOK $ takeLast num_vals res + inScopeOf stms $ mapM (mkSpaceOK . resSubExp) $ takeLast num_vals res where mkSpaceOK (Var v) = do v_info <- lookupMemInfo v @@ -1113,9 +1007,7 @@ mkSpaceOK _ = return Nothing allocInLoopForm :: - ( Allocable fromrep torep, - Allocator torep (AllocM fromrep torep) - ) => + (Allocable fromrep torep inner) => LoopForm fromrep -> AllocM fromrep torep (LoopForm torep) allocInLoopForm (WhileLoop v) = return $ WhileLoop v @@ -1139,7 +1031,7 @@ return (p {paramDec = MemAcc acc ispace ts u}, a) class SizeSubst op where - opSizeSubst :: PatternT dec -> op -> ChunkMap + opSizeSubst :: PatT dec -> op -> ChunkMap opIsConst :: op -> Bool opIsConst = const False @@ -1159,49 +1051,52 @@ stmConsts :: SizeSubst (Op rep) => Stm rep -> S.Set VName stmConsts (Let pat _ (Op op)) - | opIsConst op = S.fromList $ patternNames pat + | opIsConst op = S.fromList $ patNames pat stmConsts _ = mempty mkLetNamesB' :: - ( Op (Rep m) ~ MemOp inner, - MonadBinder m, - ExpDec (Rep m) ~ (), - Allocator (Rep m) (PatAllocM (Rep m)) + ( LetDec (Rep m) ~ LetDecMem, + Mem (Rep m) inner, + MonadBuilder m, + ExpDec (Rep m) ~ () ) => ExpDec (Rep m) -> [VName] -> Exp (Rep m) -> m (Stm (Rep m)) mkLetNamesB' dec names e = do - scope <- askScope - pat <- bindPatternWithAllocations scope names e - return $ Let pat (defAux dec) e + pat <- patWithAllocations DefaultSpace mempty names e nohints + pure $ Let pat (defAux dec) e + where + nohints = map (const NoHint) names mkLetNamesB'' :: - ( Op (Rep m) ~ MemOp inner, + ( BuilderOps rep, + Mem rep inner, + LetDec rep ~ LetDecMem, + OpReturns (Engine.OpWithWisdom inner), ExpDec rep ~ (), + Rep m ~ Engine.Wise rep, HasScope (Engine.Wise rep) m, - Allocator rep (PatAllocM rep), - MonadBinder m, - Engine.CanBeWise (Op rep) + MonadBuilder m, + Engine.CanBeWise inner ) => [VName] -> Exp (Engine.Wise rep) -> m (Stm (Engine.Wise rep)) mkLetNamesB'' names e = do - scope <- Engine.removeScopeWisdom <$> askScope - (pat, prestms) <- runPatAllocM (patternWithAllocations names $ Engine.removeExpWisdom e) scope - mapM_ bindAllocStm prestms - let pat' = Engine.addWisdomToPattern pat e + pat <- patWithAllocations DefaultSpace mempty names e nohints + let pat' = Engine.addWisdomToPat pat e dec = Engine.mkWiseExpDec pat' () e - return $ Let pat' (defAux dec) e + pure $ Let pat' (defAux dec) e + where + nohints = map (const NoHint) names simplifiable :: ( Engine.SimplifiableRep rep, ExpDec rep ~ (), BodyDec rep ~ (), - Op rep ~ MemOp inner, - Allocator rep (PatAllocM rep) + Mem rep inner ) => (Engine.OpWithWisdom inner -> UT.UsageTable) -> (inner -> Engine.SimpleM rep (Engine.OpWithWisdom inner, Stms (Engine.Wise rep))) -> @@ -1235,21 +1130,6 @@ simplifyOp (Inner k) = do (k', hoisted) <- simplifyInnerOp k return (Inner k', hoisted) - -bindPatternWithAllocations :: - ( MonadBinder m, - ExpDec rep ~ (), - Op (Rep m) ~ MemOp inner, - Allocator rep (PatAllocM rep) - ) => - Scope rep -> - [VName] -> - Exp rep -> - m (Pattern rep) -bindPatternWithAllocations types names e = do - (pat, prebnds) <- runPatAllocM (patternWithAllocations names e) types - mapM_ bindAllocStm prebnds - return pat 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 @@ -19,7 +19,7 @@ import Futhark.Pass.ExplicitAllocations.SegOp instance SizeSubst (HostOp rep op) where - opSizeSubst (Pattern _ [size]) (SizeOp (SplitSpace _ _ _ elems_per_thread)) = + opSizeSubst (Pat [size]) (SizeOp (SplitSpace _ _ _ elems_per_thread)) = M.singleton (patElemName size) elems_per_thread opSizeSubst _ _ = mempty @@ -77,7 +77,7 @@ handleHostOp (SegOp op) = Inner . SegOp <$> handleSegOp op -kernelExpHints :: Allocator GPUMem m => Exp GPUMem -> m [ExpHint] +kernelExpHints :: Exp GPUMem -> AllocM GPU GPUMem [ExpHint] kernelExpHints (BasicOp (Manifest perm v)) = do dims <- arrayDims <$> lookupType v let perm_inv = rearrangeInverse perm @@ -95,12 +95,11 @@ return $ replicate (expExtTypeSize e) NoHint mapResultHint :: - Allocator rep m => SegLevel -> SegSpace -> Type -> KernelResult -> - m ExpHint + AllocM GPU GPUMem ExpHint mapResultHint lvl space = hint where num_threads = @@ -114,13 +113,15 @@ hint t Returns {} | coalesceReturnOfShape (primByteSize (elemType t)) $ arrayDims t = do + chunkmap <- asks chunkMap let space_dims = segSpaceDims space - t_dims <- mapM dimAllocationSize $ arrayDims t + t_dims = map (dimAllocationSize chunkmap) $ arrayDims t return $ Hint (innermost space_dims t_dims) DefaultSpace - hint t (ConcatReturns SplitStrided {} w _ _) = do - t_dims <- mapM dimAllocationSize $ arrayDims t + hint t (ConcatReturns _ SplitStrided {} w _ _) = do + chunkmap <- asks chunkMap + let t_dims = map (dimAllocationSize chunkmap) $ arrayDims t return $ Hint (innermost [w] t_dims) DefaultSpace - hint Prim {} (ConcatReturns SplitContiguous w elems_per_thread _) = do + hint Prim {} (ConcatReturns _ SplitContiguous w elems_per_thread _) = do let ixfun_base = IxFun.iota [sExt64 num_threads, pe64 elems_per_thread] ixfun_tr = IxFun.permute ixfun_base [1, 0] ixfun = IxFun.reshape ixfun_tr $ map (DimNew . pe64) [w] @@ -144,13 +145,13 @@ semiStatic _ Constant {} = True semiStatic consts (Var v) = v `S.member` consts -inGroupExpHints :: Allocator GPUMem m => Exp GPUMem -> m [ExpHint] +inGroupExpHints :: Exp GPUMem -> AllocM GPU GPUMem [ExpHint] inGroupExpHints (Op (Inner (SegOp (SegMap _ space ts body)))) | any private $ kernelBodyResult body = do - consts <- askConsts - return $ do + consts <- asks envConsts + pure $ do (t, r) <- zip ts $ kernelBodyResult body - return $ + pure $ if private r && all (semiStatic consts) (arrayDims t) then let seg_dims = map pe64 $ segSpaceDims space @@ -163,22 +164,22 @@ $ ScalarSpace (arrayDims t) $ elemType t else NoHint where - private (Returns ResultPrivate _) = True + private (Returns ResultPrivate _ _) = True private _ = False -inGroupExpHints e = return $ replicate (expExtTypeSize e) NoHint +inGroupExpHints e = pure $ replicate (expExtTypeSize e) NoHint -inThreadExpHints :: Allocator GPUMem m => Exp GPUMem -> m [ExpHint] +inThreadExpHints :: Exp GPUMem -> AllocM GPU GPUMem [ExpHint] inThreadExpHints e = do - consts <- askConsts + consts <- asks envConsts mapM (maybePrivate consts) =<< expExtType e where maybePrivate consts t | Just (Array pt shape _) <- hasStaticShape t, all (semiStatic consts) $ shapeDims shape = do let ixfun = IxFun.iota $ map pe64 $ shapeDims shape - return $ Hint ixfun $ ScalarSpace (shapeDims shape) pt + pure $ Hint ixfun $ ScalarSpace (shapeDims shape) pt | otherwise = - return NoHint + pure NoHint -- | The pass from 'GPU' to 'GPUMem'. explicitAllocations :: Pass GPU GPUMem diff --git a/src/Futhark/Pass/ExplicitAllocations/MC.hs b/src/Futhark/Pass/ExplicitAllocations/MC.hs --- a/src/Futhark/Pass/ExplicitAllocations/MC.hs +++ b/src/Futhark/Pass/ExplicitAllocations/MC.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Converting 'MC' programs to 'MCMem'. module Futhark.Pass.ExplicitAllocations.MC (explicitAllocations) where import Futhark.IR.MC @@ -33,5 +34,6 @@ handleMCOp (OtherOp soac) = error $ "Cannot allocate memory in SOAC: " ++ pretty soac +-- | The pass from 'MC' to 'MCMem'. explicitAllocations :: Pass MC MCMem explicitAllocations = explicitAllocationsGeneric handleMCOp defaultExpHints 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 @@ -17,7 +17,7 @@ opSizeSubst _ _ = mempty allocInKernelBody :: - Allocable fromrep torep => + Allocable fromrep torep inner => KernelBody fromrep -> AllocM fromrep torep (KernelBody torep) allocInKernelBody (KernelBody () stms res) = @@ -25,7 +25,7 @@ <$> collectStms (allocInStms stms (pure res)) allocInLambda :: - Allocable fromrep torep => + Allocable fromrep torep inner => [LParam torep] -> Body fromrep -> AllocM fromrep torep (Lambda torep) @@ -34,7 +34,7 @@ pure $ bodyResult body allocInBinOpParams :: - Allocable fromrep torep => + Allocable fromrep torep inner => SubExp -> TPrimExp Int64 VName -> TPrimExp Int64 VName -> @@ -83,7 +83,7 @@ ) allocInBinOpLambda :: - Allocable fromrep torep => + 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 @@ -166,7 +166,7 @@ import Data.Bifunctor (first) import Data.Maybe import qualified Futhark.IR.GPU as Out -import Futhark.IR.GPU.Kernel +import Futhark.IR.GPU.Op import Futhark.IR.SOACS import Futhark.IR.SOACS.Simplify (simplifyStms) import Futhark.MonadFreshNames @@ -300,7 +300,7 @@ unbalancedLambda lam2, lambdaContainsParallelism lam2 = do types <- asksScope scopeForSOACs - Just . snd <$> runBinderT (FOT.transformSOAC pat soac) types + Just . snd <$> runBuilderT (FOT.transformSOAC pat soac) types sequentialisedUnbalancedStm _ = return Nothing @@ -313,7 +313,7 @@ x <- gets stateThresholdCounter modify $ \s -> s {stateThresholdCounter = x + 1} let size_key = nameFromString $ desc ++ "_" ++ show x - runBinder $ do + runBuilder $ do to_what' <- letSubExp "comparatee" =<< foldBinOp (Mul Int64 OverflowUndef) (intConst Int64 1) to_what @@ -322,26 +322,25 @@ kernelAlternatives :: (MonadFreshNames m, HasScope Out.GPU m) => - Out.Pattern Out.GPU -> + Out.Pat Out.GPU -> Out.Body Out.GPU -> [(SubExp, Out.Body Out.GPU)] -> m (Out.Stms Out.GPU) -kernelAlternatives pat default_body [] = runBinder_ $ do +kernelAlternatives pat default_body [] = runBuilder_ $ do ses <- bodyBind default_body - forM_ (zip (patternNames pat) ses) $ \(name, se) -> - letBindNames [name] $ BasicOp $ SubExp se -kernelAlternatives pat default_body ((cond, alt) : alts) = runBinder_ $ do - alts_pat <- fmap (Pattern []) $ - forM (patternElements pat) $ \pe -> do - name <- newVName $ baseString $ patElemName pe - return pe {patElemName = name} + forM_ (zip (patNames pat) ses) $ \(name, SubExpRes cs se) -> + certifying cs $ letBindNames [name] $ BasicOp $ SubExp se +kernelAlternatives pat default_body ((cond, alt) : alts) = runBuilder_ $ do + alts_pat <- fmap Pat . forM (patElems pat) $ \pe -> do + name <- newVName $ baseString $ patElemName pe + return pe {patElemName = name} alt_stms <- kernelAlternatives alts_pat default_body alts - let alt_body = mkBody alt_stms $ map Var $ patternValueNames alts_pat + let alt_body = mkBody alt_stms $ varsRes $ patNames alts_pat letBind pat $ If cond alt alt_body $ - IfDec (staticShapes (patternTypes pat)) IfEquiv + IfDec (staticShapes (patTypes pat)) IfEquiv transformLambda :: KernelPath -> Lambda -> DistribM (Out.Lambda Out.GPU) transformLambda path (Lambda params body ret) = @@ -352,11 +351,11 @@ transformStm :: KernelPath -> Stm -> DistribM GPUStms transformStm _ stm | "sequential" `inAttrs` stmAuxAttrs (stmAux stm) = - runBinder_ $ FOT.transformStmRecursively stm + runBuilder_ $ FOT.transformStmRecursively stm transformStm path (Let pat aux (Op soac)) | "sequential_outer" `inAttrs` stmAuxAttrs aux = transformStms path . stmsToList . fmap (certify (stmAuxCerts aux)) - =<< runBinder_ (FOT.transformSOAC pat soac) + =<< runBuilder_ (FOT.transformSOAC pat soac) transformStm path (Let pat aux (If c tb fb rt)) = do tb' <- transformBody path tb fb' <- transformBody path fb @@ -367,14 +366,11 @@ where transformInput (shape, arrs, op) = (shape, arrs, fmap (first soacsLambdaToGPU) op) -transformStm path (Let pat aux (DoLoop ctx val form body)) = - localScope - ( castScope (scopeOf form) - <> scopeOfFParams mergeparams - ) - $ oneStm . Let pat aux . DoLoop ctx val form' <$> transformBody path body +transformStm path (Let pat aux (DoLoop merge form body)) = + localScope (castScope (scopeOf form) <> scopeOfFParams params) $ + oneStm . Let pat aux . DoLoop merge form' <$> transformBody path body where - mergeparams = map fst $ ctx ++ val + params = map fst merge form' = case form of WhileLoop cond -> WhileLoop cond @@ -388,8 +384,8 @@ Scan scan_lam nes <- singleScan scans, Just do_iswim <- iswim res_pat w scan_lam $ zip nes arrs = do types <- asksScope scopeForSOACs - transformStms path . stmsToList . snd =<< runBinderT (certifying cs do_iswim) types - | Just (scans, map_lam) <- isScanomapSOAC form = runBinder_ $ do + transformStms path . stmsToList . snd =<< runBuilderT (certifying cs do_iswim) types + | Just (scans, map_lam) <- isScanomapSOAC form = runBuilder_ $ do scan_ops <- forM scans $ \(Scan scan_lam nes) -> do (scan_lam', nes', shape) <- determineReduceOp scan_lam nes let scan_lam'' = soacsLambdaToGPU scan_lam' @@ -405,11 +401,11 @@ | otherwise = comm, Just do_irwim <- irwim res_pat w comm' red_fun $ zip nes arrs = do types <- asksScope scopeForSOACs - (_, bnds) <- fst <$> runBinderT (simplifyStms =<< collectStms_ (auxing aux do_irwim)) types + (_, bnds) <- fst <$> runBuilderT (simplifyStms =<< collectStms_ (auxing aux do_irwim)) types transformStms path $ stmsToList bnds transformStm path (Let pat aux@(StmAux cs _ _) (Op (Screma w arrs form))) | Just (reds, map_lam) <- isRedomapSOAC form = do - let paralleliseOuter = runBinder_ $ do + let paralleliseOuter = runBuilder_ $ do red_ops <- forM reds $ \(Reduce comm red_lam nes) -> do (red_lam', nes', shape) <- determineReduceOp red_lam nes let comm' @@ -424,25 +420,20 @@ outerParallelBody = renameBody - =<< (mkBody <$> paralleliseOuter <*> pure (map Var (patternNames pat))) + =<< (mkBody <$> paralleliseOuter <*> pure (varsRes (patNames pat))) paralleliseInner path' = do (mapstm, redstm) <- - redomapToMapAndReduce pat (w, comm', red_lam, map_lam, nes, arrs) + redomapToMapAndReduce pat (w, reds, map_lam, arrs) types <- asksScope scopeForSOACs - transformStms path' . stmsToList <=< (`runBinderT_` types) $ do + transformStms path' . stmsToList <=< (`runBuilderT_` types) $ do (_, stms) <- simplifyStms (stmsFromList [certify cs mapstm, certify cs redstm]) addStms stms - where - comm' - | commutativeLambda red_lam = Commutative - | otherwise = comm - (Reduce comm red_lam nes) = singleReduce reds innerParallelBody path' = renameBody - =<< (mkBody <$> paralleliseInner path' <*> pure (map Var (patternNames pat))) + =<< (mkBody <$> paralleliseInner path' <*> pure (varsRes (patNames pat))) if not (lambdaContainsParallelism map_lam) || "sequential_inner" `inAttrs` stmAuxAttrs aux @@ -464,7 +455,7 @@ -- parallel. It will be distributed. types <- asksScope scopeForSOACs transformStms path . stmsToList . snd - =<< runBinderT (certifying cs $ sequentialStreamWholeArray pat w [] map_fun arrs) types + =<< runBuilderT (certifying cs $ sequentialStreamWholeArray pat w [] map_fun arrs) types transformStm path (Let pat aux@(StmAux cs _ _) (Op (Stream w arrs (Parallel o comm red_fun) nes fold_fun))) | "sequential_inner" `inAttrs` stmAuxAttrs aux = paralleliseOuter path @@ -485,8 +476,8 @@ let fold_fun' = soacsLambdaToGPU fold_fun let (red_pat_elems, concat_pat_elems) = - splitAt (length nes) $ patternValueElements pat - red_pat = Pattern [] red_pat_elems + splitAt (length nes) $ patElems pat + red_pat = Pat red_pat_elems ((num_threads, red_results), stms) <- streamMap @@ -524,16 +515,16 @@ outerParallelBody path' = renameBody - =<< (mkBody <$> paralleliseOuter path' <*> pure (map Var (patternNames pat))) + =<< (mkBody <$> paralleliseOuter path' <*> pure (varsRes (patNames pat))) paralleliseInner path' = do types <- asksScope scopeForSOACs transformStms path' . fmap (certify cs) . stmsToList . snd - =<< runBinderT (sequentialStreamWholeArray pat w nes fold_fun arrs) types + =<< runBuilderT (sequentialStreamWholeArray pat w nes fold_fun arrs) types innerParallelBody path' = renameBody - =<< (mkBody <$> paralleliseInner path' <*> pure (map Var (patternNames pat))) + =<< (mkBody <$> paralleliseInner path' <*> pure (varsRes (patNames pat))) comm' | commutativeLambda red_fun, o /= InOrder = Commutative @@ -543,22 +534,25 @@ -- anything, so split it up and try again. scope <- asksScope scopeForSOACs transformStms path . map (certify cs) . stmsToList . snd - =<< runBinderT (dissectScrema pat w form arrs) scope + =<< runBuilderT (dissectScrema pat w form arrs) scope transformStm path (Let pat _ (Op (Stream w arrs Sequential nes fold_fun))) = do -- Remove the stream and leave the body parallel. It will be -- distributed. types <- asksScope scopeForSOACs transformStms path . stmsToList . snd - =<< runBinderT (sequentialStreamWholeArray pat w nes fold_fun arrs) types -transformStm _ (Let pat (StmAux cs _ _) (Op (Scatter w lam ivs as))) = runBinder_ $ do + =<< runBuilderT (sequentialStreamWholeArray pat w nes fold_fun arrs) types +transformStm _ (Let pat (StmAux cs _ _) (Op (Scatter w lam ivs as))) = runBuilder_ $ do let lam' = soacsLambdaToGPU lam write_i <- newVName "write_i" let (as_ws, _, _) = unzip3 as kstms = bodyStms $ lambdaBody lam' krets = do - (a_w, a, is_vs) <- - groupScatterResults as $ bodyResult $ lambdaBody lam' - return $ WriteReturns a_w a [(map DimFix is, v) | (is, v) <- is_vs] + (a_w, a, is_vs) <- groupScatterResults as $ bodyResult $ lambdaBody lam' + let res_cs = + foldMap (foldMap resCerts . fst) is_vs + <> foldMap (resCerts . snd) is_vs + is_vs' = [(Slice $ map (DimFix . resSubExp) is, resSubExp v) | (is, v) <- is_vs] + return $ WriteReturns res_cs a_w a is_vs' body = KernelBody () kstms krets inputs = do (p, p_a) <- zip (lambdaParams lam') ivs @@ -568,7 +562,7 @@ segThreadCapped [(write_i, w)] inputs - (zipWith (stripArray . length) as_ws $ patternTypes pat) + (zipWith (stripArray . length) as_ws $ patTypes pat) body certifying cs $ do addStms stms @@ -579,13 +573,13 @@ -- It is important not to launch unnecessarily many threads for -- histograms, because it may mean we unnecessarily need to reduce -- subhistograms as well. - runBinder_ $ do + runBuilder_ $ do lvl <- segThreadCapped [w] "seghist" $ NoRecommendation SegNoVirt addStms =<< histKernel onLambda lvl orig_pat [] [] cs w ops bfun' imgs where onLambda = pure . soacsLambdaToGPU transformStm _ bnd = - runBinder_ $ FOT.transformStmRecursively bnd + runBuilder_ $ FOT.transformStmRecursively bnd sufficientParallelism :: String -> @@ -612,7 +606,7 @@ mapLike w lam' | Op (Scatter w lam' _ _) <- stmExp stm = mapLike w lam' - | DoLoop _ _ _ body <- stmExp stm = + | DoLoop _ _ body <- stmExp stm = bodyInterest body * 10 | If _ tbody fbody _ <- stmExp stm = max (bodyInterest tbody) (bodyInterest fbody) @@ -652,7 +646,7 @@ else bodyInterest (lambdaBody lam') | Op Scatter {} <- stmExp stm = 0 -- Basically a map. - | DoLoop _ _ ForLoop {} body <- stmExp stm = + | DoLoop _ ForLoop {} body <- stmExp stm = bodyInterest body * 10 | WithAcc _ withacc_lam <- stmExp stm = bodyInterest (lambdaBody withacc_lam) @@ -686,7 +680,7 @@ DistEnv { distNest = singleNesting (Nesting mempty loopnest), distScope = - scopeOfPattern pat + scopeOfPat pat <> scopeForGPU (scopeOf lam) <> types, distOnInnerMap = onInnerMap path', @@ -740,7 +734,7 @@ KernelPath -> (KernelPath -> DistribM (Out.Stms Out.GPU)) -> (KernelPath -> DistribM (Out.Stms Out.GPU)) -> - Pattern -> + Pat -> Lambda -> DistribM (Out.Stms Out.GPU) onMap' loopnest path mk_seq_stms mk_par_stms pat lam = do @@ -816,7 +810,7 @@ [(outer_suff, seq_body), (intra_ok, group_par_body)] where nest_ws = kernelNestWidths loopnest - res = map Var $ patternNames pat + res = varsRes $ patNames pat aux = loopNestingAux $ innermostKernelNesting loopnest attrs = stmAuxAttrs aux @@ -846,7 +840,7 @@ path' (Just intraMinInnerPar) - runBinder $ do + runBuilder $ do addStms intra_prelude max_group_size <- @@ -925,7 +919,7 @@ let sequentialised_lam = soacsLambdaToGPU lam' constructKernel segThreadCapped nest' $ lambdaBody sequentialised_lam - let outer_pat = loopNestingPattern $ fst nest + let outer_pat = loopNestingPat $ fst nest (nestw_bnds <>) <$> onMap' nest' 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 @@ -32,9 +32,9 @@ -- | Constraints pertinent to performing distribution/flattening. type DistRep rep = - ( Bindable rep, + ( Buildable rep, HasSegOp rep, - BinderOps rep, + BuilderOps rep, LetDec rep ~ Type, ExpDec rep ~ (), BodyDec rep ~ (), @@ -44,13 +44,13 @@ data ThreadRecommendation = ManyThreads | NoRecommendation SegVirt type MkSegLevel rep m = - [SubExp] -> String -> ThreadRecommendation -> BinderT rep m (SegOpLevel rep) + [SubExp] -> String -> ThreadRecommendation -> BuilderT rep m (SegOpLevel rep) mkSegSpace :: MonadFreshNames m => [(VName, SubExp)] -> m SegSpace mkSegSpace dims = SegSpace <$> newVName "phys_tid" <*> pure dims prepareRedOrScan :: - (MonadBinder m, DistRep (Rep m)) => + (MonadBuilder m, DistRep (Rep m)) => SubExp -> Lambda (Rep m) -> [VName] -> @@ -61,20 +61,21 @@ gtid <- newVName "gtid" space <- mkSegSpace $ ispace ++ [(gtid, w)] kbody <- fmap (uncurry (flip (KernelBody ()))) $ - runBinder $ + runBuilder $ localScope (scopeOfSegSpace space) $ do mapM_ readKernelInput inps mapM_ readKernelInput $ do (p, arr) <- zip (lambdaParams map_lam) arrs pure $ KernelInput (paramName p) (paramType p) arr [Var gtid] - map (Returns ResultMaySimplify) <$> bodyBind (lambdaBody map_lam) + res <- bodyBind (lambdaBody map_lam) + forM res $ \(SubExpRes cs se) -> pure $ Returns ResultMaySimplify cs se return (space, kbody) segRed :: (MonadFreshNames m, DistRep rep, HasScope rep m) => SegOpLevel rep -> - Pattern rep -> + Pat rep -> SubExp -> -- segment size [SegBinOp rep] -> Lambda rep -> @@ -82,7 +83,7 @@ [(VName, SubExp)] -> -- ispace = pair of (gtid, size) for the maps on "top" of this reduction [KernelInput] -> -- inps = inputs that can be looked up by using the gtids from ispace m (Stms rep) -segRed lvl pat w ops map_lam arrs ispace inps = runBinder_ $ do +segRed lvl pat w ops map_lam arrs ispace inps = runBuilder_ $ do (kspace, kbody) <- prepareRedOrScan w map_lam arrs ispace inps letBind pat $ Op $ @@ -92,7 +93,7 @@ segScan :: (MonadFreshNames m, DistRep rep, HasScope rep m) => SegOpLevel rep -> - Pattern rep -> + Pat rep -> SubExp -> -- segment size [SegBinOp rep] -> Lambda rep -> @@ -100,7 +101,7 @@ [(VName, SubExp)] -> -- ispace = pair of (gtid, size) for the maps on "top" of this scan [KernelInput] -> -- inps = inputs that can be looked up by using the gtids from ispace m (Stms rep) -segScan lvl pat w ops map_lam arrs ispace inps = runBinder_ $ do +segScan lvl pat w ops map_lam arrs ispace inps = runBuilder_ $ do (kspace, kbody) <- prepareRedOrScan w map_lam arrs ispace inps letBind pat $ Op $ @@ -110,14 +111,14 @@ segMap :: (MonadFreshNames m, DistRep rep, HasScope rep m) => SegOpLevel rep -> - Pattern rep -> + Pat rep -> SubExp -> -- segment size Lambda rep -> [VName] -> [(VName, SubExp)] -> -- ispace = pair of (gtid, size) for the maps on "top" of this map [KernelInput] -> -- inps = inputs that can be looked up by using the gtids from ispace m (Stms rep) -segMap lvl pat w map_lam arrs ispace inps = runBinder_ $ do +segMap lvl pat w map_lam arrs ispace inps = runBuilder_ $ do (kspace, kbody) <- prepareRedOrScan w map_lam arrs ispace inps letBind pat $ Op $ @@ -125,9 +126,9 @@ SegMap lvl kspace (lambdaReturnType map_lam) kbody dummyDim :: - (MonadFreshNames m, MonadBinder m, DistRep (Rep m)) => - Pattern (Rep m) -> - m (Pattern (Rep m), [(VName, SubExp)], m ()) + (MonadFreshNames m, MonadBuilder m, DistRep (Rep m)) => + Pat (Rep m) -> + m (Pat (Rep m), [(VName, SubExp)], m ()) dummyDim pat = do -- We add a unit-size segment on top to ensure that the result -- of the SegRed is an array, which we then immediately index. @@ -136,14 +137,14 @@ -- host-device copy (scalars are kept on the host, but arrays -- may be on the device). let addDummyDim t = t `arrayOfRow` intConst Int64 1 - pat' <- fmap addDummyDim <$> renamePattern pat + pat' <- fmap addDummyDim <$> renamePat pat dummy <- newVName "dummy" let ispace = [(dummy, intConst Int64 1)] return ( pat', ispace, - forM_ (zip (patternNames pat') (patternNames pat)) $ \(from, to) -> do + forM_ (zip (patNames pat') (patNames pat)) $ \(from, to) -> do from_t <- lookupType from letBindNames [to] $ BasicOp $ @@ -154,13 +155,13 @@ nonSegRed :: (MonadFreshNames m, DistRep rep, HasScope rep m) => SegOpLevel rep -> - Pattern rep -> + Pat rep -> SubExp -> [SegBinOp rep] -> Lambda rep -> [VName] -> m (Stms rep) -nonSegRed lvl pat w ops map_lam arrs = runBinder_ $ do +nonSegRed lvl pat w ops map_lam arrs = runBuilder_ $ do (pat', ispace, read_dummy) <- dummyDim pat addStms =<< segRed lvl pat' w ops map_lam arrs ispace [] read_dummy @@ -168,7 +169,7 @@ segHist :: (DistRep rep, MonadFreshNames m, HasScope rep m) => SegOpLevel rep -> - Pattern rep -> + Pat rep -> SubExp -> -- | Segment indexes and sizes. [(VName, SubExp)] -> @@ -177,19 +178,21 @@ Lambda rep -> [VName] -> m (Stms rep) -segHist lvl pat arr_w ispace inps ops lam arrs = runBinder_ $ do +segHist lvl pat arr_w ispace inps ops lam arrs = runBuilder_ $ do gtid <- newVName "gtid" space <- mkSegSpace $ ispace ++ [(gtid, arr_w)] kbody <- fmap (uncurry (flip $ KernelBody ())) $ - runBinder $ + runBuilder $ localScope (scopeOfSegSpace space) $ do mapM_ readKernelInput inps forM_ (zip (lambdaParams lam) arrs) $ \(p, arr) -> do arr_t <- lookupType arr letBindNames [paramName p] $ BasicOp $ Index arr $ fullSlice arr_t [DimFix $ Var gtid] - map (Returns ResultMaySimplify) <$> bodyBind (lambdaBody lam) + res <- bodyBind (lambdaBody lam) + forM res $ \(SubExpRes cs se) -> + pure $ Returns ResultMaySimplify cs se letBind pat $ Op $ segOp $ SegHist lvl space ops (lambdaReturnType lam) kbody @@ -199,7 +202,7 @@ [KernelInput] -> m (SegSpace, Stms rep) mapKernelSkeleton ispace inputs = do - read_input_bnds <- runBinder_ $ mapM readKernelInput inputs + read_input_bnds <- runBuilder_ $ mapM readKernelInput inputs space <- mkSegSpace ispace return (space, read_input_bnds) @@ -212,7 +215,7 @@ [Type] -> KernelBody rep -> m (SegOp (SegOpLevel rep) rep, Stms rep) -mapKernel mk_lvl ispace inputs rts (KernelBody () kstms krets) = runBinderT' $ do +mapKernel mk_lvl ispace inputs rts (KernelBody () kstms krets) = runBuilderT' $ do (space, read_input_stms) <- mapKernelSkeleton ispace inputs let kbody' = KernelBody () (read_input_stms <> kstms) krets @@ -237,16 +240,16 @@ deriving (Show) readKernelInput :: - (DistRep (Rep m), MonadBinder m) => + (DistRep (Rep m), MonadBuilder m) => KernelInput -> m () readKernelInput inp = do let pe = PatElem (kernelInputName inp) $ kernelInputType inp - letBind (Pattern [] [pe]) . BasicOp $ + letBind (Pat [pe]) . BasicOp $ case kernelInputType inp of Acc {} -> SubExp $ Var $ kernelInputArray inp _ -> - Index (kernelInputArray inp) $ + Index (kernelInputArray inp) . Slice $ map DimFix (kernelInputIndices inp) ++ map sliceDim (arrayDims (kernelInputType inp)) 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 @@ -65,7 +65,7 @@ scopeForSOACs :: SameScope rep SOACS => Scope rep -> Scope SOACS scopeForSOACs = castScope -data MapLoop = MapLoop SOACS.Pattern (StmAux ()) SubExp SOACS.Lambda [VName] +data MapLoop = MapLoop SOACS.Pat (StmAux ()) SubExp SOACS.Lambda [VName] mapLoopStm :: MapLoop -> Stm SOACS mapLoopStm (MapLoop pat aux w lam arrs) = @@ -79,8 +79,8 @@ MapLoop -> DistAcc rep -> DistNestT rep m (DistAcc rep), - distOnSOACSStms :: Stm SOACS -> Binder rep (Stms rep), - distOnSOACSLambda :: Lambda SOACS -> Binder rep (Lambda rep), + distOnSOACSStms :: Stm SOACS -> Builder rep (Stms rep), + distOnSOACSLambda :: Lambda SOACS -> Builder rep (Lambda rep), distSegLevel :: MkSegLevel rep m } @@ -110,7 +110,7 @@ mempty = PostStms mempty typeEnvFromDistAcc :: DistRep rep => DistAcc rep -> Scope rep -typeEnvFromDistAcc = scopeOfPattern . fst . outerTarget . distTargets +typeEnvFromDistAcc = scopeOfPat . fst . outerTarget . distTargets addStmsToAcc :: Stms rep -> DistAcc rep -> DistAcc rep addStmsToAcc stms acc = @@ -123,7 +123,7 @@ DistNestT rep m (DistAcc rep) addStmToAcc stm acc = do onSoacs <- asks distOnSOACSStms - (stm', _) <- runBinder $ onSoacs stm + (stm', _) <- runBuilder $ onSoacs stm return acc {distStms = stm' <> distStms acc} soacsLambda :: @@ -132,7 +132,7 @@ DistNestT rep m (Lambda rep) soacsLambda lam = do onLambda <- asks distOnSOACSLambda - fst <$> runBinder (onLambda lam) + fst <$> runBuilder (onLambda lam) newtype DistNestT rep m a = DistNestT (ReaderT (DistEnv rep m) (WriterT (DistRes rep) m) a) @@ -178,9 +178,8 @@ -- There may be a few final targets remaining - these correspond to -- arrays that are identity mapped, and must have statements -- inserted here. - return $ - unPostStms (accPostStms res) - <> identityStms (outerTarget $ distTargets acc) + pure $ + unPostStms (accPostStms res) <> identityStms (outerTarget $ distTargets acc) where outermost = nestingLoop $ case distNest env of @@ -191,14 +190,13 @@ loopNestingParamsAndArrs outermost identityStms (rem_pat, res) = - stmsFromList $ zipWith identityStm (patternValueElements rem_pat) res - identityStm pe (Var v) + stmsFromList $ zipWith identityStm (patElems rem_pat) res + identityStm pe (SubExpRes cs (Var v)) | Just arr <- lookup v params_to_arrs = - Let (Pattern [] [pe]) (defAux ()) $ BasicOp $ Copy arr - identityStm pe se = - Let (Pattern [] [pe]) (defAux ()) $ - BasicOp $ - Replicate (Shape [loopNestingWidth outermost]) se + certify cs $ Let (Pat [pe]) (defAux ()) $ BasicOp $ Copy arr + identityStm pe (SubExpRes cs se) = + certify cs . Let (Pat [pe]) (defAux ()) . BasicOp $ + Replicate (Shape [loopNestingWidth outermost]) se addPostStms :: Monad m => PostStms rep -> DistNestT rep m () addPostStms ks = tell $ mempty {accPostStms = ks} @@ -220,7 +218,7 @@ distNest env } where - provided = namesFromList $ patternNames $ stmPattern stm + provided = namesFromList $ patNames $ stmPat stm leavingNesting :: (MonadFreshNames m, DistRep rep) => @@ -248,10 +246,10 @@ Lambda { lambdaParams = used_params, lambdaBody = body, - lambdaReturnType = map rowType $ patternTypes pat + lambdaReturnType = map rowType $ patTypes pat } stms <- - runBinder_ . auxing aux . FOT.transformSOAC pat $ + runBuilder_ . auxing aux . FOT.transformSOAC pat $ Screma w used_arrs $ mapSOAC lam' return $ acc {distTargets = newtargets, distStms = stms} @@ -264,22 +262,20 @@ aux = loopNestingAux inner_nesting inps = loopNestingParamsAndArrs inner_nesting - remnantStm pe (Var v) + remnantStm pe (SubExpRes cs (Var v)) | Just (_, arr) <- find ((== v) . paramName . fst) inps = - Let (Pattern [] [pe]) aux $ - BasicOp $ Copy arr - remnantStm pe se = - Let (Pattern [] [pe]) aux $ - BasicOp $ Replicate (Shape [w]) se + certify cs $ Let (Pat [pe]) aux $ BasicOp $ Copy arr + remnantStm pe (SubExpRes cs se) = + certify cs $ Let (Pat [pe]) aux $ BasicOp $ Replicate (Shape [w]) se stms = - stmsFromList $ zipWith remnantStm (patternElements pat) res + stmsFromList $ zipWith remnantStm (patElems pat) res return $ acc {distTargets = newtargets, distStms = stms} mapNesting :: (MonadFreshNames m, DistRep rep) => - PatternT Type -> + PatT Type -> StmAux () -> SubExp -> Lambda SOACS -> @@ -325,8 +321,8 @@ isMap BasicOp {} = False isMap Apply {} = False isMap If {} = False - isMap (DoLoop _ _ ForLoop {} body) = bodyContainsParallelism body - isMap (DoLoop _ _ WhileLoop {} _) = False + isMap (DoLoop _ ForLoop {} body) = bodyContainsParallelism body + isMap (DoLoop _ WhileLoop {} _) = False isMap (WithAcc _ lam) = bodyContainsParallelism $ lambdaBody lam isMap Op {} = True @@ -344,7 +340,7 @@ onStms acc (Let pat (StmAux cs _ _) (Op (Stream w arrs Sequential accs lam)) : stms) = do types <- asksScope scopeForSOACs stream_stms <- - snd <$> runBinderT (sequentialStreamWholeArray pat w accs lam arrs) types + snd <$> runBuilderT (sequentialStreamWholeArray pat w accs lam arrs) types (_, stream_stms') <- runReaderT (copyPropagateInStms simpleSOACS types stream_stms) types onStms acc $ stmsToList (fmap (certify cs) stream_stms') ++ stms @@ -375,7 +371,7 @@ maybeDistributeStm (Let pat aux (Op soac)) acc | "sequential_outer" `inAttrs` stmAuxAttrs aux = distributeMapBodyStms acc . fmap (certify (stmAuxCerts aux)) - =<< runBinder_ (FOT.transformSOAC pat soac) + =<< runBuilder_ (FOT.transformSOAC pat soac) maybeDistributeStm stm@(Let pat _ (Op (Screma w arrs form))) acc | Just lam <- isMapSOAC form = -- Only distribute inside the map if we can distribute everything @@ -383,8 +379,8 @@ distributeIfPossible acc >>= \case Nothing -> addStmToAcc stm acc Just acc' -> distribute =<< onInnerMap (MapLoop pat (stmAux stm) w lam arrs) acc' -maybeDistributeStm bnd@(Let pat aux (DoLoop [] val form@ForLoop {} body)) acc - | null (patternContextElements pat), +maybeDistributeStm bnd@(Let pat aux (DoLoop merge form@ForLoop {} body)) acc + | not $ any (`nameIn` freeIn pat) $ patNames pat, bodyContainsParallelism body = distributeSingleStm acc bnd >>= \case Just (kernels, res, nest, acc') @@ -411,13 +407,13 @@ stms <- (`runReaderT` types) $ fmap snd . simplifyStms - =<< interchangeLoops nest' (SeqLoop perm pat val form body) + =<< interchangeLoops nest' (SeqLoop perm pat merge form body) onTopLevelStms stms return acc' _ -> addStmToAcc bnd acc maybeDistributeStm stm@(Let pat _ (If cond tbranch fbranch ret)) acc - | null (patternContextElements pat), + | not $ any (`nameIn` freeIn pat) $ patNames pat, bodyContainsParallelism tbranch || bodyContainsParallelism fbranch || not (all primType (ifReturns ret)) = distributeSingleStm acc stm >>= \case @@ -468,7 +464,7 @@ | Just [Reduce comm lam nes] <- isReduceSOAC form, Just m <- irwim pat w comm lam $ zip nes arrs = do types <- asksScope scopeForSOACs - (_, bnds) <- runBinderT (auxing aux m) types + (_, bnds) <- runBuilderT (auxing aux m) types distributeMapBodyStms acc bnds -- Parallelise segmented scatters. @@ -500,23 +496,17 @@ -- Parallelise Index slices if the result is going to be returned -- directly from the kernel. This is because we would otherwise have -- to sequentialise writing the result, which may be costly. -maybeDistributeStm - stm@( Let - (Pattern [] [pe]) - aux - (BasicOp (Index arr slice)) - ) - acc - | not $ null $ sliceDims slice, - Var (patElemName pe) `elem` snd (innerTarget (distTargets acc)) = - distributeSingleStm acc stm >>= \case - Just (kernels, _res, nest, acc') -> - localScope (typeEnvFromDistAcc acc') $ do - addPostStms kernels - postStm =<< segmentedGatherKernel nest (stmAuxCerts aux) arr slice - return acc' - _ -> - addStmToAcc stm acc +maybeDistributeStm stm@(Let (Pat [pe]) aux (BasicOp (Index arr slice))) acc + | not $ null $ sliceDims slice, + Var (patElemName pe) `elem` map resSubExp (snd (innerTarget (distTargets acc))) = + distributeSingleStm acc stm >>= \case + Just (kernels, _res, nest, acc') -> + localScope (typeEnvFromDistAcc acc') $ do + addPostStms kernels + postStm =<< segmentedGatherKernel nest (stmAuxCerts aux) arr slice + return acc' + _ -> + addStmToAcc stm acc -- If the scan can be distributed by itself, we will turn it into a -- segmented scan. -- @@ -571,20 +561,19 @@ -- anything, so split it up and try again. scope <- asksScope scopeForSOACs distributeMapBodyStms acc . fmap (certify cs) . snd - =<< runBinderT (dissectScrema pat w form arrs) scope + =<< runBuilderT (dissectScrema pat w form arrs) scope maybeDistributeStm (Let pat aux (BasicOp (Replicate (Shape (d : ds)) v))) acc - | [t] <- patternTypes pat = do + | [t] <- patTypes pat = do tmp <- newVName "tmp" let rowt = rowType t newbnd = Let pat aux $ Op $ Screma d [] $ mapSOAC lam tmpbnd = - Let (Pattern [] [PatElem tmp rowt]) aux $ - BasicOp $ Replicate (Shape ds) v + Let (Pat [PatElem tmp rowt]) aux $ BasicOp $ Replicate (Shape ds) v lam = Lambda { lambdaReturnType = [rowt], lambdaParams = [], - lambdaBody = mkBody (oneStm tmpbnd) [Var tmp] + lambdaBody = mkBody (oneStm tmpbnd) [varRes tmp] } maybeDistributeStm newbnd acc maybeDistributeStm stm@(Let _ aux (BasicOp (Copy stm_arr))) acc = @@ -592,7 +581,7 @@ return $ oneStm $ Let outerpat aux $ BasicOp $ Copy arr -- Opaques are applied to the full array, because otherwise they can -- drastically inhibit parallelisation in some cases. -maybeDistributeStm stm@(Let (Pattern [] [pe]) aux (BasicOp (Opaque (Var stm_arr)))) acc +maybeDistributeStm stm@(Let (Pat [pe]) aux (BasicOp (Opaque _ (Var stm_arr)))) acc | not $ primType $ typeOf pe = distributeSingleUnaryStm acc stm stm_arr $ \_ outerpat arr -> return $ oneStm $ Let outerpat aux $ BasicOp $ Copy arr @@ -606,7 +595,7 @@ arr_t <- lookupType arr return $ stmsFromList - [ Let (Pattern [] [PatElem arr' arr_t]) aux $ BasicOp $ Copy arr, + [ Let (Pat [PatElem arr' arr_t]) aux $ BasicOp $ Copy arr, Let outerpat aux $ BasicOp $ Rearrange perm' arr' ] maybeDistributeStm stm@(Let _ aux (BasicOp (Reshape reshape stm_arr))) acc = @@ -619,11 +608,11 @@ distributeSingleUnaryStm acc stm stm_arr $ \nest outerpat arr -> do let rots' = map (const $ intConst Int64 0) (kernelNestWidths nest) ++ rots return $ oneStm $ Let outerpat aux $ BasicOp $ Rotate rots' arr -maybeDistributeStm stm@(Let pat aux (BasicOp (Update arr slice (Var v)))) acc +maybeDistributeStm stm@(Let pat aux (BasicOp (Update _ arr slice (Var v)))) acc | not $ null $ sliceDims slice = distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') - | res == map Var (patternNames $ stmPattern stm), + | map resSubExp res == map Var (patNames $ stmPat stm), Just (perm, pat_unused) <- permutationAndMissing pat res -> do addPostStms kernels localScope (typeEnvFromDistAcc acc') $ do @@ -654,19 +643,19 @@ DistAcc rep -> Stm SOACS -> VName -> - (KernelNest -> PatternT Type -> VName -> DistNestT rep m (Stms rep)) -> + (KernelNest -> PatT Type -> VName -> DistNestT rep m (Stms rep)) -> DistNestT rep m (DistAcc rep) distributeSingleUnaryStm acc stm stm_arr f = distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') - | res == map Var (patternNames $ stmPattern stm), + | map resSubExp res == map Var (patNames $ stmPat stm), (outer, _) <- nest, [(arr_p, arr)] <- loopNestingParamsAndArrs outer, boundInKernelNest nest `namesIntersection` freeIn stm == oneName (paramName arr_p), perfectlyMapped arr nest -> do addPostStms kernels - let outerpat = loopNestingPattern $ fst nest + let outerpat = loopNestingPat $ fst nest localScope (typeEnvFromDistAcc acc') $ do postStm =<< f nest outerpat arr return acc' @@ -694,7 +683,7 @@ mkSegLevel = do mk_lvl <- asks distSegLevel return $ \w desc r -> do - (lvl, stms) <- lift $ liftInner $ runBinderT' $ mk_lvl w desc r + (lvl, stms) <- lift $ liftInner $ runBuilderT' $ mk_lvl w desc r addStms stms return lvl @@ -754,8 +743,8 @@ (MonadFreshNames m, LocalScope rep m, DistRep rep) => KernelNest -> [Int] -> - PatternT Type -> - Certificates -> + PatT Type -> + Certs -> SubExp -> Lambda rep -> [VName] -> @@ -791,13 +780,9 @@ drop (sum indexes) $ lambdaReturnType lam (is, vs) = splitAt (sum indexes) $ bodyResult $ lambdaBody lam - -- Maybe add certificates to the indices. - (is', k_body_stms) <- runBinder $ do + (is', k_body_stms) <- runBuilder $ do addStms $ bodyStms $ lambdaBody lam - forM is $ \i -> - if cs == mempty - then return i - else certifying cs $ letSubExp "scatter_i" $ BasicOp $ SubExp i + pure is let k_body = groupScatterResults (zip3 as_ws as_ns as_inps) (is' ++ vs) @@ -810,13 +795,12 @@ (k, k_bnds) <- mapKernel mk_lvl ispace kernel_inps' rts k_body - traverse renameStm <=< runBinder_ $ do + traverse renameStm <=< runBuilder_ $ do addStms k_bnds let pat = - Pattern [] $ - rearrangeShape perm $ - patternValueElements $ loopNestingPattern $ fst nest + Pat . rearrangeShape perm $ + patElems $ loopNestingPat $ fst nest letBind pat $ Op $ segOp k where @@ -826,9 +810,14 @@ inPlaceReturn ispace (aw, inp, is_vs) = WriteReturns + ( foldMap (foldMap resCerts . fst) is_vs + <> foldMap (resCerts . snd) is_vs + ) (Shape (init ws ++ shapeDims aw)) (kernelInputArray inp) - [(map DimFix $ map Var (init gtids) ++ is, v) | (is, v) <- is_vs] + [ (Slice $ map DimFix $ map Var (init gtids) ++ map resSubExp is, resSubExp v) + | (is, v) <- is_vs + ] where (gtids, ws) = unzip ispace @@ -836,7 +825,7 @@ (MonadFreshNames m, LocalScope rep m, DistRep rep) => KernelNest -> [Int] -> - Certificates -> + Certs -> VName -> Slice SubExp -> VName -> @@ -848,14 +837,14 @@ let ispace = base_ispace ++ zip slice_gtids slice_dims - ((res_t, res), kstms) <- runBinder $ do + ((res_t, res), kstms) <- runBuilder $ do -- Compute indexes into full array. v' <- certifying cs $ - letSubExp "v" $ BasicOp $ Index v $ map (DimFix . Var) slice_gtids + letSubExp "v" $ BasicOp $ Index v $ Slice $ map (DimFix . Var) slice_gtids slice_is <- traverse (toSubExp "index") $ - fixSlice (map (fmap pe64) slice) $ map (pe64 . Var) slice_gtids + fixSlice (fmap pe64 slice) $ map (pe64 . Var) slice_gtids let write_is = map (Var . fst) base_ispace ++ slice_is arr' = @@ -865,33 +854,32 @@ v_t <- subExpType v' return ( v_t, - WriteReturns (arrayShape arr_t) arr' [(map DimFix write_is, v')] + WriteReturns mempty (arrayShape arr_t) arr' [(Slice $ map DimFix write_is, v')] ) -- Remove unused kernel inputs, since some of these might -- reference the array we are scattering into. let kernel_inps' = - filter ((`nameIn` freeIn kstms) . kernelInputName) kernel_inps + filter ((`nameIn` (freeIn kstms <> freeIn res)) . kernelInputName) kernel_inps mk_lvl <- mkSegLevel (k, prestms) <- mapKernel mk_lvl ispace kernel_inps' [res_t] $ KernelBody () kstms [res] - traverse renameStm <=< runBinder_ $ do + traverse renameStm <=< runBuilder_ $ do addStms prestms let pat = - Pattern [] $ - rearrangeShape perm $ - patternValueElements $ loopNestingPattern $ fst nest + Pat . rearrangeShape perm $ + patElems $ loopNestingPat $ fst nest letBind pat $ Op $ segOp k segmentedGatherKernel :: (MonadFreshNames m, LocalScope rep m, DistRep rep) => KernelNest -> - Certificates -> + Certs -> VName -> Slice SubExp -> DistNestT rep m (Stms rep) @@ -902,25 +890,24 @@ (base_ispace, kernel_inps) <- flatKernel nest let ispace = base_ispace ++ zip slice_gtids slice_dims - ((res_t, res), kstms) <- runBinder $ do + ((res_t, res), kstms) <- runBuilder $ do -- Compute indexes into full array. slice'' <- - subExpSlice $ - sliceSlice (primExpSlice slice) $ - primExpSlice $ map (DimFix . Var) slice_gtids + subExpSlice . sliceSlice (primExpSlice slice) $ + primExpSlice $ Slice $ map (DimFix . Var) slice_gtids v' <- certifying cs $ letSubExp "v" $ BasicOp $ Index arr slice'' v_t <- subExpType v' - return (v_t, Returns ResultMaySimplify v') + return (v_t, Returns ResultMaySimplify mempty v') mk_lvl <- mkSegLevel (k, prestms) <- mapKernel mk_lvl ispace kernel_inps [res_t] $ KernelBody () kstms [res] - traverse renameStm <=< runBinder_ $ do + traverse renameStm <=< runBuilder_ $ do addStms prestms - let pat = Pattern [] $ patternValueElements $ loopNestingPattern $ fst nest + let pat = Pat $ patElems $ loopNestingPat $ fst nest letBind pat $ Op $ segOp k @@ -928,7 +915,7 @@ (MonadFreshNames m, LocalScope rep m, DistRep rep) => KernelNest -> [Int] -> - Certificates -> + Certs -> SubExp -> [SOACS.HistOp SOACS] -> Lambda rep -> @@ -940,9 +927,8 @@ -- scan. (ispace, inputs) <- flatKernel nest let orig_pat = - Pattern [] $ - rearrangeShape perm $ - patternValueElements $ loopNestingPattern $ fst nest + Pat . rearrangeShape perm $ + patElems $ loopNestingPat $ fst nest -- The input/output arrays _must_ correspond to some kernel input, -- or else the original nested Hist would have been ill-typed. @@ -955,9 +941,9 @@ mk_lvl <- asks distSegLevel onLambda <- asks distOnSOACSLambda - let onLambda' = fmap fst . runBinder . onLambda + let onLambda' = fmap fst . runBuilder . onLambda liftInner $ - runBinderT'_ $ do + runBuilderT'_ $ do -- It is important not to launch unnecessarily many threads for -- histograms, because it may mean we unnecessarily need to reduce -- subhistograms as well. @@ -970,19 +956,19 @@ bad = error "Ill-typed nested Hist encountered." histKernel :: - (MonadBinder m, DistRep (Rep m)) => + (MonadBuilder m, DistRep (Rep m)) => (Lambda SOACS -> m (Lambda (Rep m))) -> SegOpLevel (Rep m) -> - PatternT Type -> + PatT Type -> [(VName, SubExp)] -> [KernelInput] -> - Certificates -> + Certs -> SubExp -> [SOACS.HistOp SOACS] -> Lambda (Rep m) -> [VName] -> m (Stms (Rep m)) -histKernel onLambda lvl orig_pat ispace inputs cs hist_w ops lam arrs = runBinderT'_ $ do +histKernel onLambda lvl orig_pat ispace inputs cs hist_w ops lam arrs = runBuilderT'_ $ do ops' <- forM ops $ \(SOACS.HistOp num_bins rf dests nes op) -> do (op', nes', shape) <- determineReduceOp op nes op'' <- lift $ onLambda op' @@ -996,7 +982,7 @@ =<< segHist lvl orig_pat hist_w ispace inputs' ops' lam arrs determineReduceOp :: - MonadBinder m => + MonadBuilder m => Lambda SOACS -> [SubExp] -> m (Lambda SOACS, [SubExp], Shape) @@ -1019,9 +1005,9 @@ isVectorMap :: Lambda SOACS -> (Shape, Lambda SOACS) isVectorMap lam - | [Let (Pattern [] pes) _ (Op (Screma w arrs form))] <- + | [Let (Pat pes) _ (Op (Screma w arrs form))] <- stmsToList $ bodyStms $ lambdaBody lam, - bodyResult (lambdaBody lam) == map (Var . patElemName) pes, + map resSubExp (bodyResult (lambdaBody lam)) == map (Var . patElemName) pes, Just map_lam <- isMapSOAC form, arrs == map paramName (lambdaParams lam) = let (shape, lam') = isVectorMap map_lam @@ -1075,12 +1061,12 @@ Names -> [SubExp] -> [VName] -> - ( PatternT Type -> + ( PatT Type -> [(VName, SubExp)] -> [KernelInput] -> [SubExp] -> [VName] -> - BinderT rep m () + BuilderT rep m () ) -> DistNestT rep m (Maybe (Stms rep)) isSegmentedOp nest perm free_in_op _free_in_fold_op nes arrs m = runMaybeT $ do @@ -1129,22 +1115,21 @@ lift $ liftInner $ - runBinderT'_ $ do + runBuilderT'_ $ do nested_arrs <- sequence mk_arrs let pat = - Pattern [] $ - rearrangeShape perm $ - patternValueElements $ loopNestingPattern $ fst nest + Pat . rearrangeShape perm $ + patElems $ loopNestingPat $ fst nest m pat ispace kernel_inps nes' nested_arrs -permutationAndMissing :: PatternT Type -> [SubExp] -> Maybe ([Int], [PatElemT Type]) -permutationAndMissing pat res = do - let pes = patternValueElements pat - (_used, unused) = +permutationAndMissing :: PatT Type -> Result -> Maybe ([Int], [PatElemT Type]) +permutationAndMissing (Pat pes) res = do + let (_used, unused) = partition ((`nameIn` freeIn res) . patElemName) pes - res_expanded = res ++ map (Var . patElemName) unused + res' = map resSubExp res + res_expanded = res' ++ map (Var . patElemName) unused perm <- map (Var . patElemName) pes `isPermutationOf` res_expanded return (perm, unused) @@ -1167,9 +1152,8 @@ pes' <- mapM (expandPatElemWith dims) pes return nest - { loopNestingPattern = - Pattern [] $ - patternElements (loopNestingPattern nest) <> pes' + { loopNestingPat = + Pat $ patElems (loopNestingPat nest) <> pes' } expandPatElemWith dims pe = do @@ -1182,7 +1166,7 @@ kernelOrNot :: (MonadFreshNames m, DistRep rep) => - Certificates -> + Certs -> Stm SOACS -> DistAcc rep -> PostStms rep -> 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 @@ -45,6 +45,7 @@ import Control.Monad.RWS.Strict import Control.Monad.Trans.Maybe +import Data.Bifunctor (second) import Data.Foldable import Data.List (elemIndex, sortOn) import qualified Data.Map.Strict as M @@ -64,7 +65,7 @@ import Futhark.Util import Futhark.Util.Log -type Target = (PatternT Type, Result) +type Target = (PatT Type, Result) -- | First pair element is the very innermost ("current") target. In -- the list, the outermost target comes first. Invariant: Every @@ -101,8 +102,8 @@ pushInnerTarget (pat, res) (Targets inner_target targets) = Targets (pat', res') (targets ++ [inner_target]) where - (pes', res') = unzip $ filter (used . fst) $ zip (patternElements pat) res - pat' = Pattern [] pes' + (pes', res') = unzip $ filter (used . fst) $ zip (patElems pat) res + pat' = Pat pes' inner_used = freeIn $ snd inner_target used pe = patElemName pe `nameIn` inner_used @@ -113,13 +114,13 @@ [] -> Nothing targetScope :: DistRep rep => Target -> Scope rep -targetScope = scopeOfPattern . fst +targetScope = scopeOfPat . fst targetsScope :: DistRep rep => Targets -> Scope rep targetsScope (Targets t ts) = mconcat $ map targetScope $ t : ts data LoopNesting = MapNesting - { loopNestingPattern :: PatternT Type, + { loopNestingPat :: PatT Type, loopNestingAux :: StmAux (), loopNestingWidth :: SubExp, loopNestingParamsAndArrs :: [(Param Type, VName)] @@ -202,7 +203,7 @@ -- list, also taking care to swap patterns if necessary. pushKernelNesting :: Target -> LoopNesting -> KernelNest -> KernelNest pushKernelNesting target newnest (nest, nests) = - ( fixNestingPatternOrder newnest target (loopNestingPattern nest), + ( fixNestingPatOrder newnest target (loopNestingPat nest), nest : nests ) @@ -211,20 +212,20 @@ -- (non-permuted compared to what is expected by the outer nests). pushInnerKernelNesting :: Target -> LoopNesting -> KernelNest -> KernelNest pushInnerKernelNesting target newnest (nest, nests) = - (nest, nests ++ [fixNestingPatternOrder newnest target (loopNestingPattern innermost)]) + (nest, nests ++ [fixNestingPatOrder newnest target (loopNestingPat innermost)]) where innermost = case reverse nests of [] -> nest n : _ -> n -fixNestingPatternOrder :: LoopNesting -> Target -> PatternT Type -> LoopNesting -fixNestingPatternOrder nest (_, res) inner_pat = - nest {loopNestingPattern = basicPattern [] pat'} +fixNestingPatOrder :: LoopNesting -> Target -> PatT Type -> LoopNesting +fixNestingPatOrder nest (_, res) inner_pat = + nest {loopNestingPat = basicPat pat'} where - pat = loopNestingPattern nest + pat = loopNestingPat nest pat' = map fst fixed_target - fixed_target = sortOn posInInnerPat $ zip (patternValueIdents pat) res - posInInnerPat (_, Var v) = fromMaybe 0 $ elemIndex v $ patternNames inner_pat + fixed_target = sortOn posInInnerPat $ zip (patIdents pat) res + posInInnerPat (_, SubExpRes _ (Var v)) = fromMaybe 0 $ elemIndex v $ patNames inner_pat posInInnerPat _ = 0 newKernel :: LoopNesting -> KernelNest @@ -254,18 +255,19 @@ KernelNest -> Body rep -> m (Stm rep, Stms rep) -constructKernel mk_lvl kernel_nest inner_body = runBinderT' $ do +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 - pat = loopNestingPattern first_nest - rts = map (stripArray (length ispace)) $ patternTypes pat + pat = loopNestingPat first_nest + rts = map (stripArray (length ispace)) $ patTypes pat inner_body' <- fmap (uncurry (flip (KernelBody ()))) $ - runBinder $ + runBuilder $ localScope ispace_scope $ do mapM_ readKernelInput $ filter inputIsUsed inps - map (Returns ResultMaySimplify) <$> bodyBind inner_body + res <- bodyBind inner_body + forM res $ \(SubExpRes cs se) -> pure $ Returns ResultMaySimplify cs se (segop, aux_stms) <- lift $ mapKernel mk_lvl ispace [] rts inner_body' @@ -327,8 +329,8 @@ distributionExpandTarget :: Target -> Target } -distributionInnerPattern :: DistributionBody -> PatternT Type -distributionInnerPattern = fst . innerTarget . distributionTarget +distributionInnerPat :: DistributionBody -> PatT Type +distributionInnerPat = fst . innerTarget . distributionTarget distributionBodyFromStms :: ASTRep rep => @@ -382,7 +384,7 @@ distributeAtNesting :: Nesting -> - PatternT Type -> + PatT Type -> (LoopNesting -> KernelNest, Names) -> M.Map VName Ident -> [Ident] -> @@ -431,9 +433,7 @@ ) let free_arrs_pat = - basicPattern [] $ - map snd $ - filter fst $ zip bind_in_target free_arrs + basicPat $ map snd $ filter fst $ zip bind_in_target free_arrs free_params_pat = map snd $ filter fst $ zip bind_in_target free_params @@ -459,7 +459,7 @@ return ( add_to_kernel nest'', free_in_kernel'', - addTarget (free_arrs_pat, map (Var . paramName) free_params_pat) + addTarget (free_arrs_pat, varsRes $ map paramName free_params_pat) ) recurse :: @@ -468,7 +468,7 @@ recurse [] = distributeAtNesting inner_nest - (distributionInnerPattern distrib_body) + (distributionInnerPat distrib_body) ( newKernel, distributionFreeInBody distrib_body `namesIntersection` bound_in_nest ) @@ -480,7 +480,7 @@ let (pat', res', identity_map, expand_target) = removeIdentityMappingFromNesting - (namesFromList $ patternNames $ loopNestingPattern outer) + (namesFromList $ patNames $ loopNestingPat outer) pat res @@ -491,7 +491,7 @@ kernel_free ) identity_map - (patternIdents $ fst $ outerTarget kernel_targets) + (patIdents $ fst $ outerTarget kernel_targets) ((`pushOuterTarget` kernel_targets) . expand_target) removeUnusedNestingParts :: Names -> LoopNesting -> LoopNesting @@ -506,41 +506,39 @@ removeIdentityMappingGeneral :: Names -> - PatternT Type -> + PatT Type -> Result -> - ( PatternT Type, + ( PatT Type, Result, M.Map VName Ident, Target -> Target ) removeIdentityMappingGeneral bound pat res = let (identities, not_identities) = - mapEither isIdentity $ zip (patternElements pat) res + mapEither isIdentity $ zip (patElems pat) res (not_identity_patElems, not_identity_res) = unzip not_identities (identity_patElems, identity_res) = unzip identities expandTarget (tpat, tres) = - ( Pattern [] $ patternElements tpat ++ identity_patElems, - tres ++ map Var identity_res + ( Pat $ patElems tpat ++ identity_patElems, + tres ++ map (uncurry SubExpRes . second Var) identity_res ) identity_map = - M.fromList $ - zip identity_res $ - map patElemIdent identity_patElems - in ( Pattern [] not_identity_patElems, + M.fromList $ zip (map snd identity_res) $ map patElemIdent identity_patElems + in ( Pat not_identity_patElems, not_identity_res, identity_map, expandTarget ) where - isIdentity (patElem, Var v) - | not (v `nameIn` bound) = Left (patElem, v) + isIdentity (patElem, SubExpRes cs (Var v)) + | not (v `nameIn` bound) = Left (patElem, (cs, v)) isIdentity x = Right x removeIdentityMappingFromNesting :: Names -> - PatternT Type -> + PatT Type -> Result -> - ( PatternT Type, + ( PatT Type, Result, M.Map VName Ident, Target -> Target 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 @@ -18,8 +18,8 @@ -- | Interchange Scan With Inner Map. Tries to turn a @scan(map)@ into a -- @map(scan) iswim :: - (MonadBinder m, Rep m ~ SOACS) => - Pattern -> + (MonadBuilder m, Rep m ~ SOACS) => + Pat -> SubExp -> Lambda -> [(SubExp, VName)] -> @@ -51,38 +51,33 @@ let map_body = mkBody ( oneStm $ - Let (setPatternOuterDimTo w map_pat) (defAux ()) $ + Let (setPatOuterDimTo w map_pat) (defAux ()) $ Op $ Screma w scan_arrs scan_soac ) - $ map Var $ patternNames map_pat + $ varsRes $ patNames map_pat map_fun' = Lambda map_params map_body map_rettype res_pat' <- - fmap (basicPattern []) $ + fmap basicPat $ mapM (newIdent' (<> "_transposed") . transposeIdentType) $ - patternValueIdents res_pat + patIdents res_pat addStm $ Let res_pat' (StmAux map_cs mempty ()) $ Op $ Screma map_w map_arrs' (mapSOAC map_fun') - forM_ - ( zip - (patternValueIdents res_pat) - (patternValueIdents res_pat') - ) - $ \(to, from) -> do - let perm = [1, 0] ++ [2 .. arrayRank (identType from) -1] - addStm $ - Let (basicPattern [] [to]) (defAux ()) $ - BasicOp $ Rearrange perm $ identName from + forM_ (zip (patIdents res_pat) (patIdents res_pat')) $ \(to, from) -> do + let perm = [1, 0] ++ [2 .. arrayRank (identType from) -1] + addStm $ + Let (basicPat [to]) (defAux ()) $ + BasicOp $ Rearrange perm $ identName from | otherwise = Nothing -- | Interchange Reduce With Inner Map. Tries to turn a @reduce(map)@ into a -- @map(reduce) irwim :: - (MonadBinder m, Rep m ~ SOACS) => - Pattern -> + (MonadBuilder m, Rep m ~ SOACS) => + Pat -> SubExp -> Commutativity -> Lambda -> @@ -114,7 +109,7 @@ red_rettype = lambdaReturnType map_fun red_fun' = Lambda red_params red_body red_rettype red_input' = zip accs' $ map paramName map_params - red_pat = stripPatternOuterDim map_pat + red_pat = stripPatOuterDim map_pat map_body <- case irwim red_pat w comm red_fun' red_input' of @@ -126,10 +121,10 @@ Let red_pat (defAux ()) $ Op $ Screma w (map snd red_input') reduce_soac ) - $ map Var $ patternNames map_pat + $ varsRes $ patNames map_pat Just m -> localScope (scopeOfLParams map_params) $ do map_body_bnds <- collectStms_ m - return $ mkBody map_body_bnds $ map Var $ patternNames map_pat + return $ mkBody map_body_bnds $ varsRes $ patNames map_pat let map_fun' = Lambda map_params map_body map_rettype @@ -142,12 +137,12 @@ -- does that map look like? rwimPossible :: Lambda -> - Maybe (Pattern, Certificates, SubExp, Lambda) + Maybe (Pat, Certs, SubExp, Lambda) rwimPossible fun | Body _ stms res <- lambdaBody fun, [bnd] <- stmsToList stms, -- Body has a single binding - map_pat <- stmPattern bnd, - map Var (patternNames map_pat) == res, -- Returned verbatim + map_pat <- stmPat bnd, + map Var (patNames map_pat) == map resSubExp res, -- Returned verbatim Op (Screma map_w map_arrs form) <- stmExp bnd, Just map_fun <- isMapSOAC form, map paramName (lambdaParams fun) == map_arrs = @@ -155,7 +150,7 @@ | otherwise = Nothing -transposedArrays :: MonadBinder 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] @@ -180,9 +175,9 @@ setOuterDimTo w t = arrayOfRow (rowType t) w -setPatternOuterDimTo :: SubExp -> Pattern -> Pattern -setPatternOuterDimTo w pat = - basicPattern [] $ map (setIdentOuterDimTo w) $ patternValueIdents pat +setPatOuterDimTo :: SubExp -> Pat -> Pat +setPatOuterDimTo w pat = + basicPat $ map (setIdentOuterDimTo w) $ patIdents pat transposeIdentType :: Ident -> Ident transposeIdentType ident = @@ -192,6 +187,6 @@ stripIdentOuterDim ident = ident {identType = rowType $ identType ident} -stripPatternOuterDim :: Pattern -> Pattern -stripPatternOuterDim pat = - basicPattern [] $ map stripIdentOuterDim $ patternValueIdents pat +stripPatOuterDim :: Pat -> Pat +stripPatOuterDim pat = + basicPat $ map stripIdentOuterDim $ patIdents pat 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 @@ -33,14 +33,14 @@ -- | An encoding of a sequential do-loop with no existential context, -- alongside its result pattern. -data SeqLoop = SeqLoop [Int] Pattern [(FParam, SubExp)] (LoopForm SOACS) Body +data SeqLoop = SeqLoop [Int] Pat [(FParam, SubExp)] (LoopForm SOACS) Body seqLoopStm :: SeqLoop -> Stm seqLoopStm (SeqLoop _ pat merge form body) = - Let pat (defAux ()) $ DoLoop [] merge form body + Let pat (defAux ()) $ DoLoop merge form body interchangeLoop :: - (MonadBinder m, LocalScope SOACS m) => + (MonadBuilder m, LocalScope SOACS m) => (VName -> Maybe VName) -> SeqLoop -> LoopNesting -> @@ -54,13 +54,11 @@ mapM expand merge let loop_pat_expanded = - Pattern [] $ map expandPatElem $ patternElements loop_pat + Pat $ map expandPatElem $ patElems loop_pat new_params = - [ Param pname $ fromDecl ptype - | (Param pname ptype, _) <- merge - ] + [Param pname $ fromDecl ptype | (Param pname ptype, _) <- merge] new_arrs = map (paramName . fst) merge_expanded - rettype = map rowType $ patternTypes loop_pat_expanded + rettype = map rowType $ patTypes loop_pat_expanded -- If the map consumes something that is bound outside the loop -- (i.e. is not a merge parameter), we have to copy() it. As a @@ -68,7 +66,7 @@ -- it is not used anymore. This might happen if the parameter was -- used just as the inital value of a merge parameter. ((params', arrs'), pre_copy_bnds) <- - runBinder $ + runBuilder $ localScope (scopeOfLParams new_params) $ unzip . catMaybes <$> mapM copyOrRemoveParam params_and_arrs @@ -76,8 +74,8 @@ map_bnd = Let loop_pat_expanded aux $ Op $ Screma w (arrs' <> new_arrs) (mapSOAC lam) - res = map Var $ patternNames loop_pat_expanded - pat' = Pattern [] $ rearrangeShape perm $ patternValueElements pat + res = varsRes $ patNames loop_pat_expanded + pat' = Pat $ rearrangeShape perm $ patElems pat return $ SeqLoop perm pat' merge_expanded form $ @@ -122,7 +120,7 @@ m (Stms SOACS) interchangeLoops nest loop = do (loop', bnds) <- - runBinder $ + runBuilder $ foldM (interchangeLoop isMapParameter) loop $ reverse $ kernelNestLoops nest return $ bnds <> oneStm (seqLoopStm loop') @@ -132,14 +130,14 @@ find ((== v) . paramName . fst) $ concatMap loopNestingParamsAndArrs $ kernelNestLoops nest -data Branch = Branch [Int] Pattern SubExp Body Body (IfDec (BranchType SOACS)) +data Branch = Branch [Int] Pat SubExp Body Body (IfDec (BranchType SOACS)) branchStm :: Branch -> Stm branchStm (Branch _ pat cond tbranch fbranch ret) = Let pat (defAux ()) $ If cond tbranch fbranch ret interchangeBranch1 :: - (MonadBinder m) => + (MonadBuilder m) => Branch -> LoopNesting -> m Branch @@ -147,24 +145,24 @@ (Branch perm branch_pat cond tbranch fbranch (IfDec ret if_sort)) (MapNesting pat aux w params_and_arrs) = do let ret' = map (`arrayOfRow` Free w) ret - pat' = Pattern [] $ rearrangeShape perm $ patternValueElements pat + pat' = Pat $ rearrangeShape perm $ patElems pat (params, arrs) = unzip params_and_arrs - lam_ret = rearrangeShape perm $ map rowType $ patternTypes pat + lam_ret = rearrangeShape perm $ map rowType $ patTypes pat branch_pat' = - Pattern [] $ map (fmap (`arrayOfRow` w)) $ patternElements branch_pat + Pat $ map (fmap (`arrayOfRow` w)) $ patElems branch_pat mkBranch branch = (renameBody =<<) $ do let lam = Lambda params branch lam_ret - res = map Var $ patternNames branch_pat' + res = varsRes $ patNames branch_pat' map_bnd = Let branch_pat' aux $ Op $ Screma w arrs $ mapSOAC lam return $ mkBody (oneStm map_bnd) res tbranch' <- mkBranch tbranch fbranch' <- mkBranch fbranch return $ - Branch [0 .. patternSize pat -1] pat' cond tbranch' fbranch' $ + Branch [0 .. patSize pat -1] pat' cond tbranch' fbranch' $ IfDec ret' if_sort interchangeBranch :: @@ -174,18 +172,18 @@ m (Stms SOACS) interchangeBranch nest loop = do (loop', bnds) <- - runBinder $ foldM interchangeBranch1 loop $ reverse $ kernelNestLoops nest + runBuilder $ foldM interchangeBranch1 loop $ reverse $ kernelNestLoops nest return $ bnds <> oneStm (branchStm loop') data WithAccStm - = WithAccStm [Int] Pattern [(Shape, [VName], Maybe (Lambda, [SubExp]))] Lambda + = WithAccStm [Int] Pat [(Shape, [VName], Maybe (Lambda, [SubExp]))] Lambda withAccStm :: WithAccStm -> Stm withAccStm (WithAccStm _ pat inputs lam) = Let pat (defAux ()) $ WithAcc inputs lam interchangeWithAcc1 :: - (MonadBinder m, Rep m ~ SOACS) => + (MonadBuilder m, Rep m ~ SOACS) => WithAccStm -> LoopNesting -> m WithAccStm @@ -204,10 +202,10 @@ let (params, arrs) = unzip params_and_arrs maplam_ret = lambdaReturnType acc_lam maplam = Lambda (iota_p : orig_acc_params ++ params) (lambdaBody acc_lam) maplam_ret - auxing map_aux . letTupExp' "withacc_inter" $ + auxing map_aux . fmap subExpsRes . letTupExp' "withacc_inter" $ Op $ Screma w (iota_w : map paramName acc_params ++ arrs) (mapSOAC maplam) - let pat = Pattern [] $ rearrangeShape perm $ patternValueElements map_pat - perm' = [0 .. patternSize pat -1] + let pat = Pat $ rearrangeShape perm $ patElems map_pat + perm' = [0 .. patSize pat -1] pure $ WithAccStm perm' pat inputs' acc_lam' where newAccLamParams ps = do @@ -284,5 +282,5 @@ m (Stms SOACS) interchangeWithAcc nest withacc = do (withacc', stms) <- - runBinder $ foldM interchangeWithAcc1 withacc $ reverse $ kernelNestLoops nest + runBuilder $ foldM interchangeWithAcc1 withacc $ reverse $ kernelNestLoops nest return $ stms <> oneStm (withAccStm withacc') 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 @@ -14,7 +14,7 @@ import qualified Data.Set as S import Futhark.Analysis.PrimExp.Convert import qualified Futhark.IR.GPU as Out -import Futhark.IR.GPU.Kernel hiding (HistOp) +import Futhark.IR.GPU.Op hiding (HistOp) import Futhark.IR.SOACS import Futhark.MonadFreshNames import Futhark.Pass.ExtractKernels.BlockedKernel @@ -56,7 +56,7 @@ (num_groups, w_stms) <- lift $ - runBinder $ + runBuilder $ letSubExp "intra_num_groups" =<< foldBinOp (Mul Int64 OverflowUndef) (intConst Int64 1) (map snd ispace) @@ -80,7 +80,7 @@ fail "Irregular parallelism" ((intra_avail_par, kspace, read_input_stms), prelude_stms) <- lift $ - runBinder $ do + runBuilder $ do let foldBinOp' _ [] = eSubExp $ intConst Int64 0 foldBinOp' bop (x : xs) = foldBinOp bop x xs ws_min <- @@ -110,14 +110,14 @@ used_inps = filter inputIsUsed inps addStms w_stms - read_input_stms <- runBinder_ $ mapM readGroupKernelInput used_inps + read_input_stms <- runBuilder_ $ mapM readGroupKernelInput used_inps space <- mkSegSpace ispace return (intra_avail_par, space, read_input_stms) let kbody' = kbody {kernelBodyStms = read_input_stms <> kernelBodyStms kbody} - let nested_pat = loopNestingPattern first_nest - rts = map (length ispace `stripArray`) $ patternTypes nested_pat + let nested_pat = loopNestingPat first_nest + rts = map (length ispace `stripArray`) $ patTypes nested_pat lvl = SegGroup (Count num_groups) (Count $ Var group_size) SegNoVirt kstm = Let nested_pat aux $ @@ -136,7 +136,7 @@ aux = loopNestingAux first_nest readGroupKernelInput :: - (DistRep (Rep m), MonadBinder m) => + (DistRep (Rep m), MonadBuilder m) => KernelInput -> m () readGroupKernelInput inp @@ -161,7 +161,7 @@ mempty = IntraAcc mempty mempty mempty type IntraGroupM = - BinderT Out.GPU (RWS () IntraAcc VNameSource) + BuilderT Out.GPU (RWS () IntraAcc VNameSource) instance MonadLogger IntraGroupM where addLog log = tell mempty {accLog = log} @@ -173,7 +173,7 @@ runIntraGroupM m = do scope <- castScope <$> askScope modifyNameSource $ \src -> - let (((), kstms), src', acc) = runRWS (runBinderT m scope) () src + let (((), kstms), src', acc) = runRWS (runBuilderT m scope) () src in ((acc, kstms), src') parallelMin :: [SubExp] -> IntraGroupM () @@ -195,12 +195,12 @@ let lvl' = SegThread (segNumGroups lvl) (segGroupSize lvl) SegNoVirt case e of - DoLoop ctx val form loopbody -> + DoLoop merge form loopbody -> localScope (scopeOf form') $ - localScope (scopeOfFParams $ map fst $ ctx ++ val) $ do + localScope (scopeOfFParams $ map fst merge) $ do loopbody' <- intraGroupBody lvl loopbody certifying (stmAuxCerts aux) $ - letBind pat $ DoLoop ctx val form' loopbody' + letBind pat $ DoLoop merge form' loopbody' where form' = case form of ForLoop i it bound inps -> ForLoop i it bound inps @@ -213,7 +213,7 @@ Op soac | "sequential_outer" `inAttrs` stmAuxAttrs aux -> intraGroupStms lvl . fmap (certify (stmAuxCerts aux)) - =<< runBinder_ (FOT.transformSOAC pat soac) + =<< runBuilder_ (FOT.transformSOAC pat soac) Op (Screma w arrs form) | Just lam <- isMapSOAC form -> do let loopnest = MapNesting pat aux w $ zip (lambdaParams lam) arrs @@ -222,7 +222,7 @@ { distNest = singleNesting $ Nesting mempty loopnest, distScope = - scopeOfPattern pat + scopeOfPat pat <> scopeForGPU (scopeOf lam) <> scope, distOnInnerMap = @@ -275,7 +275,7 @@ | chunk_size_param : _ <- lambdaParams lam -> do types <- asksScope castScope ((), stream_bnds) <- - runBinderT (sequentialStreamWholeArray pat w accs lam arrs) types + runBuilderT (sequentialStreamWholeArray pat w accs lam arrs) types let replace (Var v) | v == paramName chunk_size_param = w replace se = se replaceSets (IntraAcc x y log) = @@ -290,18 +290,22 @@ krets = do (a_w, a, is_vs) <- groupScatterResults dests $ bodyResult $ lambdaBody lam' - return $ WriteReturns a_w a [(map DimFix is, v) | (is, v) <- is_vs] + let cs = + foldMap (foldMap resCerts . fst) is_vs + <> foldMap (resCerts . snd) is_vs + is_vs' = [(Slice $ map (DimFix . resSubExp) is, resSubExp v) | (is, v) <- is_vs] + return $ WriteReturns cs a_w a is_vs' inputs = do (p, p_a) <- zip (lambdaParams lam') ivs return $ KernelInput (paramName p) (paramType p) p_a [Var write_i] - kstms <- runBinder_ $ + kstms <- runBuilder_ $ localScope (scopeOfSegSpace space) $ do mapM_ readKernelInput inputs addStms $ bodyStms $ lambdaBody lam' certifying (stmAuxCerts aux) $ do - let ts = zipWith (stripArray . length) dests_ws $ patternTypes pat + let ts = zipWith (stripArray . length) dests_ws $ patTypes pat body = KernelBody () kstms krets letBind pat $ Op $ SegOp $ SegMap lvl' space ts body @@ -324,5 +328,7 @@ ( S.toList min_ws, S.toList avail_ws, log, - KernelBody () kstms $ map (Returns ResultMaySimplify) $ bodyResult body + KernelBody () kstms $ map ret $ bodyResult body ) + where + ret (SubExpRes cs se) = Returns ResultMaySimplify cs se 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 @@ -22,8 +22,8 @@ FunDef, LParam, Lambda, + Pat, PatElem, - Pattern, Prog, RetType, Stm, @@ -43,7 +43,7 @@ deriving (Eq, Ord, Show) numberOfGroups :: - (MonadBinder m, Op (Rep m) ~ HostOp (Rep m) inner) => + (MonadBuilder m, Op (Rep m) ~ HostOp (Rep m) inner) => String -> SubExp -> SubExp -> @@ -59,7 +59,7 @@ return (num_groups, num_threads) blockedKernelSize :: - (MonadBinder m, Rep m ~ GPU) => + (MonadBuilder m, Rep m ~ GPU) => String -> SubExp -> m KernelSize @@ -75,7 +75,7 @@ return $ KernelSize per_thread_elements num_threads splitArrays :: - (MonadBinder m, Rep m ~ GPU) => + (MonadBuilder m, Rep m ~ GPU) => VName -> [VName] -> SplitOrdering -> @@ -113,7 +113,7 @@ error "partitionChunkedKernelFoldParameters: lambda takes too few parameters" blockedPerThread :: - (MonadBinder m, Rep m ~ GPU) => + (MonadBuilder m, Rep m ~ GPU) => VName -> SubExp -> KernelSize -> @@ -156,12 +156,12 @@ addStms $ bodyStms (lambdaBody lam) <> stmsFromList - [ Let (Pattern [] [pe]) (defAux ()) $ BasicOp $ SubExp se - | (pe, se) <- zip chunk_red_pes chunk_red_ses + [ certify cs $ Let (Pat [pe]) (defAux ()) $ BasicOp $ SubExp se + | (pe, SubExpRes cs se) <- zip chunk_red_pes chunk_red_ses ] <> stmsFromList - [ Let (Pattern [] [pe]) (defAux ()) $ BasicOp $ SubExp se - | (pe, se) <- zip chunk_map_pes chunk_map_ses + [ certify cs $ Let (Pat [pe]) (defAux ()) $ BasicOp $ SubExp se + | (pe, SubExpRes cs se) <- zip chunk_map_pes chunk_map_ses ] return (chunk_red_pes, chunk_map_pes) @@ -182,22 +182,17 @@ mkAccInit p (Var v) | not $ primType $ paramType p = - mkLet [] [paramIdent p] $ BasicOp $ Copy v - mkAccInit p x = mkLet [] [paramIdent p] $ BasicOp $ SubExp x + mkLet [paramIdent p] $ BasicOp $ Copy v + mkAccInit p x = mkLet [paramIdent p] $ BasicOp $ SubExp x acc_init_bnds = stmsFromList $ zipWith mkAccInit fold_acc_params nes return lam - { lambdaBody = - insertStms acc_init_bnds $ - lambdaBody lam, - lambdaParams = - thread_index_param : - fold_chunk_param : - fold_inp_params + { lambdaBody = insertStms acc_init_bnds $ lambdaBody lam, + lambdaParams = thread_index_param : fold_chunk_param : fold_inp_params } prepareStream :: - (MonadBinder m, Rep m ~ GPU) => + (MonadBuilder m, Rep m ~ GPU) => KernelSize -> [(VName, SubExp)] -> SubExp -> @@ -218,14 +213,14 @@ gtid <- newVName "gtid" space <- mkSegSpace $ ispace ++ [(gtid, num_threads)] kbody <- fmap (uncurry (flip (KernelBody ()))) $ - runBinder $ + runBuilder $ localScope (scopeOfSegSpace space) $ do (chunk_red_pes, chunk_map_pes) <- blockedPerThread gtid w size ordering fold_lam' (length nes) arrs let concatReturns pe = - ConcatReturns split_ordering w elems_per_thread $ patElemName pe + ConcatReturns mempty split_ordering w elems_per_thread $ patElemName pe return - ( map (Returns ResultMaySimplify . Var . patElemName) chunk_red_pes + ( map (Returns ResultMaySimplify mempty . Var . patElemName) chunk_red_pes ++ map concatReturns chunk_map_pes ) @@ -237,7 +232,7 @@ streamRed :: (MonadFreshNames m, HasScope GPU m) => MkSegLevel GPU m -> - Pattern GPU -> + Pat GPU -> SubExp -> Commutativity -> Lambda GPU -> @@ -245,28 +240,21 @@ [SubExp] -> [VName] -> m (Stms GPU) -streamRed mk_lvl pat w comm red_lam fold_lam nes arrs = runBinderT'_ $ do +streamRed mk_lvl pat w comm red_lam fold_lam nes arrs = runBuilderT'_ $ do -- The strategy here is to rephrase the stream reduction as a -- non-segmented SegRed that does explicit chunking within its body. -- First, figure out how many threads to use for this. size <- blockedKernelSize "stream_red" w - let (redout_pes, mapout_pes) = splitAt (length nes) $ patternElements pat - (redout_pat, ispace, read_dummy) <- dummyDim $ Pattern [] redout_pes - let pat' = Pattern [] $ patternElements redout_pat ++ mapout_pes + let (redout_pes, mapout_pes) = splitAt (length nes) $ patElems pat + (redout_pat, ispace, read_dummy) <- dummyDim $ Pat redout_pes + let pat' = Pat $ patElems redout_pat ++ mapout_pes (_, kspace, ts, kbody) <- prepareStream size ispace w comm fold_lam nes arrs lvl <- mk_lvl [w] "stream_red" $ NoRecommendation SegNoVirt - letBind pat' $ - Op $ - SegOp $ - SegRed - lvl - kspace - [SegBinOp comm red_lam nes mempty] - ts - kbody + letBind pat' . Op . SegOp $ + SegRed lvl kspace [SegBinOp comm red_lam nes mempty] ts kbody read_dummy @@ -282,7 +270,7 @@ [SubExp] -> [VName] -> m ((SubExp, [VName]), Stms GPU) -streamMap mk_lvl out_desc mapout_pes w comm fold_lam nes arrs = runBinderT' $ do +streamMap mk_lvl out_desc mapout_pes w comm fold_lam nes arrs = runBuilderT' $ do size <- blockedKernelSize "stream_map" w (threads, kspace, ts, kbody) <- prepareStream size [] w comm fold_lam nes arrs @@ -292,7 +280,7 @@ redout_pes <- forM (zip out_desc redout_ts) $ \(desc, t) -> PatElem <$> newVName desc <*> pure (t `arrayOfRow` threads) - let pat = Pattern [] $ redout_pes ++ mapout_pes + let pat = Pat $ redout_pes ++ mapout_pes lvl <- mk_lvl [w] "stream_map" $ NoRecommendation SegNoVirt letBind pat $ Op $ SegOp $ SegMap lvl kspace ts kbody diff --git a/src/Futhark/Pass/ExtractKernels/ToGPU.hs b/src/Futhark/Pass/ExtractKernels/ToGPU.hs --- a/src/Futhark/Pass/ExtractKernels/ToGPU.hs +++ b/src/Futhark/Pass/ExtractKernels/ToGPU.hs @@ -23,7 +23,7 @@ import Futhark.Tools getSize :: - (MonadBinder m, Op (Rep m) ~ HostOp (Rep m) inner) => + (MonadBuilder m, Op (Rep m) ~ HostOp (Rep m) inner) => String -> SizeClass -> m SubExp @@ -32,7 +32,7 @@ letSubExp desc $ Op $ SizeOp $ GetSize size_key size_class segThread :: - (MonadBinder m, Op (Rep m) ~ HostOp (Rep m) inner) => + (MonadBuilder m, Op (Rep m) ~ HostOp (Rep m) inner) => String -> m SegLevel segThread desc = 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 @@ -3,6 +3,9 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +-- | Extraction of parallelism from a SOACs program. This generates +-- parallel constructs aimed at CPU execution, which in particular may +-- involve ad-hoc irregular nested parallelism. module Futhark.Pass.ExtractMulticore (extractMulticore) where import Control.Monad.Identity @@ -18,7 +21,7 @@ Exp, LParam, Lambda, - Pattern, + Pat, Stm, ) import qualified Futhark.IR.SOACS as SOACS @@ -48,10 +51,10 @@ indexArray :: VName -> LParam SOACS -> VName -> Stm MC indexArray i (Param p t) arr = - Let (Pattern [] [PatElem p t]) (defAux ()) . BasicOp $ + Let (Pat [PatElem p t]) (defAux ()) . BasicOp $ case t of Acc {} -> SubExp $ Var arr - _ -> Index arr $ DimFix (Var i) : map sliceDim (arrayDims t) + _ -> Index arr $ Slice $ DimFix (Var i) : map sliceDim (arrayDims t) mapLambdaToBody :: (Body SOACS -> ExtractM (Body MC)) -> @@ -72,23 +75,24 @@ ExtractM (KernelBody MC) mapLambdaToKernelBody onBody i lam arrs = do Body () stms res <- mapLambdaToBody onBody i lam arrs - return $ KernelBody () stms $ map (Returns ResultMaySimplify) res + let ret (SubExpRes cs se) = Returns ResultMaySimplify cs se + return $ KernelBody () stms $ map ret res reduceToSegBinOp :: Reduce SOACS -> ExtractM (Stms MC, SegBinOp MC) reduceToSegBinOp (Reduce comm lam nes) = do - ((lam', nes', shape), stms) <- runBinder $ determineReduceOp lam nes + ((lam', nes', shape), stms) <- runBuilder $ determineReduceOp lam nes lam'' <- transformLambda lam' return (stms, SegBinOp comm lam'' nes' shape) scanToSegBinOp :: Scan SOACS -> ExtractM (Stms MC, SegBinOp MC) scanToSegBinOp (Scan lam nes) = do - ((lam', nes', shape), stms) <- runBinder $ determineReduceOp lam nes + ((lam', nes', shape), stms) <- runBuilder $ determineReduceOp lam nes lam'' <- transformLambda lam' return (stms, SegBinOp Noncommutative lam'' nes' shape) histToSegBinOp :: SOACS.HistOp SOACS -> ExtractM (Stms MC, MC.HistOp MC) histToSegBinOp (SOACS.HistOp num_bins rf dests nes op) = do - ((op', nes', shape), stms) <- runBinder $ determineReduceOp op nes + ((op', nes', shape), stms) <- runBuilder $ determineReduceOp op nes op'' <- transformLambda op' return (stms, MC.HistOp num_bins rf dests nes' shape op'') @@ -108,16 +112,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 ctx val form body)) = do +transformStm (Let pat aux (DoLoop merge form body)) = do let form' = transformLoopForm form body' <- - localScope - ( scopeOfFParams (map fst ctx) - <> scopeOfFParams (map fst val) - <> scopeOf form' - ) - $ transformBody body - return $ oneStm $ Let pat aux $ DoLoop ctx val form' body' + localScope (scopeOfFParams (map fst merge) <> scopeOf form') $ + transformBody body + return $ oneStm $ Let pat aux $ DoLoop merge form' body' transformStm (Let pat aux (If cond tbranch fbranch ret)) = oneStm . Let pat aux <$> (If cond <$> transformBody tbranch <*> transformBody fbranch <*> pure ret) @@ -167,7 +167,7 @@ inp_params <- forM slice_params $ \(Param p t) -> newParam (baseString p) (rowType t) - body <- runBodyBinder $ + body <- runBodyBuilder $ localScope (scopeOfLParams inp_params) $ do letBindNames [paramName chunk_param] $ BasicOp $ SubExp $ intConst Int64 1 @@ -181,15 +181,13 @@ (red_res, map_res) <- splitAt (length nes) <$> bodyBind (lambdaBody lam) - map_res' <- forM map_res $ \se -> do + map_res' <- forM map_res $ \(SubExpRes cs se) -> do v <- letExp "map_res" $ BasicOp $ SubExp se v_t <- lookupType v - letSubExp "chunk" $ - BasicOp $ - Index v $ - fullSlice v_t [DimFix $ intConst Int64 0] + certifying cs . letSubExp "chunk" . BasicOp $ + Index v $ fullSlice v_t [DimFix $ intConst Int64 0] - pure $ resultBody $ red_res <> map_res' + pure $ mkBody mempty $ red_res <> subExpsRes map_res' let (red_ts, map_ts) = splitAt (length nes) $ lambdaReturnType lam map_lam = @@ -282,7 +280,7 @@ SegRed () space [red] (lambdaReturnType map_lam) kbody return (red_stms, op) -transformSOAC :: Pattern SOACS -> Attrs -> SOAC SOACS -> ExtractM (Stms MC) +transformSOAC :: Pat SOACS -> Attrs -> SOAC SOACS -> ExtractM (Stms MC) transformSOAC pat _ (Screma w arrs form) | Just lam <- isMapSOAC form = do seq_op <- transformMap DoNotRename sequentialiseBody w lam arrs @@ -321,7 +319,7 @@ -- This screma is too complicated for us to immediately do -- anything, so split it up and try again. scope <- castScope <$> askScope - transformStms =<< runBinderT_ (dissectScrema pat w form arrs) scope + transformStms =<< runBuilderT_ (dissectScrema pat w form arrs) scope transformSOAC pat _ (Scatter w lam ivs dests) = do (gtid, space) <- mkSegSpace w @@ -329,9 +327,12 @@ let rets = takeLast (length dests) $ lambdaReturnType lam kres = do - (a_w, a, is_vs) <- - groupScatterResults dests res - return $ WriteReturns a_w a [(map DimFix is, v) | (is, v) <- is_vs] + (a_w, a, is_vs) <- groupScatterResults dests res + let cs = + foldMap (foldMap resCerts . fst) is_vs + <> foldMap (resCerts . snd) is_vs + is_vs' = [(Slice $ map (DimFix . resSubExp) is, resSubExp v) | (is, v) <- is_vs] + return $ WriteReturns cs a_w a is_vs' kbody = KernelBody () kstms kres return $ oneStm $ @@ -383,7 +384,7 @@ -- Just remove the stream and transform the resulting stms. soacs_scope <- castScope <$> askScope stream_stms <- - flip runBinderT_ soacs_scope $ + flip runBuilderT_ soacs_scope $ sequentialStreamWholeArray pat w nes lam arrs transformStms stream_stms @@ -396,6 +397,8 @@ funs' <- inScopeOf consts' $ mapM transformFunDef funs return $ Prog consts' funs' +-- | Transform a program using SOACs to a program in the 'MC' +-- representation, using some amount of flattening. extractMulticore :: Pass SOACS MC extractMulticore = Pass 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 @@ -19,8 +19,8 @@ FunDef, LParam, Lambda, + Pat, PatElem, - Pattern, Prog, RetType, Stm, @@ -40,9 +40,9 @@ where onStms scope stms = do let m = localScope scope $ transformStms mempty stms - fmap fst $ modifyNameSource $ runState (runBinderT m M.empty) + fmap fst $ modifyNameSource $ runState (runBuilderT m M.empty) -type BabysitM = Binder GPU +type BabysitM = Builder GPU transformStms :: ExpMap -> Stms GPU -> BabysitM (Stms GPU) transformStms expmap stms = collectStms_ $ foldM_ transformStm expmap stms @@ -62,7 +62,7 @@ nonlinearInMemory :: VName -> ExpMap -> Maybe (Maybe [Int]) nonlinearInMemory name m = case M.lookup name m of - Just (Let _ _ (BasicOp (Opaque (Var arr)))) -> nonlinearInMemory arr m + Just (Let _ _ (BasicOp (Opaque _ (Var arr)))) -> nonlinearInMemory arr m Just (Let _ _ (BasicOp (Rearrange perm _))) -> Just $ Just $ rearrangeInverse perm Just (Let _ _ (BasicOp (Reshape _ arr))) -> nonlinearInMemory arr m Just (Let _ _ (BasicOp (Manifest perm _))) -> Just $ Just perm @@ -70,7 +70,7 @@ nonlinear =<< find ((== name) . patElemName . fst) - (zip (patternElements pat) ts) + (zip (patElems pat) ts) _ -> Nothing where nonlinear (pe, t) @@ -95,12 +95,12 @@ op' <- mapSegOpM mapper op let stm' = Let pat aux $ Op $ SegOp op' addStm stm' - return $ M.fromList [(name, stm') | name <- patternNames pat] <> expmap + return $ M.fromList [(name, stm') | name <- patNames pat] <> expmap transformStm expmap (Let pat aux e) = do e' <- mapExpM (transform expmap) e let bnd' = Let pat aux e' addStm bnd' - return $ M.fromList [(name, bnd') | name <- patternNames pat] <> expmap + return $ M.fromList [(name, bnd') | name <- patNames pat] <> expmap transform :: ExpMap -> Mapper GPU GPU BabysitM transform expmap = @@ -218,14 +218,14 @@ mkSizeSubsts = foldMap mkStmSizeSubst where - mkStmSizeSubst (Let (Pattern [] [pe]) _ (Op (SizeOp (SplitSpace _ _ _ elems_per_i)))) = + mkStmSizeSubst (Let (Pat [pe]) _ (Op (SizeOp (SplitSpace _ _ _ elems_per_i)))) = M.singleton (patElemName pe) elems_per_i mkStmSizeSubst _ = mempty type Replacements = M.Map (VName, Slice SubExp) VName ensureCoalescedAccess :: - MonadBinder m => + MonadBuilder m => ExpMap -> [(VName, SubExp)] -> SubExp -> @@ -268,7 +268,7 @@ not $ null thread_gids, inner_gid <- last thread_gids, length slice >= length perm, - slice' <- map (slice !!) perm, + slice' <- map (unSlice slice !!) perm, DimFix inner_ind <- last slice', not $ null thread_gids, isGidVariant inner_gid inner_ind -> @@ -309,7 +309,7 @@ -- padding. | (is, rem_slice) <- splitSlice slice, and $ zipWith (==) is $ map Var thread_gids, - DimSlice offset len (Constant stride) : _ <- rem_slice, + DimSlice offset len (Constant stride) : _ <- unSlice rem_slice, isThreadLocalSubExp offset, Just {} <- sizeSubst len, oneIsh stride -> do @@ -352,14 +352,14 @@ comb (_, x) _ = (False, x) splitSlice :: Slice SubExp -> ([SubExp], Slice SubExp) -splitSlice [] = ([], []) -splitSlice (DimFix i : is) = first (i :) $ splitSlice is +splitSlice (Slice []) = ([], Slice []) +splitSlice (Slice (DimFix i : is)) = first (i :) $ splitSlice (Slice is) splitSlice is = ([], is) allDimAreSlice :: Slice SubExp -> Bool -allDimAreSlice [] = True -allDimAreSlice (DimFix _ : _) = False -allDimAreSlice (_ : is) = allDimAreSlice is +allDimAreSlice (Slice []) = True +allDimAreSlice (Slice (DimFix _ : _)) = False +allDimAreSlice (Slice (_ : is)) = allDimAreSlice (Slice is) -- Try to move thread indexes into their proper position. coalescedIndexes :: Names -> (VName -> SubExp -> Bool) -> [SubExp] -> [SubExp] -> Maybe [SubExp] @@ -418,7 +418,7 @@ [num_is .. rank -1] ++ [0 .. num_is -1] rearrangeInput :: - MonadBinder m => + MonadBuilder m => Maybe (Maybe [Int]) -> [Int] -> VName -> @@ -441,7 +441,7 @@ BasicOp $ Manifest perm manifested rowMajorArray :: - MonadBinder m => + MonadBuilder m => VName -> m VName rowMajorArray arr = do @@ -449,7 +449,7 @@ letExp (baseString arr ++ "_rowmajor") $ BasicOp $ Manifest [0 .. rank -1] arr rearrangeSlice :: - MonadBinder m => + MonadBuilder m => Int -> SubExp -> PrimExp VName -> @@ -498,7 +498,7 @@ =<< eSliceArray d arr_inv_tr (eSubExp $ constant (0 :: Int64)) (eSubExp w) paddedScanReduceInput :: - MonadBinder m => + MonadBuilder m => SubExp -> SubExp -> m (SubExp, SubExp) @@ -518,7 +518,7 @@ varianceInStm :: VarianceTable -> Stm GPU -> VarianceTable varianceInStm variance bnd = - foldl' add variance $ patternNames $ stmPattern bnd + foldl' add variance $ patNames $ stmPat bnd where add variance' v = M.insert v binding_variance variance' look variance' v = oneName v <> M.findWithDefault mempty v variance' diff --git a/src/Futhark/Passes.hs b/src/Futhark/Passes.hs --- a/src/Futhark/Passes.hs +++ b/src/Futhark/Passes.hs @@ -44,7 +44,9 @@ standardPipeline = passes [ simplifySOACS, - inlineFunctions, + inlineConservatively, + simplifySOACS, + inlineAggressively, simplifySOACS, performCSE True, simplifySOACS, diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs --- a/src/Futhark/Script.hs +++ b/src/Futhark/Script.hs @@ -131,7 +131,7 @@ parseExp sep = choice [ lexeme sep "let" $> Let - <*> pPattern <* lexeme sep "=" + <*> pPat <* lexeme sep "=" <*> parseExp sep <* lexeme sep "in" <*> parseExp sep, try $ Call <$> parseFunc <*> many pAtom, @@ -155,7 +155,7 @@ Call <$> parseFunc <*> pure [] ] - pPattern = + pPat = choice [ inParens sep $ pVarName `sepBy` pComma, pure <$> pVarName @@ -321,7 +321,7 @@ pure $ M.fromList (zip vs vals) | otherwise = throwError $ - "Pattern: " <> prettyTextOneLine vs + "Pat: " <> prettyTextOneLine vs <> "\nDoes not match value of type: " <> prettyTextOneLine (fmap scriptValueType val) diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -623,8 +623,12 @@ forM_ (zip gen_fs names_and_types) $ \(file, (v, t)) -> cmdMaybe $ cmdRestore server (dir file) [(v, t)] valuesAsVars server names_and_types _ _ (Values vs) = do - unless (length vs == length names_and_types) $ - throwError "Mismatch between number of expected and provided values." + let types = map snd names_and_types + vs_types = map (V.valueTypeTextNoDims . V.valueType) vs + unless (types == vs_types) . throwError . T.unlines $ + [ "Expected input of types: " <> prettyTextOneLine types, + "Provided input of types: " <> prettyTextOneLine vs_types + ] cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do mapM_ (BS.hPutStr tmpf_h . Bin.encode) vs hClose tmpf_h diff --git a/src/Futhark/Tools.hs b/src/Futhark/Tools.hs --- a/src/Futhark/Tools.hs +++ b/src/Futhark/Tools.hs @@ -27,52 +27,44 @@ -- -- Reuses the original pattern for the @reduce@, and creates a new -- pattern with new 'Ident's for the result of the @map@. --- --- Only handles a pattern with an empty 'patternContextElements'. redomapToMapAndReduce :: ( MonadFreshNames m, - Bindable rep, + Buildable rep, ExpDec rep ~ (), Op rep ~ SOAC rep ) => - Pattern rep -> + Pat rep -> ( SubExp, - Commutativity, - LambdaT rep, + [Reduce rep], LambdaT rep, - [SubExp], [VName] ) -> m (Stm rep, Stm rep) -redomapToMapAndReduce - (Pattern [] patelems) - (w, comm, redlam, map_lam, accs, arrs) = do - (map_pat, red_pat, red_args) <- - splitScanOrRedomap patelems w map_lam accs - let map_bnd = mkLet [] map_pat $ Op $ Screma w arrs (mapSOAC map_lam) - (nes, red_arrs) = unzip red_args - red_bnd <- - Let red_pat (defAux ()) . Op - <$> (Screma w red_arrs <$> reduceSOAC [Reduce comm redlam nes]) - return (map_bnd, red_bnd) -redomapToMapAndReduce _ _ = - error "redomapToMapAndReduce does not handle a non-empty 'patternContextElements'" +redomapToMapAndReduce (Pat pes) (w, reds, map_lam, arrs) = do + (map_pat, red_pat, red_arrs) <- + splitScanOrRedomap pes w map_lam $ map redNeutral reds + let map_stm = mkLet map_pat $ Op $ Screma w arrs (mapSOAC map_lam) + red_stm <- + Let red_pat (defAux ()) . Op + <$> (Screma w red_arrs <$> reduceSOAC reds) + return (map_stm, red_stm) splitScanOrRedomap :: (Typed dec, MonadFreshNames m) => [PatElemT dec] -> SubExp -> LambdaT rep -> - [SubExp] -> - m ([Ident], PatternT dec, [(SubExp, VName)]) -splitScanOrRedomap patelems w map_lam accs = do - let (acc_patelems, arr_patelems) = splitAt (length accs) patelems - (acc_ts, _arr_ts) = splitAt (length accs) $ lambdaReturnType map_lam - map_accpat <- zipWithM accMapPatElem acc_patelems acc_ts - map_arrpat <- mapM arrMapPatElem arr_patelems + [[SubExp]] -> + m ([Ident], PatT dec, [VName]) +splitScanOrRedomap pes w map_lam nes = do + let (acc_pes, arr_pes) = + splitAt (length $ concat nes) pes + (acc_ts, _arr_ts) = + splitAt (length (concat nes)) $ lambdaReturnType map_lam + map_accpat <- zipWithM accMapPatElem acc_pes acc_ts + map_arrpat <- mapM arrMapPatElem arr_pes let map_pat = map_accpat ++ map_arrpat - red_args = zip accs $ map identName map_accpat - return (map_pat, Pattern [] acc_patelems, red_args) + return (map_pat, Pat acc_pes, map identName map_accpat) where accMapPatElem pe acc_t = newIdent (baseString (patElemName pe) ++ "_map_acc") $ acc_t `arrayOfRow` w @@ -83,11 +75,11 @@ -- that we cannot directly generate efficient parallel code for them. -- In essense, what happens is the opposite of horisontal fusion. dissectScrema :: - ( MonadBinder m, + ( MonadBuilder m, Op (Rep m) ~ SOAC (Rep m), - Bindable (Rep m) + Buildable (Rep m) ) => - Pattern (Rep m) -> + Pat (Rep m) -> SubExp -> ScremaForm (Rep m) -> [VName] -> @@ -96,7 +88,7 @@ let num_reds = redResults reds num_scans = scanResults scans (scan_res, red_res, map_res) = - splitAt3 num_scans num_reds $ patternNames pat + splitAt3 num_scans num_reds $ patNames pat to_red <- replicateM num_reds $ newVName "to_red" @@ -110,8 +102,8 @@ -- | Turn a stream SOAC into statements that apply the stream lambda -- to the entire input. sequentialStreamWholeArray :: - (MonadBinder m, Bindable (Rep m)) => - Pattern (Rep m) -> + (MonadBuilder m, Buildable (Rep m)) => + Pat (Rep m) -> SubExp -> [SubExp] -> LambdaT (Rep m) -> @@ -143,8 +135,8 @@ -- The number of results in the body matches exactly the size (and -- order) of 'pat', so we bind them up here, again with a reshape to -- make the types work out. - forM_ (zip (patternElements pat) $ bodyResult $ lambdaBody lam) $ \(pe, se) -> - case (arrayDims $ patElemType pe, se) of + forM_ (zip (patElems pat) $ bodyResult $ lambdaBody lam) $ \(pe, SubExpRes cs se) -> + certifying cs $ case (arrayDims $ patElemType pe, se) of (dims, Var v) | not $ null dims -> letBindNames [patElemName pe] $ BasicOp $ Reshape (map DimCoercion dims) v 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 @@ -33,8 +33,8 @@ -- | The constraints that must hold for a rep in order to be the -- target of first-order transformation. type FirstOrderRep rep = - ( Bindable rep, - BinderOps rep, + ( Buildable rep, + BuilderOps rep, LetDec SOACS ~ LetDec rep, LParamInfo SOACS ~ LParamInfo rep, CanBeAliased (Op rep) @@ -48,7 +48,7 @@ FunDef SOACS -> m (AST.FunDef torep) transformFunDef consts_scope (FunDef entry attrs fname rettype params body) = do - (body', _) <- modifyNameSource $ runState $ runBinderT m consts_scope + (body', _) <- modifyNameSource $ runState $ runBuilderT m consts_scope return $ FunDef entry attrs fname rettype params body' where m = localScope (scopeOfFParams params) $ transformBody body @@ -59,17 +59,17 @@ Stms SOACS -> m (AST.Stms torep) transformConsts stms = - fmap snd $ modifyNameSource $ runState $ runBinderT m mempty + fmap snd $ modifyNameSource $ runState $ runBuilderT m mempty where m = mapM_ transformStmRecursively stms -- | The constraints that a monad must uphold in order to be used for -- first-order transformation. type Transformer m = - ( MonadBinder m, + ( MonadBuilder m, LocalScope (Rep m) m, - Bindable (Rep m), - BinderOps (Rep m), + Buildable (Rep m), + BuilderOps (Rep m), LParamInfo SOACS ~ LParamInfo (Rep m), CanBeAliased (Op (Rep m)) ) @@ -122,7 +122,7 @@ -- on the given rep. transformSOAC :: Transformer m => - AST.Pattern (Rep m) -> + AST.Pat (Rep m) -> SOAC (Rep m) -> m () transformSOAC pat (Screma w arrs form@(ScremaForm scans reds map_lam)) = do @@ -161,7 +161,7 @@ let loopform = ForLoop i Int64 w [] lam_cons = consumedByLambda $ Alias.analyseLambda mempty map_lam - loop_body <- runBodyBinder + loop_body <- runBodyBuilder . localScope (scopeOfFParams (map fst merge) <> scopeOf loopform) $ do -- Bind the parameters to the lambda. @@ -193,35 +193,35 @@ scan_res' <- eLambda scan_lam $ map (pure . BasicOp . SubExp) $ - map (Var . paramName) scanacc_params ++ scan_res + map (Var . paramName) scanacc_params ++ map resSubExp scan_res red_res' <- eLambda red_lam $ map (pure . BasicOp . SubExp) $ - map (Var . paramName) redout_params ++ red_res + map (Var . paramName) redout_params ++ map resSubExp red_res -- Write the scan accumulator to the scan result arrays. scan_outarrs <- - letwith (map paramName scanout_params) (Var i) scan_res' + certifying (foldMap resCerts scan_res) $ + letwith (map paramName scanout_params) (Var i) $ map resSubExp scan_res' -- Write the map results to the map result arrays. map_outarrs <- - letwith (map paramName mapout_params) (Var i) map_res + certifying (foldMap resCerts map_res) $ + letwith (map paramName mapout_params) (Var i) $ map resSubExp map_res - return $ - resultBody $ - concat - [ scan_res', - map Var scan_outarrs, - red_res', - map Var map_outarrs - ] + return . mkBody mempty . concat $ + [ scan_res', + varsRes scan_outarrs, + red_res', + varsRes map_outarrs + ] -- We need to discard the final scan accumulators, as they are not -- bound in the original pattern. names <- - (++ patternNames pat) + (++ patNames pat) <$> replicateM (length scanacc_params) (newVName "discard") - letBindNames names $ DoLoop [] merge loopform loop_body + letBindNames names $ DoLoop 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 @@ -258,7 +258,7 @@ letBindNames [paramName chunk_size_param] $ BasicOp $ SubExp $ intConst Int64 1 - loop_body <- runBodyBinder $ + loop_body <- runBodyBuilder $ localScope (scopeOf loop_form <> scopeOfFParams merge_params) $ do let slice = [DimSlice (Var i) (Var (paramName chunk_size_param)) (intConst Int64 1)] forM_ (zip chunk_params arrs) $ \(p, arr) -> @@ -267,13 +267,13 @@ (res, mapout_res) <- splitAt (length nes) <$> bodyBind (lambdaBody lam) - mapout_res' <- forM (zip mapout_params mapout_res) $ \(p, se) -> - letSubExp "mapout_res" . BasicOp $ - Update (paramName p) (fullSlice (paramType p) slice) se + mapout_res' <- forM (zip mapout_params mapout_res) $ \(p, SubExpRes cs se) -> + certifying cs . letSubExp "mapout_res" . BasicOp $ + Update Unsafe (paramName p) (fullSlice (paramType p) slice) se - resultBodyM $ res ++ mapout_res' + mkBodyM mempty $ res ++ subExpsRes mapout_res' - letBind pat $ DoLoop [] merge loop_form loop_body + letBind pat $ DoLoop merge loop_form loop_body transformSOAC pat (Scatter len lam ivs as) = do iter <- newVName "write_iter" @@ -283,7 +283,7 @@ -- Scatter is in-place, so we use the input array as the output array. let merge = loopMerge asOuts $ map Var as_vs - loopBody <- runBodyBinder $ + loopBody <- runBodyBuilder $ localScope (M.insert iter (IndexName Int64) $ scopeOfFParams $ map fst merge) $ do ivs' <- forM ivs $ \iv -> do iv_t <- lookupType iv @@ -293,12 +293,14 @@ let indexes = groupScatterResults (zip3 as_ws as_ns $ map identName asOuts) ivs'' ress <- forM indexes $ \(_, arr, indexes') -> do - let saveInArray arr' (indexCur, valueCur) = - letExp "write_out" =<< eWriteArray arr' (map eSubExp indexCur) (eSubExp valueCur) + arr_t <- lookupType arr + let saveInArray arr' (indexCur, SubExpRes value_cs valueCur) = + certifying (foldMap resCerts indexCur <> value_cs) . letExp "write_out" $ + BasicOp $ Update Safe arr' (fullSlice arr_t $ map (DimFix . resSubExp) indexCur) valueCur foldM saveInArray arr indexes' return $ resultBody (map Var ress) - letBind pat $ DoLoop [] merge (ForLoop iter Int64 len []) loopBody + letBind pat $ DoLoop merge (ForLoop iter Int64 len []) loopBody transformSOAC pat (Hist len ops bucket_fun imgs) = do iter <- newVName "iter" @@ -309,12 +311,12 @@ -- Bind lambda-bodies for operators. let iter_scope = M.insert iter (IndexName Int64) $ scopeOfFParams $ map fst merge - loopBody <- runBodyBinder . localScope iter_scope $ do + loopBody <- runBodyBuilder . localScope iter_scope $ do -- Bind images to parameters of bucket function. imgs' <- forM imgs $ \img -> do img_t <- lookupType img letSubExp "pixel" $ BasicOp $ Index img $ fullSlice img_t [DimFix $ Var iter] - imgs'' <- bindLambda bucket_fun $ map (BasicOp . SubExp) imgs' + imgs'' <- map resSubExp <$> bindLambda bucket_fun (map (BasicOp . SubExp) imgs') -- Split out values from bucket function. let lens = length ops @@ -327,7 +329,7 @@ hists_out'' <- forM (zip4 hists_out' ops inds vals) $ \(hist, op, idx, val) -> do -- Check whether the indexes are in-bound. If they are not, we -- return the histograms unchanged. - let outside_bounds_branch = buildBody_ $ pure $ map Var hist + let outside_bounds_branch = buildBody_ $ pure $ varsRes hist oob = case hist of [] -> eSubExp $ constant True arr : _ -> eOutOfBounds arr [eSubExp idx] @@ -345,23 +347,23 @@ map (BasicOp . SubExp) $ h_val ++ val -- Write values back to histograms. - hist' <- forM (zip hist h_val') $ \(arr, v) -> do + hist' <- forM (zip hist h_val') $ \(arr, SubExpRes cs v) -> do arr_t <- lookupType arr - letInPlace "hist_out" arr (fullSlice arr_t [DimFix idx]) $ + certifying cs . letInPlace "hist_out" arr (fullSlice arr_t [DimFix idx]) $ BasicOp $ SubExp v - pure $ map Var hist' + pure $ varsRes hist' return $ 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 $ DoLoop merge (ForLoop iter Int64 len []) loopBody -- | Recursively first-order-transform a lambda. transformLambda :: ( MonadFreshNames m, - Bindable rep, - BinderOps rep, + Buildable rep, + BuilderOps rep, LocalScope somerep m, SameScope somerep rep, LetDec rep ~ LetDec SOACS, @@ -371,7 +373,7 @@ m (AST.Lambda rep) transformLambda (Lambda params body rettype) = do body' <- - runBodyBinder $ + runBodyBuilder $ localScope (scopeOfLParams params) $ transformBody body return $ Lambda params body' rettype @@ -391,7 +393,7 @@ Transformer m => AST.Lambda (Rep m) -> [AST.Exp (Rep m)] -> - m [SubExp] + m Result bindLambda (Lambda params body _) args = do forM_ (zip params args) $ \(param, arg) -> if primType $ paramType param 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 @@ -19,7 +19,7 @@ renameStm, renameBody, renameLambda, - renamePattern, + renamePat, renameSomething, -- * Renaming annotations @@ -105,13 +105,13 @@ -- | Produce an equivalent pattern but with each pattern element given -- a new name. -renamePattern :: +renamePat :: (Rename dec, MonadFreshNames m) => - PatternT dec -> - m (PatternT dec) -renamePattern = modifyNameSource . runRenamer . rename' + PatT dec -> + m (PatT dec) +renamePat = modifyNameSource . runRenamer . rename' where - rename' pat = bind (patternNames pat) $ rename pat + rename' pat = bind (patNames pat) $ rename pat -- | Rename the bound variables in something (does not affect free variables). renameSomething :: @@ -201,7 +201,7 @@ where descend stms' rem_stms = case stmsHead rem_stms of Nothing -> m stms' - Just (stm, rem_stms') -> bind (patternNames $ stmPattern stm) $ do + Just (stm, rem_stms') -> bind (patNames $ stmPat stm) $ do stm' <- rename stm descend (stms' <> oneStm stm') rem_stms' @@ -220,14 +220,14 @@ instance Rename dec => Rename (Param dec) where rename (Param name dec) = Param <$> rename name <*> rename dec -instance Rename dec => Rename (PatternT dec) where - rename (Pattern context values) = Pattern <$> rename context <*> rename values +instance Rename dec => Rename (PatT dec) where + rename (Pat xs) = Pat <$> rename xs instance Rename dec => Rename (PatElemT dec) where rename (PatElem ident dec) = PatElem <$> rename ident <*> rename dec -instance Rename Certificates where - rename (Certificates cs) = Certificates <$> rename cs +instance Rename Certs where + rename (Certs cs) = Certs <$> rename cs instance Rename Attrs where rename = pure @@ -236,6 +236,9 @@ 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 rename (Body dec stms res) = do dec' <- rename dec @@ -248,49 +251,33 @@ instance Renameable rep => Rename (Exp rep) where rename (WithAcc inputs lam) = WithAcc <$> rename inputs <*> rename lam - rename (DoLoop ctx val form loopbody) = do - let (ctxparams, ctxinit) = unzip ctx - (valparams, valinit) = unzip val - ctxinit' <- mapM rename ctxinit - valinit' <- mapM rename valinit + rename (DoLoop merge form loopbody) = do + let (params, args) = unzip merge + args' <- mapM rename args case form of -- It is important that 'i' is renamed before the loop_vars, as -- 'i' may be used in the annotations for loop_vars (e.g. index -- functions). ForLoop i it boundexp loop_vars -> bind [i] $ do - let (loop_params, loop_arrs) = unzip loop_vars + let (arr_params, loop_arrs) = unzip loop_vars boundexp' <- rename boundexp loop_arrs' <- rename loop_arrs - bind - ( map paramName (ctxparams ++ valparams) - ++ map paramName loop_params - ) - $ do - ctxparams' <- mapM rename ctxparams - valparams' <- mapM rename valparams - loop_params' <- mapM rename loop_params - i' <- rename i - loopbody' <- rename loopbody - return $ - DoLoop - (zip ctxparams' ctxinit') - (zip valparams' valinit') - ( ForLoop i' it boundexp' $ - zip loop_params' loop_arrs' - ) - loopbody' - WhileLoop cond -> - bind (map paramName $ ctxparams ++ valparams) $ do - ctxparams' <- mapM rename ctxparams - valparams' <- mapM rename valparams + bind (map paramName params ++ map paramName arr_params) $ do + params' <- mapM rename params + arr_params' <- mapM rename arr_params + i' <- rename i loopbody' <- rename loopbody - cond' <- rename cond return $ DoLoop - (zip ctxparams' ctxinit') - (zip valparams' valinit') - (WhileLoop cond') + (zip params' args') + (ForLoop i' it boundexp' $ zip arr_params' loop_arrs') loopbody' + WhileLoop cond -> + bind (map paramName params) $ do + params' <- mapM rename params + loopbody' <- rename loopbody + cond' <- rename cond + return $ DoLoop (zip params' args') (WhileLoop cond') loopbody' rename e = mapExpM mapper e where mapper = 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 @@ -95,14 +95,18 @@ (substituteNames substs name) (substituteNames substs dec) -instance Substitute dec => Substitute (PatternT dec) where - substituteNames substs (Pattern context values) = - Pattern (substituteNames substs context) (substituteNames substs values) +instance Substitute SubExpRes where + substituteNames substs (SubExpRes cs se) = + SubExpRes (substituteNames substs cs) (substituteNames substs se) -instance Substitute Certificates where - substituteNames substs (Certificates cs) = - Certificates $ substituteNames substs cs +instance Substitute dec => Substitute (PatT dec) where + substituteNames substs (Pat xs) = + Pat (substituteNames substs xs) +instance Substitute Certs where + substituteNames substs (Certs cs) = + Certs $ substituteNames substs cs + instance Substitutable rep => Substitute (Stm rep) where substituteNames substs (Let pat annot e) = Let @@ -182,6 +186,15 @@ substituteNames substs = fmap $ substituteNames substs instance Substitute d => Substitute (DimIndex d) where + substituteNames substs = fmap $ substituteNames substs + +instance Substitute d => Substitute (Slice d) where + substituteNames substs = fmap $ substituteNames substs + +instance Substitute d => Substitute (FlatDimIndex d) where + substituteNames substs = fmap $ substituteNames substs + +instance Substitute d => Substitute (FlatSlice d) where substituteNames substs = fmap $ substituteNames substs instance Substitute v => Substitute (PrimExp v) where diff --git a/src/Futhark/TypeCheck.hs b/src/Futhark/TypeCheck.hs --- a/src/Futhark/TypeCheck.hs +++ b/src/Futhark/TypeCheck.hs @@ -33,12 +33,13 @@ requireI, requirePrimExp, checkSubExp, + checkCerts, checkExp, checkStms, checkStm, checkType, checkExtType, - matchExtPattern, + matchExtPat, matchExtBranchType, argType, argAliases, @@ -76,8 +77,8 @@ | ReturnTypeError Name [ExtType] [ExtType] | DupDefinitionError Name | DupParamError Name VName - | DupPatternError VName - | InvalidPatternError (Pattern (Aliases rep)) [ExtType] (Maybe String) + | DupPatError VName + | InvalidPatError (Pat (Aliases rep)) [ExtType] (Maybe String) | UnknownVariableError VName | UnknownFunctionError Name | ParameterMismatch (Maybe Name) [Type] [Type] @@ -116,10 +117,10 @@ ++ " mentioned multiple times in argument list of function " ++ nameToString funname ++ "." - show (DupPatternError name) = + show (DupPatError name) = "Variable " ++ pretty name ++ " bound twice in pattern." - show (InvalidPatternError pat t desc) = - "Pattern\n" ++ pretty pat + show (InvalidPatError pat t desc) = + "Pat\n" ++ pretty pat ++ "\ncannot match value of type\n" ++ prettyTuple t ++ end @@ -705,6 +706,14 @@ observe ident lookupType ident +checkCerts :: Checkable rep => Certs -> TypeM rep () +checkCerts (Certs cs) = mapM_ (requireI [Prim Unit]) cs + +checkSubExpRes :: Checkable rep => SubExpRes -> TypeM rep Type +checkSubExpRes (SubExpRes cs se) = do + checkCerts cs + checkSubExp se + checkStms :: Checkable rep => Stms (Aliases rep) -> @@ -724,7 +733,7 @@ Checkable rep => Result -> TypeM rep () -checkResult = mapM_ checkSubExp +checkResult = mapM_ checkSubExpRes checkFunBody :: Checkable rep => @@ -737,7 +746,7 @@ context "When checking body result" $ checkResult res context "When matching declared return type to result of body" $ matchReturnType rt res - map (`namesSubtract` bound_here) <$> mapM subExpAliasesM res + map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res where bound_here = namesFromList $ M.keys $ scopeOf bnds @@ -750,7 +759,7 @@ checkBodyDec rep checkStms bnds $ do checkLambdaResult ret res - map (`namesSubtract` bound_here) <$> mapM subExpAliasesM res + map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res where bound_here = namesFromList $ M.keys $ scopeOf bnds @@ -771,7 +780,7 @@ ++ " values: " ++ prettyTuple es | otherwise = forM_ (zip ts es) $ \(t, e) -> do - et <- checkSubExp e + et <- checkSubExpRes e unless (et == t) $ bad $ TypeError $ @@ -787,14 +796,14 @@ checkBodyDec rep checkStms bnds $ do checkResult res - map (`namesSubtract` bound_here) <$> mapM subExpAliasesM res + map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res where bound_here = namesFromList $ M.keys $ scopeOf bnds checkBasicOp :: Checkable rep => BasicOp -> TypeM rep () checkBasicOp (SubExp es) = void $ checkSubExp es -checkBasicOp (Opaque es) = +checkBasicOp (Opaque _ es) = void $ checkSubExp es checkBasicOp (ArrayLit [] _) = return () @@ -818,13 +827,13 @@ checkBasicOp (BinOp op e1 e2) = checkBinOpArgs (binOpType op) e1 e2 checkBasicOp (CmpOp op e1 e2) = checkCmpOp op e1 e2 checkBasicOp (ConvOp op e) = require [Prim $ fst $ convOpType op] e -checkBasicOp (Index ident idxes) = do +checkBasicOp (Index ident (Slice idxes)) = do vt <- lookupType ident observe ident when (arrayRank vt /= length idxes) $ bad $ SlicingError (arrayRank vt) (length idxes) mapM_ checkDimIndex idxes -checkBasicOp (Update src idxes se) = do +checkBasicOp (Update _ src (Slice idxes) se) = do src_t <- checkArrIdent src when (arrayRank src_t /= length idxes) $ bad $ SlicingError (arrayRank src_t) (length idxes) @@ -834,8 +843,26 @@ bad $ TypeError "The target of an Update must not alias the value to be written." mapM_ checkDimIndex idxes - require [arrayOf (Prim (elemType src_t)) (Shape (sliceDims idxes)) NoUniqueness] se + require [arrayOf (Prim (elemType src_t)) (Shape (sliceDims (Slice idxes))) NoUniqueness] se consume =<< lookupAliases src +checkBasicOp (FlatIndex ident slice) = do + vt <- lookupType ident + observe ident + when (arrayRank vt /= 1) $ + bad $ SlicingError (arrayRank vt) 1 + checkFlatSlice slice +checkBasicOp (FlatUpdate src slice v) = do + src_t <- checkArrIdent src + when (arrayRank src_t /= 1) $ + bad $ SlicingError (arrayRank src_t) 1 + + v_aliases <- lookupAliases v + when (src `nameIn` v_aliases) $ + bad $ TypeError "The target of an Update must not alias the value to be written." + + checkFlatSlice slice + requireI [arrayOf (Prim (elemType src_t)) (Shape (flatSliceDims slice)) NoUniqueness] v + consume =<< lookupAliases src checkBasicOp (Iota e x s et) = do require [Prim int64] e require [Prim $ IntType et] x @@ -907,8 +934,7 @@ mapM_ checkPart parts where checkPart ErrorString {} = return () - checkPart (ErrorInt32 x) = require [Prim int32] x - checkPart (ErrorInt64 x) = require [Prim int64] x + checkPart (ErrorVal t x) = require [Prim t] x checkBasicOp (UpdateAcc acc is ses) = do (shape, ts) <- checkAccIdent acc @@ -936,17 +962,16 @@ matchLoopResultExt :: Checkable rep => [Param DeclType] -> - [Param DeclType] -> - [SubExp] -> + Result -> TypeM rep () -matchLoopResultExt ctx val loopres = do +matchLoopResultExt merge loopres = do let rettype_ext = - existentialiseExtTypes (map paramName ctx) $ - staticShapes $ map typeOf $ ctx ++ val + existentialiseExtTypes (map paramName merge) $ + staticShapes $ map typeOf merge - bodyt <- mapM subExpType loopres + bodyt <- mapM subExpResType loopres - case instantiateShapes (`maybeNth` loopres) rettype_ext of + case instantiateShapes (fmap resSubExp . (`maybeNth` loopres)) rettype_ext of Nothing -> bad $ ReturnTypeError @@ -977,27 +1002,18 @@ (rettype_derived, paramtypes) <- lookupFun fname $ map fst args argflows <- mapM (checkArg . fst) args when (rettype_derived /= rettype_annot) $ - bad $ - TypeError $ - "Expected apply result type " ++ pretty rettype_derived - ++ " but annotation is " - ++ pretty rettype_annot + bad . TypeError . pretty $ + "Expected apply result type:" + indent 2 (ppr rettype_derived) + "But annotation is:" + indent 2 (ppr rettype_annot) consumeArgs paramtypes argflows -checkExp (DoLoop ctxmerge valmerge form loopbody) = do - let merge = ctxmerge ++ valmerge - (mergepat, mergeexps) = unzip merge +checkExp (DoLoop merge form loopbody) = do + let (mergepat, mergeexps) = unzip merge mergeargs <- mapM checkArg mergeexps - let val_free = freeIn $ map fst valmerge - usedInVal p = paramName p `nameIn` val_free - case find (not . usedInVal . fst) ctxmerge of - Just p -> - bad $ TypeError $ "Loop context parameter " ++ pretty p ++ " unused." - Nothing -> - return () - binding (scopeOf form) $ do - form_consumable <- checkForm merge mergeargs form + form_consumable <- checkForm mergeargs form let rettype = map paramDeclType mergepat consumable = @@ -1022,15 +1038,14 @@ checkResult $ bodyResult loopbody context "When matching result of body with loop parameters" $ - matchLoopResult (map fst ctxmerge) (map fst valmerge) $ - bodyResult loopbody + matchLoopResult (map fst merge) $ bodyResult loopbody let bound_here = namesFromList $ M.keys $ scopeOf $ bodyStms loopbody map (`namesSubtract` bound_here) - <$> mapM subExpAliasesM (bodyResult loopbody) + <$> mapM (subExpAliasesM . resSubExp) (bodyResult loopbody) where checkLoopVar (p, a) = do a_t <- lookupType a @@ -1054,7 +1069,7 @@ "Cannot loop over " ++ pretty a ++ " of type " ++ pretty a_t - checkForm merge mergeargs (ForLoop loopvar it boundexp loopvars) = do + checkForm mergeargs (ForLoop loopvar it boundexp loopvars) = do iparam <- primFParam loopvar $ IntType it let mergepat = map fst merge funparams = iparam : mergepat @@ -1064,7 +1079,7 @@ boundarg <- checkArg boundexp checkFuncall Nothing paramts $ boundarg : mergeargs pure consumable - checkForm merge mergeargs (WhileLoop cond) = do + checkForm mergeargs (WhileLoop cond) = do case find ((== cond) . paramName . fst) merge of Just (condparam, _) -> unless (paramType condparam == Prim Bool) $ @@ -1206,6 +1221,20 @@ context ("When checking pattern element " ++ pretty name) $ checkLetBoundDec name dec +checkFlatDimIndex :: + Checkable rep => + FlatDimIndex SubExp -> + TypeM rep () +checkFlatDimIndex (FlatDimIndex n s) = mapM_ (require [Prim int64]) [n, s] + +checkFlatSlice :: + Checkable rep => + FlatSlice SubExp -> + TypeM rep () +checkFlatSlice (FlatSlice offset idxs) = do + require [Prim int64] offset + mapM_ checkFlatDimIndex idxs + checkDimIndex :: Checkable rep => DimIndex SubExp -> @@ -1218,13 +1247,13 @@ Stm (Aliases rep) -> TypeM rep a -> TypeM rep a -checkStm stm@(Let pat (StmAux (Certificates cs) _ (_, dec)) e) m = do +checkStm stm@(Let pat (StmAux (Certs cs) _ (_, dec)) e) m = do context "When checking certificates" $ mapM_ (requireI [Prim Unit]) cs context "When checking expression annotation" $ checkExpDec dec context ("When matching\n" ++ message " " pat ++ "\nwith\n" ++ message " " e) $ - matchPattern pat e + matchPat pat e binding (maybeWithoutAliases $ scopeOf stm) $ do - mapM_ checkPatElem (patternElements $ removePatternAliases pat) + mapM_ checkPatElem (patElems $ removePatAliases pat) m where -- FIXME: this is wrong. However, the core language type system @@ -1241,14 +1270,14 @@ withoutAliases (LetName (_, ldec)) = LetName (mempty, ldec) withoutAliases info = info -matchExtPattern :: +matchExtPat :: Checkable rep => - Pattern (Aliases rep) -> + Pat (Aliases rep) -> [ExtType] -> TypeM rep () -matchExtPattern pat ts = - unless (expExtTypesFromPattern pat == ts) $ - bad $ InvalidPatternError pat ts Nothing +matchExtPat pat ts = + unless (expExtTypesFromPat pat == ts) $ + bad $ InvalidPatError pat ts Nothing matchExtReturnType :: Checkable rep => @@ -1256,7 +1285,7 @@ Result -> TypeM rep () matchExtReturnType rettype res = do - ts <- mapM subExpType res + ts <- mapM subExpResType res matchExtReturns rettype res ts matchExtBranchType :: @@ -1265,7 +1294,7 @@ Body (Aliases rep) -> TypeM rep () matchExtBranchType rettype (Body _ stms res) = do - ts <- extendedScope (traverse subExpType res) stmscope + ts <- extendedScope (traverse subExpResType res) stmscope matchExtReturns rettype res ts where stmscope = scopeOf stms @@ -1283,32 +1312,16 @@ " " ++ prettyTuple ts ] - let (ctx_res, val_res) = splitFromEnd (length rettype) res - (ctx_ts, val_ts) = splitFromEnd (length rettype) ts - - unless (length val_res == length rettype) problem - - let num_exts = - length $ - S.fromList $ - concatMap (mapMaybe isExt . arrayExtDims) rettype - unless (num_exts == length ctx_res) $ - bad $ - TypeError $ - "Number of context results does not match number of existentials in the return type.\n" - ++ "Type:\n " - ++ prettyTuple rettype - ++ "\ncannot match context parameters:\n " - ++ prettyTuple ctx_res + unless (length res == length rettype) problem - let ctx_vals = zip ctx_res ctx_ts + let ctx_vals = zip res ts instantiateExt i = case maybeNth i ctx_vals of - Just (se, Prim (IntType Int64)) -> return se + Just (SubExpRes _ se, Prim (IntType Int64)) -> return se _ -> problem rettype' <- instantiateShapes instantiateExt rettype - unless (rettype' == val_ts) problem + unless (rettype' == ts) problem validApply :: ArrayShape shape => @@ -1462,15 +1475,11 @@ checkLParamDec :: VName -> LParamInfo rep -> TypeM rep () checkLetBoundDec :: VName -> LetDec rep -> TypeM rep () checkRetType :: [RetType rep] -> TypeM rep () - matchPattern :: Pattern (Aliases rep) -> Exp (Aliases rep) -> TypeM rep () + matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep () primFParam :: VName -> PrimType -> TypeM rep (FParam (Aliases rep)) matchReturnType :: [RetType rep] -> Result -> TypeM rep () matchBranchType :: [BranchType rep] -> Body (Aliases rep) -> TypeM rep () - matchLoopResult :: - [FParam (Aliases rep)] -> - [FParam (Aliases rep)] -> - [SubExp] -> - TypeM rep () + matchLoopResult :: [FParam (Aliases rep)] -> Result -> TypeM rep () default checkExpDec :: ExpDec rep ~ () => ExpDec rep -> TypeM rep () checkExpDec = return @@ -1490,8 +1499,8 @@ default checkRetType :: RetType rep ~ DeclExtType => [RetType rep] -> TypeM rep () checkRetType = mapM_ $ checkExtType . declExtTypeOf - default matchPattern :: Pattern (Aliases rep) -> Exp (Aliases rep) -> TypeM rep () - matchPattern pat = matchExtPattern pat <=< expExtType + default matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep () + matchPat pat = matchExtPat pat <=< expExtType default primFParam :: FParamInfo rep ~ DeclType => VName -> PrimType -> TypeM rep (FParam (Aliases rep)) primFParam name t = return $ Param name (Prim t) @@ -1505,7 +1514,6 @@ default matchLoopResult :: FParamInfo rep ~ DeclType => [FParam (Aliases rep)] -> - [FParam (Aliases rep)] -> - [SubExp] -> + Result -> TypeM rep () matchLoopResult = matchLoopResultExt diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -23,7 +23,7 @@ splitFromEnd, splitAt3, focusNth, - hashIntText, + hashText, unixEnvironment, isEnvVarAtLeast, fancyTerminal, @@ -46,6 +46,7 @@ trim, pmapIO, readFileSafely, + convFloat, UserString, EncodedString, zEncodeString, @@ -58,17 +59,17 @@ import Control.Concurrent import Control.Exception import Control.Monad +import Crypto.Hash.MD5 as MD5 import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 import Data.Char import Data.Either import Data.Function ((&)) import Data.List (foldl', genericDrop, genericSplitAt, sort) import qualified Data.List.NonEmpty as NE -import Data.Map (Map) -import qualified Data.Map as Map +import qualified Data.Map as M import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T @@ -84,7 +85,6 @@ import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe import System.Process.ByteString -import Text.Printf import Text.Read (readMaybe) -- | Like 'nub', but without the quadratic runtime. @@ -171,10 +171,11 @@ | (bef, x : aft) <- genericSplitAt i xs = Just (bef, x, aft) | otherwise = Nothing --- | Convert the given integer (implied to be a hash digest) to a --- hexadecimal non-negative number. -hashIntText :: Int -> T.Text -hashIntText x = T.pack $ printf "%x" (fromIntegral x :: Word) +-- | Compute a hash of a text that is stable across OS versions. +-- Returns the hash as a text as well, ready for human consumption. +hashText :: T.Text -> T.Text +hashText = + T.decodeUtf8With T.lenientDecode . Base16.encode . MD5.hash . T.encodeUtf8 {-# NOINLINE unixEnvironment #-} @@ -358,6 +359,15 @@ | otherwise = return $ Just $ Left $ show e +-- | Convert between different floating-point types, preserving +-- infinities and NaNs. +convFloat :: (RealFloat from, RealFloat to) => from -> to +convFloat v + | isInfinite v, v > 0 = 1 / 0 + | isInfinite v, v < 0 = -1 / 0 + | isNaN v = 0 / 0 + | otherwise = fromRational $ toRational v + -- Z-encoding from https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/SymbolNames -- -- Slightly simplified as we do not need it to deal with tuples and @@ -440,8 +450,8 @@ | length s > n = take (n -3) s ++ "..." | otherwise = s -invertMap :: (Ord v, Ord k) => Map k v -> Map v (Set k) +invertMap :: (Ord v, Ord k) => M.Map k v -> M.Map v (S.Set k) invertMap m = - Map.toList m - & fmap (swap . first Set.singleton) - & foldr (uncurry $ Map.insertWith (<>)) mempty + M.toList m + & fmap (swap . first S.singleton) + & foldr (uncurry $ M.insertWith (<>)) mempty diff --git a/src/Futhark/Util/Console.hs b/src/Futhark/Util/Console.hs --- a/src/Futhark/Util/Console.hs +++ b/src/Futhark/Util/Console.hs @@ -2,7 +2,6 @@ module Futhark.Util.Console ( color, inRed, - inGreen, inBold, ) where @@ -16,10 +15,6 @@ -- | Make the string red. inRed :: String -> String inRed s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset] - --- | Make the string green. -inGreen :: String -> String -inGreen s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset] -- | Make the string bold. inBold :: String -> String 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 @@ -8,6 +8,7 @@ where import Control.Monad.IO.Class +import Data.List (sortBy) import Futhark.Version import System.Console.GetOpt import System.Exit @@ -51,7 +52,13 @@ helpStr :: String -> String -> [OptDescr a] -> IO String helpStr prog usage opts = do let header = unlines ["Usage: " ++ prog ++ " " ++ usage, "Options:"] - return $ usageInfo header opts + return $ usageInfo header $ sortBy cmp opts + where + -- Sort first by long option, then by short name, then by description. Hopefully + -- everything has a long option. + cmp (Option _ (a : _) _ _) (Option _ (b : _) _ _) = compare a b + cmp (Option (a : _) _ _ _) (Option (b : _) _ _ _) = compare a b + cmp (Option _ _ _ a) (Option _ _ _ b) = compare a b badOptions :: String -> [String] -> [String] -> [String] -> IO () badOptions usage nonopts errs unrecs = do 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 @@ -22,6 +22,7 @@ import Data.Text (Text) import qualified Data.Text.Lazy as LT +import Numeric.Half import Text.PrettyPrint.Mainland hiding (pretty) import qualified Text.PrettyPrint.Mainland as PP import Text.PrettyPrint.Mainland.Class @@ -47,7 +48,7 @@ prettyDoc = PP.pretty ppTuple' :: Pretty a => [a] -> Doc -ppTuple' ets = braces $ commasep $ map ppr ets +ppTuple' ets = braces $ commasep $ map (align . ppr) ets -- | Prettyprint a list enclosed in curly braces. prettyTuple :: Pretty a => [a] -> String @@ -94,3 +95,6 @@ -- | Like 'commasep', but a newline after every comma. commastack :: [Doc] -> Doc commastack = align . stack . punctuate comma + +instance Pretty Half where + ppr = text . show diff --git a/src/Futhark/Version.hs b/src/Futhark/Version.hs --- a/src/Futhark/Version.hs +++ b/src/Futhark/Version.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -- | This module exports version information about the Futhark -- compiler. @@ -9,36 +8,48 @@ ) where +import qualified Data.ByteString.Char8 as BS +import Data.FileEmbed import Data.Version -import Development.GitRev +import Futhark.Util (trim) +import GitHash import qualified Paths_futhark +{-# NOINLINE version #-} + -- | The version of Futhark that we are using. This is equivalent to -- the version defined in the .cabal file. version :: Version version = Paths_futhark.version --- | The version of Futhark that we are using, as a 'String' +{-# NOINLINE versionString #-} + +-- | The version of Futhark that we are using, as a 'String'. versionString :: String versionString = showVersion version - ++ if used_hash /= "UNKNOWN" - then "\n" ++ gitversion - else "" + ++ gitversion $$tGitInfoCwdTry where - used_hash = take 7 $(gitHash) - - gitversion = + gitversion (Left _) = + case commitIdFromFile of + Nothing -> "" + Just commit -> "\ngit: " <> commit + gitversion (Right gi) = concat - [ "git: ", + [ "\n", + "git: ", branch, - used_hash, + take 7 $ giHash gi, " (", - $(gitCommitDate), + giCommitDate gi, ")", dirty ] - branch - | $(gitBranch) == "master" = "" - | otherwise = $(gitBranch) ++ " @ " - dirty = if $(gitDirtyTracked) then " [modified]" else "" + where + branch + | giBranch gi == "master" = "" + | otherwise = giBranch gi ++ " @ " + dirty = if giDirty gi then " [modified]" else "" + +commitIdFromFile :: Maybe String +commitIdFromFile = trim . BS.unpack <$> $(embedFileIfExists "./commit-id") diff --git a/src/Language/Futhark.hs b/src/Language/Futhark.hs --- a/src/Language/Futhark.hs +++ b/src/Language/Futhark.hs @@ -8,7 +8,7 @@ Slice, AppExp, Exp, - Pattern, + Pat, ModExp, ModParam, SigExp, @@ -47,7 +47,7 @@ type AppExp = AppExpBase Info VName -- | A pattern with type information. -type Pattern = PatternBase Info VName +type Pat = PatBase Info VName -- | An constant declaration with type information. type ValBind = ValBindBase Info VName 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 @@ -33,7 +33,7 @@ -- * Special identifiers defaultEntryPoint, - -- * Integer re-export + -- * Number re-export Int8, Int16, Int32, @@ -42,6 +42,7 @@ Word16, Word32, Word64, + Half, ) where @@ -52,6 +53,7 @@ import Data.Word (Word16, Word32, Word64, Word8) import Futhark.Util.Loc import Futhark.Util.Pretty +import Numeric.Half import Prelude hiding (id, (.)) -- | The uniqueness attribute of a type. This essentially indicates 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 @@ -69,13 +69,13 @@ BreakNaN data ExtOp a - = ExtOpTrace Loc String a - | ExtOpBreak BreakReason (NE.NonEmpty StackFrame) a + = ExtOpTrace String String a + | ExtOpBreak Loc BreakReason (NE.NonEmpty StackFrame) a | ExtOpError InterpreterError instance Functor ExtOp where fmap f (ExtOpTrace w s x) = ExtOpTrace w s $ f x - fmap f (ExtOpBreak why backtrace x) = ExtOpBreak why backtrace $ f x + fmap f (ExtOpBreak w why backtrace x) = ExtOpBreak w why backtrace $ f x fmap _ (ExtOpError err) = ExtOpError err type Stack = [StackFrame] @@ -455,13 +455,9 @@ ss <- map (locStr . srclocOf) <$> stacktrace liftF $ ExtOpError $ InterpreterError $ "Error at\n" ++ prettyStacktrace 0 ss ++ s -trace :: Value -> EvalM () -trace v = do - -- We take the second-to-top element of the stack, because any - -- actual call to 'implicits.trace' is going to be in the trace - -- function in the prelude, which is not interesting. - top <- fromMaybe noLoc . maybeHead . drop 1 <$> stacktrace - liftF $ ExtOpTrace top (prettyOneLine v) () +trace :: String -> Value -> EvalM () +trace w v = do + liftF $ ExtOpTrace w (prettyOneLine v) () typeCheckerEnv :: Env -> T.Env typeCheckerEnv env = @@ -477,16 +473,12 @@ T.envVtable = vtable } -break :: EvalM () -break = do - -- We don't want the env of the function that is calling - -- intrinsics.break, since that is just going to be the boring - -- wrapper function (intrinsics are never called directly). - -- This is why we go a step up the stack. - backtrace <- asks $ drop 1 . fst +break :: Loc -> EvalM () +break loc = do + backtrace <- asks fst case NE.nonEmpty backtrace of Nothing -> return () - Just backtrace' -> liftF $ ExtOpBreak BreakPoint backtrace' () + Just backtrace' -> liftF $ ExtOpBreak loc BreakPoint backtrace' () fromArray :: Value -> (ValueShape, [Value]) fromArray (ValueArray shape as) = (shape, elems as) @@ -509,30 +501,30 @@ f' <- apply noLoc mempty f x apply noLoc mempty f' y -matchPattern :: Env -> Pattern -> Value -> EvalM Env -matchPattern env p v = do +matchPat :: Env -> Pat -> Value -> EvalM Env +matchPat env p v = do m <- runMaybeT $ patternMatch env p v case m of - Nothing -> error $ "matchPattern: missing case for " ++ pretty p ++ " and " ++ pretty v + Nothing -> error $ "matchPat: missing case for " ++ pretty p ++ " and " ++ pretty v Just env' -> return env' -patternMatch :: Env -> Pattern -> Value -> MaybeT EvalM Env +patternMatch :: Env -> Pat -> Value -> MaybeT EvalM Env patternMatch env (Id v (Info t) _) val = lift $ pure $ valEnv (M.singleton v (Just $ T.BoundV [] $ toStruct t, val)) <> env patternMatch env Wildcard {} _ = lift $ pure env -patternMatch env (TuplePattern ps _) (ValueRecord vs) = +patternMatch env (TuplePat ps _) (ValueRecord vs) = foldM (\env' (p, v) -> patternMatch env' p v) env $ zip ps (map snd $ sortFields vs) -patternMatch env (RecordPattern ps _) (ValueRecord vs) = +patternMatch env (RecordPat ps _) (ValueRecord vs) = foldM (\env' (p, v) -> patternMatch env' p v) env $ M.intersectionWith (,) (M.fromList ps) vs -patternMatch env (PatternParens p _) v = patternMatch env p v -patternMatch env (PatternAscription p _ _) v = +patternMatch env (PatParens p _) v = patternMatch env p v +patternMatch env (PatAscription p _ _) v = patternMatch env p v -patternMatch env (PatternLit l t _) v = do +patternMatch env (PatLit l t _) v = do l' <- case l of PatLitInt x -> lift $ eval env $ IntLit x t mempty PatLitFloat x -> lift $ eval env $ FloatLit x t mempty @@ -540,7 +532,7 @@ if v == l' then pure env else mzero -patternMatch env (PatternConstr n _ ps _) (ValueSum _ n' vs) +patternMatch env (PatConstr n _ ps _) (ValueSum _ n' vs) | n == n' = foldM (\env' (p, v) -> patternMatch env' p v) env $ zip ps vs patternMatch _ _ _ = mzero @@ -723,7 +715,7 @@ dim (ConstDim x) = Just $ fromIntegral x dim _ = Nothing -evalFunction :: Env -> [VName] -> [Pattern] -> Exp -> StructType -> EvalM Value +evalFunction :: Env -> [VName] -> [Pat] -> Exp -> StructType -> EvalM Value -- We treat zero-parameter lambdas as simply an expression to -- evaluate immediately. Note that this is *not* the same as a lambda -- that takes an empty tuple '()' as argument! Zero-parameter lambdas @@ -736,7 +728,7 @@ etaExpand vs env' (Scalar (Arrow _ _ pt rt)) = return $ ValueFun $ \v -> do - env'' <- matchPattern env' (Wildcard (Info $ fromStruct pt) noLoc) v + env'' <- matchPat env' (Wildcard (Info $ fromStruct pt) noLoc) v etaExpand (v : vs) env'' rt etaExpand vs env' _ = do f <- eval env' body @@ -744,7 +736,7 @@ evalFunction env missing_sizes (p : ps) body rettype = return $ ValueFun $ \v -> do - env' <- matchPattern env p v + env' <- matchPat env p v -- Fix up the last sizes, if any. let p_t = evalType env $ patternStructType p env'' @@ -756,7 +748,7 @@ evalFunctionBinding :: Env -> [TypeParam] -> - [Pattern] -> + [Pat] -> StructType -> [VName] -> Exp -> @@ -864,7 +856,7 @@ <> "`)" evalAppExp env (LetPat sizes p e body _) = do v <- eval env e - env' <- matchPattern env p v + env' <- matchPat env p v let p_t = evalType env $ patternStructType p v_s = valueShape v env'' = env' <> i64Env (resolveExistentials (map sizeName sizes) p_t v_s) @@ -938,7 +930,7 @@ sparams (patternStructType pat) (valueShape v) - in matchPattern (i64Env sparams' <> env) pat v + in matchPat (i64Env sparams' <> env) pat v inc = (`P.doAdd` Int64Value 1) zero = (`P.doMul` Int64Value 0) @@ -969,14 +961,14 @@ forInLoop in_pat v in_v = do env' <- withLoopParams v - env'' <- matchPattern env' in_pat in_v + env'' <- matchPat env' in_pat in_v eval env'' body evalAppExp env (Match e cs _) = do v <- eval env e match v (NE.toList cs) where match _ [] = - error "Pattern match failure." + error "Pat match failure." match v (c : cs') = do c' <- evalCase v env c case c' of @@ -1041,9 +1033,17 @@ ValuePrim (UnsignedValue (Int16Value v)) -> return $ UnsignedValue $ Int16Value (- v) ValuePrim (UnsignedValue (Int32Value v)) -> return $ UnsignedValue $ Int32Value (- v) ValuePrim (UnsignedValue (Int64Value v)) -> return $ UnsignedValue $ Int64Value (- v) + ValuePrim (FloatValue (Float16Value v)) -> return $ FloatValue $ Float16Value (- v) ValuePrim (FloatValue (Float32Value v)) -> return $ FloatValue $ Float32Value (- v) ValuePrim (FloatValue (Float64Value v)) -> return $ FloatValue $ Float64Value (- v) _ -> error $ "Cannot negate " ++ pretty ev +eval env (Not e _) = do + ev <- eval env e + ValuePrim <$> case ev of + ValuePrim (BoolValue b) -> pure $ BoolValue $ not b + ValuePrim (SignedValue iv) -> pure $ SignedValue $ P.doComplement iv + ValuePrim (UnsignedValue iv) -> pure $ UnsignedValue $ P.doComplement iv + _ -> error $ "Cannot logically negate " ++ pretty ev eval env (Update src is v loc) = maybe oob return =<< updateArray <$> mapM (evalDimIndex env) is <*> eval env src <*> eval env v @@ -1097,7 +1097,19 @@ vs <- mapM (eval env) es shape <- typeValueShape env $ toStruct t return $ ValueSum shape c vs -eval env (Attr _ e _) = eval env e +eval env (Attr (AttrAtom "break") e loc) = do + break (locOf loc) + eval env e +eval env (Attr (AttrAtom "trace") e loc) = do + v <- eval env e + trace (locStr (locOf loc)) v + pure v +eval env (Attr (AttrComp "trace" [AttrAtom tag]) e _) = do + v <- eval env e + trace (nameToString tag) v + pure v +eval env (Attr _ e _) = + eval env e evalCase :: Value -> @@ -1217,6 +1229,7 @@ nanValue :: PrimValue -> Bool nanValue (FloatValue v) = case v of + Float16Value x -> isNaN x Float32Value x -> isNaN x Float64Value x -> isNaN x nanValue _ = False @@ -1227,7 +1240,9 @@ backtrace <- asks fst case NE.nonEmpty backtrace of Nothing -> return () - Just backtrace' -> liftF $ ExtOpBreak BreakNaN backtrace' () + Just backtrace' -> + let loc = stackFrameLoc $ NE.head backtrace' + in liftF $ ExtOpBreak loc BreakNaN backtrace' () breakOnNaN _ _ = return () @@ -1263,7 +1278,8 @@ ] intOp f = sintOp f ++ uintOp f floatOp f = - [ (getF, putF, P.doBinOp (f Float32)), + [ (getF, putF, P.doBinOp (f Float16)), + (getF, putF, P.doBinOp (f Float32)), (getF, putF, P.doBinOp (f Float64)) ] arithOp f g = Just $ bopDef $ intOp f ++ floatOp g @@ -1282,7 +1298,8 @@ (getU, Just . BoolValue, P.doCmpOp (f Int64)) ] floatCmp f = - [ (getF, Just . BoolValue, P.doCmpOp (f Float32)), + [ (getF, Just . BoolValue, P.doCmpOp (f Float16)), + (getF, Just . BoolValue, P.doCmpOp (f Float32)), (getF, Just . BoolValue, P.doCmpOp (f Float64)) ] boolCmp f = [(getB, Just . BoolValue, P.doCmpOp f)] @@ -1349,6 +1366,27 @@ Just [x, y, z, a, b, c] -> f x y z a b c _ -> error $ "Expected sextuple; got: " ++ pretty v + fun7t f = + TermValue Nothing $ + ValueFun $ \v -> + case fromTuple v of + Just [x, y, z, a, b, c, d] -> f x y z a b c d + _ -> error $ "Expected septuple; got: " ++ pretty v + + fun8t f = + TermValue Nothing $ + ValueFun $ \v -> + case fromTuple v of + Just [x, y, z, a, b, c, d, e] -> f x y z a b c d e + _ -> error $ "Expected sextuple; got: " ++ pretty v + + fun10t fun = + TermValue Nothing $ + ValueFun $ \v -> + case fromTuple v of + Just [x, y, z, a, b, c, d, e, f, g] -> fun x y z a b c d e f g + _ -> error $ "Expected octuple; got: " ++ pretty v + bopDef fs = fun2 $ \x y -> case (x, y) of (ValuePrim x', ValuePrim y') @@ -1677,6 +1715,127 @@ else pure acc _ -> error $ "acc_write invalid arguments: " ++ pretty (acc, i, v) + -- + def "flat_index_2d" = Just . fun6t $ \arr offset n1 s1 n2 s2 -> do + let offset' = asInt64 offset + n1' = asInt64 n1 + n2' = asInt64 n2 + s1' = asInt64 s1 + s2' = asInt64 s2 + shapeFromDims = foldr ShapeDim ShapeLeaf + mk1 = fmap (toArray (shapeFromDims [n1', n2'])) . sequence + mk2 = fmap (toArray $ shapeFromDims [n2']) . sequence + iota x = [0 .. x -1] + f i j = + indexArray [IndexingFix $ offset' + i * s1' + j * s2'] arr + + case mk1 [mk2 [f i j | j <- iota n2'] | i <- iota n1'] of + Just arr' -> pure arr' + Nothing -> + bad mempty mempty $ + "Index out of bounds: " ++ pretty [(n1', s1', n2', s2')] + -- + def "flat_update_2d" = Just . fun5t $ \arr offset s1 s2 v -> do + let offset' = asInt64 offset + s1' = asInt64 s1 + s2' = asInt64 s2 + case valueShape v of + ShapeDim n1 (ShapeDim n2 _) -> do + let iota x = [0 .. x -1] + f arr' (i, j) = + updateArray [IndexingFix $ offset' + i * s1' + j * s2'] arr' + =<< indexArray [IndexingFix i, IndexingFix j] v + case foldM f arr [(i, j) | i <- iota n1, j <- iota n2] of + Just arr' -> pure arr' + Nothing -> + bad mempty mempty $ + "Index out of bounds: " ++ pretty [(n1, s1', n2, s2')] + s -> error $ "flat_update_2d: invalid arg shape: " ++ show s + -- + def "flat_index_3d" = Just . fun8t $ \arr offset n1 s1 n2 s2 n3 s3 -> do + let offset' = asInt64 offset + n1' = asInt64 n1 + n2' = asInt64 n2 + n3' = asInt64 n3 + s1' = asInt64 s1 + s2' = asInt64 s2 + s3' = asInt64 s3 + shapeFromDims = foldr ShapeDim ShapeLeaf + mk1 = fmap (toArray (shapeFromDims [n1', n2', n3'])) . sequence + mk2 = fmap (toArray $ shapeFromDims [n2', n3']) . sequence + mk3 = fmap (toArray $ shapeFromDims [n3']) . sequence + iota x = [0 .. x -1] + f i j l = + indexArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr + + case mk1 [mk2 [mk3 [f i j l | l <- iota n3'] | j <- iota n2'] | i <- iota n1'] of + Just arr' -> pure arr' + Nothing -> + bad mempty mempty $ + "Index out of bounds: " ++ pretty [(n1', s1', n2', s2', n3', s3')] + -- + def "flat_update_3d" = Just . fun6t $ \arr offset s1 s2 s3 v -> do + let offset' = asInt64 offset + s1' = asInt64 s1 + s2' = asInt64 s2 + s3' = asInt64 s3 + case valueShape v of + ShapeDim n1 (ShapeDim n2 (ShapeDim n3 _)) -> do + let iota x = [0 .. x -1] + f arr' (i, j, l) = + updateArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr' + =<< indexArray [IndexingFix i, IndexingFix j, IndexingFix l] v + case foldM f arr [(i, j, l) | i <- iota n1, j <- iota n2, l <- iota n3] of + Just arr' -> pure arr' + Nothing -> + bad mempty mempty $ + "Index out of bounds: " ++ pretty [(n1, s1', n2, s2', n3, s3')] + s -> error $ "flat_update_3d: invalid arg shape: " ++ show s + -- + def "flat_index_4d" = Just . fun10t $ \arr offset n1 s1 n2 s2 n3 s3 n4 s4 -> do + let offset' = asInt64 offset + n1' = asInt64 n1 + n2' = asInt64 n2 + n3' = asInt64 n3 + n4' = asInt64 n4 + s1' = asInt64 s1 + s2' = asInt64 s2 + s3' = asInt64 s3 + s4' = asInt64 s4 + shapeFromDims = foldr ShapeDim ShapeLeaf + mk1 = fmap (toArray (shapeFromDims [n1', n2', n3', n4'])) . sequence + mk2 = fmap (toArray $ shapeFromDims [n2', n3', n4']) . sequence + mk3 = fmap (toArray $ shapeFromDims [n3', n4']) . sequence + mk4 = fmap (toArray $ shapeFromDims [n4']) . sequence + iota x = [0 .. x -1] + f i j l m = + indexArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr + + case mk1 [mk2 [mk3 [mk4 [f i j l m | m <- iota n4'] | l <- iota n3'] | j <- iota n2'] | i <- iota n1'] of + Just arr' -> pure arr' + Nothing -> + bad mempty mempty $ + "Index out of bounds: " ++ pretty [(n1', s1', n2', s2', n3', s3', n4', s4')] + -- + def "flat_update_4d" = Just . fun7t $ \arr offset s1 s2 s3 s4 v -> do + let offset' = asInt64 offset + s1' = asInt64 s1 + s2' = asInt64 s2 + s3' = asInt64 s3 + s4' = asInt64 s4 + case valueShape v of + ShapeDim n1 (ShapeDim n2 (ShapeDim n3 (ShapeDim n4 _))) -> do + let iota x = [0 .. x -1] + f arr' (i, j, l, m) = + updateArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr' + =<< indexArray [IndexingFix i, IndexingFix j, IndexingFix l, IndexingFix m] v + case foldM f arr [(i, j, l, m) | i <- iota n1, j <- iota n2, l <- iota n3, m <- iota n4] of + Just arr' -> pure arr' + Nothing -> + bad mempty mempty $ + "Index out of bounds: " ++ pretty [(n1, s1', n2, s2', n3, s3', n4, s4')] + s -> error $ "flat_update_4d: invalid arg shape: " ++ show s + -- def "unzip" = Just $ fun1 $ \x -> do let ShapeDim _ (ShapeRecord fs) = valueShape x @@ -1728,12 +1887,6 @@ rowshape = ShapeDim (asInt64 m) innershape shape = ShapeDim (asInt64 n) rowshape return $ toArray shape $ map (toArray rowshape) $ chunk (asInt m) xs' - def "opaque" = Just $ fun1 return - def "trace" = Just $ fun1 $ \v -> trace v >> return v - def "break" = Just $ - fun1 $ \v -> do - break - return v def "acc" = Nothing def s | nameFromString s `M.member` namesToPrimTypes = Nothing def s = error $ "Missing intrinsic: " ++ s diff --git a/src/Language/Futhark/Parser/Lexer.x b/src/Language/Futhark/Parser/Lexer.x --- a/src/Language/Futhark/Parser/Lexer.x +++ b/src/Language/Futhark/Parser/Lexer.x @@ -23,7 +23,7 @@ import Data.List import Data.Monoid import Data.Either -import Numeric +import Numeric.Half import Language.Futhark.Core (Int8, Int16, Int32, Int64, Word8, Word16, Word32, Word64, @@ -51,9 +51,6 @@ @identifier = [a-zA-Z] [a-zA-Z0-9_']* | "_" [a-zA-Z0-9] [a-zA-Z0-9_']* @qualidentifier = (@identifier ".")+ @identifier -@unop = "!" -@qualunop = (@identifier ".")+ @unop - $opchar = [\+\-\*\/\%\=\!\>\<\|\&\^\.] @binop = ($opchar # \.) $opchar* @qualbinop = (@identifier ".")+ @binop @@ -94,6 +91,7 @@ "..." { tokenC THREE_DOTS } ".." { tokenC TWO_DOTS } "." { tokenC DOT } + "!" { tokenC BANG } @intlit i8 { tokenM $ return . I8LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') } @intlit i16 { tokenM $ return . I16LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') } @@ -105,14 +103,16 @@ @intlit u64 { tokenM $ return . U64LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='u') } @intlit { tokenM $ return . INTLIT . readIntegral . T.filter (/= '_') } + @reallit f16 { tokenM $ fmap F16LIT . tryRead "f16" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } @reallit f32 { tokenM $ fmap F32LIT . tryRead "f32" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } @reallit f64 { tokenM $ fmap F64LIT . tryRead "f64" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } @reallit { tokenM $ fmap FLOATLIT . tryRead "f64" . suffZero . T.filter (/= '_') } + @hexreallit f16 { tokenM $ fmap F16LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 } @hexreallit f32 { tokenM $ fmap F32LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 } @hexreallit f64 { tokenM $ fmap F64LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 } @hexreallit { tokenM $ fmap FLOATLIT . readHexRealLit . T.filter (/= '_') } "'" @charlit "'" { tokenM $ fmap CHARLIT . tryRead "char" } - \" @stringcharlit* \" { tokenM $ fmap STRINGLIT . tryRead "string" } + \" @stringcharlit* \" { tokenM $ fmap (STRINGLIT . T.pack) . tryRead "string" } @identifier { tokenS keyword } @identifier "[" { tokenM $ fmap INDEXING . indexing . T.takeWhile (/='[') } @@ -121,9 +121,6 @@ @qualidentifier "." "(" { tokenM $ fmap (uncurry QUALPAREN) . mkQualId . T.init . T.takeWhile (/='(') } "#" @identifier { tokenS $ CONSTRUCTOR . nameFromText . T.drop 1 } - @unop { tokenS $ UNOP . nameFromText } - @qualunop { tokenM $ fmap (uncurry QUALUNOP) . mkQualId } - @binop { tokenM $ return . symbol [] . nameFromText } @qualbinop { tokenM $ \s -> do (qs,k) <- mkQualId s; return (symbol qs k) } @@ -287,14 +284,12 @@ | INDEXING Name | QUALINDEXING [Name] Name | QUALPAREN [Name] Name - | UNOP Name - | QUALUNOP [Name] Name | SYMBOL BinOp [Name] Name | CONSTRUCTOR Name | PROJ_INTFIELD Name | INTLIT Integer - | STRINGLIT String + | STRINGLIT T.Text | I8LIT Int8 | I16LIT Int16 | I32LIT Int32 @@ -304,6 +299,7 @@ | U32LIT Word32 | U64LIT Word64 | FLOATLIT Double + | F16LIT Half | F32LIT Float | F64LIT Double | CHARLIT Char @@ -335,6 +331,7 @@ | EQU | ASTERISK | NEGATE + | BANG | LTH | HAT | TILDE 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 @@ -24,8 +24,9 @@ import Control.Monad.Reader import Control.Monad.Trans.State import Data.Array +import qualified Data.ByteString as BS import qualified Data.Text as T -import Codec.Binary.UTF8.String (encode) +import qualified Data.Text.Encoding as T import Data.Char (ord) import Data.Maybe (fromMaybe, fromJust) import Data.List (genericLength) @@ -72,9 +73,6 @@ 'qid.(' { L _ (QUALPAREN _ _) } - unop { L _ (UNOP _) } - qunop { L _ (QUALUNOP _ _) } - constructor { L _ (CONSTRUCTOR _) } '.int' { L _ (PROJ_INTFIELD _) } @@ -89,6 +87,7 @@ u32lit { L _ (U32LIT _) } u64lit { L _ (U64LIT _) } floatlit { L _ (FLOATLIT _) } + f16lit { L _ (F16LIT _) } f32lit { L _ (F32LIT _) } f64lit { L _ (F64LIT _) } stringlit { L _ (STRINGLIT _) } @@ -103,6 +102,7 @@ '*' { L $$ ASTERISK } '-' { L $$ NEGATE } + '!' { L $$ BANG } '<' { L $$ LTH } '^' { L $$ HAT } '~' { L $$ TILDE } @@ -222,7 +222,7 @@ | ModBind { ModDec $1 } | open ModExp { OpenDec $2 $1 } | import stringlit - { let L _ (STRINGLIT s) = $2 in ImportDec s NoInfo (srcspan $1 $>) } + { let L _ (STRINGLIT s) = $2 in ImportDec (T.unpack s) NoInfo (srcspan $1 $>) } | local Dec { LocalDec $2 (srcspan $1 $>) } | '#[' AttrInfo ']' Dec_ { addAttr $2 $4 } @@ -254,7 +254,7 @@ | '\\' ModParam maybeAscription(SimpleSigExp) '->' ModExp { ModLambda $2 (fmap (,NoInfo) $3) $5 (srcspan $1 $>) } | import stringlit - { let L _ (STRINGLIT s) = $2 in ModImport s NoInfo (srcspan $1 $>) } + { let L _ (STRINGLIT s) = $2 in ModImport (T.unpack s) NoInfo (srcspan $1 $>) } | ModExpApply { $1 } | ModExpAtom @@ -302,8 +302,6 @@ in ValSpec name $3 $5 Nothing (srcspan $1 $>) } | val BindingBinOp TypeParams ':' TypeExpDecl { ValSpec $2 $3 $5 Nothing (srcspan $1 $>) } - | val BindingUnOp TypeParams ':' TypeExpDecl - { ValSpec $2 $3 $5 Nothing (srcspan $1 $>) } | TypeAbbr { TypeAbbrSpec $1 } @@ -345,10 +343,6 @@ : TypeParam TypeParams { $1 : $2 } | { [] } -UnOp :: { (QualName Name, SrcLoc) } - : qunop { let L loc (QUALUNOP qs v) = $1 in (QualName qs v, loc) } - | unop { let L loc (UNOP v) = $1 in (qualName v, loc) } - -- Note that this production does not include Minus, but does include -- operator sections. BinOp :: { (QualName Name, SrcLoc) } @@ -381,12 +375,6 @@ | '<' { (qualName (nameFromString "<"), $1) } | '`' QualName '`' { $2 } -BindingUnOp :: { Name } - : UnOp {% let (QualName qs name, loc) = $1 in do - unless (null qs) $ parseErrorAt loc $ - Just "Cannot use a qualified name in binding position." - return name } - BindingBinOp :: { Name } : BinOp {% let (QualName qs name, loc) = $1 in do unless (null qs) $ parseErrorAt loc $ @@ -397,7 +385,6 @@ BindingId :: { (Name, SrcLoc) } : id { let L loc (ID name) = $1 in (name, loc) } | '(' BindingBinOp ')' { ($2, $1) } - | '(' BindingUnOp ')' { ($2, $1) } Val :: { ValBindBase NoInfo Name } Val : let BindingId TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp @@ -416,11 +403,6 @@ Nothing mempty (srcspan $1 $>) } - | let BindingUnOp TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp - { ValBind Nothing $2 (fmap declaredType $5) NoInfo $3 $4 $7 - Nothing mempty (srcspan $1 $>) - } - TypeExpDecl :: { TypeDeclBase NoInfo Name } : TypeExp %prec bottom { TypeDecl $1 NoInfo } @@ -518,14 +500,14 @@ { let L loc (INTLIT n) = $1 in DimExpConst (fromIntegral n) loc } -FunParam :: { PatternBase NoInfo Name } -FunParam : InnerPattern { $1 } +FunParam :: { PatBase NoInfo Name } +FunParam : InnerPat { $1 } -FunParams1 :: { (PatternBase NoInfo Name, [PatternBase NoInfo Name]) } +FunParams1 :: { (PatBase NoInfo Name, [PatBase NoInfo Name]) } FunParams1 : FunParam { ($1, []) } | FunParam FunParams1 { ($1, fst $2 : snd $2) } -FunParams :: { [PatternBase NoInfo Name] } +FunParams :: { [PatBase NoInfo Name] } FunParams : { [] } | FunParam FunParams { $1 : $2 } @@ -549,10 +531,10 @@ : if Exp then Exp else Exp %prec ifprec { AppExp (If $2 $4 $6 (srcspan $1 $>)) NoInfo } - | loop Pattern LoopForm do Exp %prec ifprec + | loop Pat LoopForm do Exp %prec ifprec {% fmap (\t -> AppExp (DoLoop [] $2 t $3 $5 (srcspan $1 $>)) NoInfo) (patternExp $2) } - | loop Pattern '=' Exp LoopForm do Exp %prec ifprec + | loop Pat '=' Exp LoopForm do Exp %prec ifprec { AppExp (DoLoop [] $2 $4 $5 $7 (srcspan $1 $>)) NoInfo } | LetExp %prec letprec { $1 } @@ -602,9 +584,10 @@ | Exp2 '..' Exp2 '..>' Exp2 { AppExp (Range $1 (Just $3) (DownToExclusive $5) (srcspan $1 $>)) NoInfo } | Exp2 '..' Atom {% twoDotsRange $2 } | Atom '..' Exp2 {% twoDotsRange $2 } - | '-' Exp2 - { Negate $2 $1 } + | '-' Exp2 %prec juxtprec { Negate $2 $1 } + | '!' Exp2 %prec juxtprec { Not $2 $1 } + | Exp2 with '[' DimIndices ']' '=' Exp2 { Update $1 $4 $7 (srcspan $1 $>) } @@ -622,8 +605,6 @@ ApplyList :: { [UncheckedExp] } : ApplyList Atom %prec juxtprec { $1 ++ [$2] } - | UnOp Atom %prec juxtprec - { [Var (fst $1) NoInfo (snd $1), $2] } | Atom %prec juxtprec { [$1] } @@ -635,7 +616,7 @@ | intlit { let L loc (INTLIT x) = $1 in IntLit x NoInfo loc } | floatlit { let L loc (FLOATLIT x) = $1 in FloatLit x NoInfo loc } | stringlit { let L loc (STRINGLIT s) = $1 in - StringLit (encode s) loc } + StringLit (BS.unpack (T.encodeUtf8 s)) loc } | '(' Exp ')' FieldAccesses { foldl (\x (y, _) -> Project y x NoInfo (srclocOf x)) (Parens $2 (srcspan $1 ($3:map snd $>))) @@ -659,8 +640,8 @@ QualParens (QualName qs name, loc) $2 (srcspan $1 $>) } -- Operator sections. - | '(' UnOp ')' - { Var (fst $2) NoInfo (srcspan (snd $2) $>) } + | '(' '!' ')' + { Var (qualName "!") NoInfo (srcspan $2 $>) } | '(' '-' ')' { OpSection (qualName (nameFromString "-")) NoInfo (srcspan $1 $>) } | '(' Exp2 '-' ')' @@ -694,6 +675,7 @@ | u32lit { let L loc (U32LIT num) = $1 in (UnsignedValue $ Int32Value $ fromIntegral num, loc) } | u64lit { let L loc (U64LIT num) = $1 in (UnsignedValue $ Int64Value $ fromIntegral num, loc) } + | f16lit { let L loc (F16LIT num) = $1 in (FloatValue $ Float16Value num, loc) } | f32lit { let L loc (F32LIT num) = $1 in (FloatValue $ Float32Value num, loc) } | f64lit { let L loc (F64LIT num) = $1 in (FloatValue $ Float64Value num, loc) } @@ -730,9 +712,9 @@ | Field { [$1] } LetExp :: { UncheckedExp } - : let SizeBinders1 Pattern '=' Exp LetBody + : let SizeBinders1 Pat '=' Exp LetBody { AppExp (LetPat $2 $3 $5 $6 (srcspan $1 $>)) NoInfo } - | let Pattern '=' Exp LetBody + | let Pat '=' Exp LetBody { AppExp (LetPat [] $2 $4 $5 (srcspan $1 $>)) NoInfo } | let id TypeParams FunParams1 maybeAscription(TypeExpDecl) '=' Exp LetBody @@ -760,52 +742,51 @@ | Case Cases { NE.cons $1 $2 } Case :: { CaseBase NoInfo Name } - : case CPattern '->' Exp + : case CPat '->' Exp { let loc = srcspan $1 $> in CasePat $2 $> loc } -CPattern :: { PatternBase NoInfo Name } - : CInnerPattern ':' TypeExpDecl { PatternAscription $1 $3 (srcspan $1 $>) } - | CInnerPattern { $1 } +CPat :: { PatBase NoInfo Name } + : CInnerPat ':' TypeExpDecl { PatAscription $1 $3 (srcspan $1 $>) } + | CInnerPat { $1 } | Constr ConstrFields { let (n, loc) = $1; loc' = srcspan loc $> - in PatternConstr n NoInfo $2 loc'} + in PatConstr n NoInfo $2 loc'} -CPatterns1 :: { [PatternBase NoInfo Name] } - : CPattern { [$1] } - | CPattern ',' CPatterns1 { $1 : $3 } +CPats1 :: { [PatBase NoInfo Name] } + : CPat { [$1] } + | CPat ',' CPats1 { $1 : $3 } -CInnerPattern :: { PatternBase NoInfo Name } +CInnerPat :: { PatBase NoInfo Name } : id { let L loc (ID name) = $1 in Id name NoInfo loc } | '(' BindingBinOp ')' { Id $2 NoInfo (srcspan $1 $>) } - | '(' BindingUnOp ')' { Id $2 NoInfo (srcspan $1 $>) } | '_' { Wildcard NoInfo $1 } - | '(' ')' { TuplePattern [] (srcspan $1 $>) } - | '(' CPattern ')' { PatternParens $2 (srcspan $1 $>) } - | '(' CPattern ',' CPatterns1 ')' { TuplePattern ($2:$4) (srcspan $1 $>) } - | '{' CFieldPatterns '}' { RecordPattern $2 (srcspan $1 $>) } - | CaseLiteral { PatternLit (fst $1) NoInfo (snd $1) } + | '(' ')' { TuplePat [] (srcspan $1 $>) } + | '(' CPat ')' { PatParens $2 (srcspan $1 $>) } + | '(' CPat ',' CPats1 ')' { TuplePat ($2:$4) (srcspan $1 $>) } + | '{' CFieldPats '}' { RecordPat $2 (srcspan $1 $>) } + | CaseLiteral { PatLit (fst $1) NoInfo (snd $1) } | Constr { let (n, loc) = $1 - in PatternConstr n NoInfo [] loc } + in PatConstr n NoInfo [] loc } -ConstrFields :: { [PatternBase NoInfo Name] } - : CInnerPattern { [$1] } - | ConstrFields CInnerPattern { $1 ++ [$2] } +ConstrFields :: { [PatBase NoInfo Name] } + : CInnerPat { [$1] } + | ConstrFields CInnerPat { $1 ++ [$2] } -CFieldPattern :: { (Name, PatternBase NoInfo Name) } - : FieldId '=' CPattern +CFieldPat :: { (Name, PatBase NoInfo Name) } + : FieldId '=' CPat { (fst $1, $3) } | FieldId ':' TypeExpDecl - { (fst $1, PatternAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) } + { (fst $1, PatAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) } | FieldId { (fst $1, Id (fst $1) NoInfo (snd $1)) } -CFieldPatterns :: { [(Name, PatternBase NoInfo Name)] } - : CFieldPatterns1 { $1 } +CFieldPats :: { [(Name, PatBase NoInfo Name)] } + : CFieldPats1 { $1 } | { [] } -CFieldPatterns1 :: { [(Name, PatternBase NoInfo Name)] } - : CFieldPattern ',' CFieldPatterns1 { $1 : $3 } - | CFieldPattern { [$1] } +CFieldPats1 :: { [(Name, PatBase NoInfo Name)] } + : CFieldPat ',' CFieldPats1 { $1 : $3 } + | CFieldPat { [$1] } CaseLiteral :: { (PatLit, SrcLoc) } : PrimLit { (PatLitPrim (fst $1), snd $1) } @@ -817,7 +798,7 @@ LoopForm :: { LoopFormBase NoInfo Name } LoopForm : for VarId '<' Exp { For $2 $4 } - | for Pattern in Exp + | for Pat in Exp { ForIn $2 $4 } | while Exp { While $2 } @@ -860,39 +841,38 @@ : id { let L loc (ID name) = $1 in (name, loc) } | intlit { let L loc (INTLIT n) = $1 in (nameFromString (show n), loc) } -Pattern :: { PatternBase NoInfo Name } -Pattern : InnerPattern ':' TypeExpDecl { PatternAscription $1 $3 (srcspan $1 $>) } - | InnerPattern { $1 } +Pat :: { PatBase NoInfo Name } +Pat : InnerPat ':' TypeExpDecl { PatAscription $1 $3 (srcspan $1 $>) } + | InnerPat { $1 } -Patterns1 :: { [PatternBase NoInfo Name] } - : Pattern { [$1] } - | Pattern ',' Patterns1 { $1 : $3 } +Pats1 :: { [PatBase NoInfo Name] } + : Pat { [$1] } + | Pat ',' Pats1 { $1 : $3 } -InnerPattern :: { PatternBase NoInfo Name } -InnerPattern : id { let L loc (ID name) = $1 in Id name NoInfo loc } +InnerPat :: { PatBase NoInfo Name } +InnerPat : id { let L loc (ID name) = $1 in Id name NoInfo loc } | '(' BindingBinOp ')' { Id $2 NoInfo (srcspan $1 $>) } - | '(' BindingUnOp ')' { Id $2 NoInfo (srcspan $1 $>) } | '_' { Wildcard NoInfo $1 } - | '(' ')' { TuplePattern [] (srcspan $1 $>) } - | '(' Pattern ')' { PatternParens $2 (srcspan $1 $>) } - | '(' Pattern ',' Patterns1 ')' { TuplePattern ($2:$4) (srcspan $1 $>) } - | '{' FieldPatterns '}' { RecordPattern $2 (srcspan $1 $>) } + | '(' ')' { TuplePat [] (srcspan $1 $>) } + | '(' Pat ')' { PatParens $2 (srcspan $1 $>) } + | '(' Pat ',' Pats1 ')' { TuplePat ($2:$4) (srcspan $1 $>) } + | '{' FieldPats '}' { RecordPat $2 (srcspan $1 $>) } -FieldPattern :: { (Name, PatternBase NoInfo Name) } - : FieldId '=' Pattern +FieldPat :: { (Name, PatBase NoInfo Name) } + : FieldId '=' Pat { (fst $1, $3) } | FieldId ':' TypeExpDecl - { (fst $1, PatternAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) } + { (fst $1, PatAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) } | FieldId { (fst $1, Id (fst $1) NoInfo (snd $1)) } -FieldPatterns :: { [(Name, PatternBase NoInfo Name)] } - : FieldPatterns1 { $1 } +FieldPats :: { [(Name, PatBase NoInfo Name)] } + : FieldPats1 { $1 } | { [] } -FieldPatterns1 :: { [(Name, PatternBase NoInfo Name)] } - : FieldPattern ',' FieldPatterns1 { $1 : $3 } - | FieldPattern { [$1] } +FieldPats1 :: { [(Name, PatBase NoInfo Name)] } + : FieldPat ',' FieldPats1 { $1 : $3 } + | FieldPat { [$1] } maybeAscription(p) : ':' p { Just $2 } @@ -932,7 +912,7 @@ StringValue :: { Value } StringValue : stringlit { let L pos (STRINGLIT s) = $1 in - ArrayValue (arrayFromList $ map (PrimValue . UnsignedValue . Int8Value . fromIntegral) $ encode s) $ Scalar $ Prim $ Signed Int32 } + ArrayValue (arrayFromList $ map (PrimValue . UnsignedValue . Int8Value . fromIntegral) $ BS.unpack $ T.encodeUtf8 s) $ Scalar $ Prim $ Signed Int32 } BoolValue :: { Value } BoolValue : true { PrimValue $ BoolValue True } @@ -953,10 +933,13 @@ | u64lit { let L pos (U64LIT num) = $1 in (Int64Value $ fromIntegral num, pos) } FloatLit :: { (FloatValue, SrcLoc) } - : f32lit { let L loc (F32LIT num) = $1 in (Float32Value num, loc) } + : f16lit { let L loc (F16LIT num) = $1 in (Float16Value num, loc) } + | f32lit { let L loc (F32LIT num) = $1 in (Float32Value num, loc) } | f64lit { let L loc (F64LIT num) = $1 in (Float64Value num, loc) } | QualName {% let (qn, loc) = $1 in case qn of + QualName ["f16"] "inf" -> return (Float16Value (1/0), loc) + QualName ["f16"] "nan" -> return (Float16Value (0/0), loc) QualName ["f32"] "inf" -> return (Float32Value (1/0), loc) QualName ["f32"] "nan" -> return (Float32Value (0/0), loc) QualName ["f64"] "inf" -> return (Float64Value (1/0), loc) @@ -1107,13 +1090,13 @@ ap f x = return $ AppExp (Apply f x NoInfo (srcspan f x)) NoInfo -patternExp :: UncheckedPattern -> ParserMonad UncheckedExp +patternExp :: UncheckedPat -> ParserMonad UncheckedExp patternExp (Id v _ loc) = return $ Var (qualName v) NoInfo loc -patternExp (TuplePattern pats loc) = TupLit <$> (mapM patternExp pats) <*> return loc +patternExp (TuplePat pats loc) = TupLit <$> (mapM patternExp pats) <*> return loc patternExp (Wildcard _ loc) = parseErrorAt loc $ Just "cannot have wildcard here." -patternExp (PatternAscription pat _ _) = patternExp pat -patternExp (PatternParens pat _) = patternExp pat -patternExp (RecordPattern fs loc) = RecordLit <$> mapM field fs <*> pure loc +patternExp (PatAscription pat _ _) = patternExp pat +patternExp (PatParens pat _) = patternExp pat +patternExp (RecordPat fs loc) = RecordLit <$> mapM field fs <*> pure loc where field (name, pat) = RecordFieldExplicit name <$> patternExp pat <*> pure loc eof :: Pos -> L Token @@ -1144,6 +1127,7 @@ intNegate (Int64Value v) = Int64Value (-v) floatNegate :: FloatValue -> FloatValue +floatNegate (Float16Value v) = Float16Value (-v) floatNegate (Float32Value v) = Float32Value (-v) floatNegate (Float64Value v) = Float64Value (-v) 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 @@ -15,9 +15,9 @@ ) where -import Codec.Binary.UTF8.String (decode) import Control.Monad import Data.Array +import Data.Char (chr) import Data.Functor import Data.List (intersperse) import qualified Data.List.NonEmpty as NE @@ -320,9 +320,10 @@ text "@" <> parens (align $ ppr t) _ -> mempty pprPrec _ (StringLit s _) = - text $ show $ decode s + text $ show $ map (chr . fromIntegral) s pprPrec _ (Project k e _ _) = ppr e <> text "." <> ppr k pprPrec _ (Negate e _) = text "-" <> ppr e + pprPrec _ (Not e _) = text "-" <> ppr e pprPrec _ (Update src idxs ve _) = ppr src <+> text "with" <+> brackets (commasep (map ppr idxs)) @@ -379,21 +380,21 @@ ppr (PatLitFloat f) = ppr f ppr (PatLitPrim v) = ppr v -instance (Eq vn, IsName vn, Annot f) => Pretty (PatternBase f vn) where - ppr (PatternAscription p t _) = ppr p <> colon <+> align (ppr t) - ppr (PatternParens p _) = parens $ ppr p +instance (Eq vn, IsName vn, Annot f) => Pretty (PatBase f vn) where + ppr (PatAscription p t _) = ppr p <> colon <+> align (ppr t) + ppr (PatParens p _) = parens $ ppr p ppr (Id v t _) = case unAnnot t of Just t' -> parens $ pprName v <> colon <+> align (ppr t') Nothing -> pprName v - ppr (TuplePattern pats _) = parens $ commasep $ map ppr pats - ppr (RecordPattern fs _) = braces $ commasep $ map ppField fs + ppr (TuplePat pats _) = parens $ commasep $ map ppr pats + ppr (RecordPat fs _) = braces $ commasep $ map ppField fs where ppField (name, t) = text (nameToString name) <> equals <> ppr t ppr (Wildcard t _) = case unAnnot t of Just t' -> parens $ text "_" <> colon <+> ppr t' Nothing -> text "_" - ppr (PatternLit e _ _) = ppr e - ppr (PatternConstr n _ ps _) = text "#" <> ppr n <+> sep (map ppr ps) + ppr (PatLit e _ _) = ppr e + ppr (PatConstr n _ ps _) = text "#" <> ppr n <+> sep (map ppr ps) ppAscription :: Pretty t => Maybe t -> Doc ppAscription Nothing = mempty 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 @@ -31,8 +31,8 @@ funType, -- * Queries on patterns and params - patternIdents, - patternNames, + patIdents, + patNames, patternMap, patternType, patternStructType, @@ -53,7 +53,6 @@ foldFunType, typeVars, typeDimNames, - primByteSize, -- * Operations on types peelArray, @@ -96,7 +95,7 @@ UncheckedModExp, UncheckedSigExp, UncheckedTypeParam, - UncheckedPattern, + UncheckedPat, UncheckedValBind, UncheckedDec, UncheckedSpec, @@ -514,6 +513,7 @@ intValueType Int64Value {} = Int64 floatValueType :: FloatValue -> FloatType +floatValueType Float16Value {} = Float16 floatValueType Float32Value {} = Float32 floatValueType Float64Value {} = Float64 @@ -529,17 +529,10 @@ valueType (PrimValue bv) = Scalar $ Prim $ primValueType bv valueType (ArrayValue _ t) = t --- | The size of values of this type, in bytes. -primByteSize :: Num a => PrimType -> a -primByteSize (Signed it) = Primitive.intByteSize it -primByteSize (Unsigned it) = Primitive.intByteSize it -primByteSize (FloatType ft) = Primitive.floatByteSize ft -primByteSize Bool = 1 - -- | The type is leaving a scope, so clean up any aliases that -- reference the bound variables, and turn any dimensions that name -- them into AnyDim instead. -unscopeType :: S.Set VName -> PatternType -> PatternType +unscopeType :: S.Set VName -> PatType -> PatType unscopeType bound_here t = first onDim $ t `addAliases` S.map unbind where unbind (AliasBound v) | v `S.member` bound_here = AliasFree v @@ -551,7 +544,7 @@ -- | The type of an Futhark term. The aliasing will refer to itself, if -- the term is a non-tuple-typed variable. -typeOf :: ExpBase Info VName -> PatternType +typeOf :: ExpBase Info VName -> PatType typeOf (Literal val _) = Scalar $ Prim $ primValueType val typeOf (IntLit _ (Info t) _) = t typeOf (FloatLit _ (Info t) _) = t @@ -578,6 +571,7 @@ typeOf (Var _ (Info t) _) = t typeOf (Ascript e _ _) = typeOf e typeOf (Negate e _) = typeOf e +typeOf (Not e _) = typeOf e typeOf (Update e _ _ _) = typeOf e `setAliases` mempty typeOf (RecordUpdate _ _ _ (Info t) _) = t typeOf (Assert _ e _ _) = typeOf e @@ -585,7 +579,7 @@ unscopeType bound_here $ foldr (arrow . patternParam) t params `setAliases` als where bound_here = - S.map identName (mconcat $ map patternIdents params) + S.map identName (mconcat $ map patIdents params) `S.difference` S.fromList (mapMaybe (named . patternParam) params) arrow (px, tx) y = Scalar $ Arrow () px tx y named (Named x, _) = Just x @@ -626,7 +620,7 @@ ) -- | The type of a function with the given parameters and return type. -funType :: [PatternBase Info VName] -> StructType -> StructType +funType :: [PatBase Info VName] -> StructType -> StructType funType params ret = foldr (arrow . patternParam) ret params where arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt @@ -659,16 +653,16 @@ orderZero (Scalar (Sum cs)) = all (all orderZero) cs -- | Extract all the shape names that occur in a given pattern. -patternDimNames :: PatternBase Info VName -> S.Set VName -patternDimNames (TuplePattern ps _) = foldMap patternDimNames ps -patternDimNames (RecordPattern fs _) = foldMap (patternDimNames . snd) fs -patternDimNames (PatternParens p _) = patternDimNames p +patternDimNames :: PatBase Info VName -> S.Set VName +patternDimNames (TuplePat ps _) = foldMap patternDimNames ps +patternDimNames (RecordPat fs _) = foldMap (patternDimNames . snd) fs +patternDimNames (PatParens p _) = patternDimNames p patternDimNames (Id _ (Info tp) _) = typeDimNames tp patternDimNames (Wildcard (Info tp) _) = typeDimNames tp -patternDimNames (PatternAscription p (TypeDecl _ (Info t)) _) = +patternDimNames (PatAscription p (TypeDecl _ (Info t)) _) = patternDimNames p <> typeDimNames t -patternDimNames (PatternLit _ (Info tp) _) = typeDimNames tp -patternDimNames (PatternConstr _ _ ps _) = foldMap patternDimNames ps +patternDimNames (PatLit _ (Info tp) _) = typeDimNames tp +patternDimNames (PatConstr _ _ ps _) = foldMap patternDimNames ps -- | Extract all the shape names that occur in a given type. typeDimNames :: TypeBase (DimDecl VName) als -> S.Set VName @@ -680,67 +674,67 @@ -- | @patternOrderZero pat@ is 'True' if all of the types in the given pattern -- have order 0. -patternOrderZero :: PatternBase Info vn -> Bool +patternOrderZero :: PatBase Info vn -> Bool patternOrderZero pat = case pat of - TuplePattern ps _ -> all patternOrderZero ps - RecordPattern fs _ -> all (patternOrderZero . snd) fs - PatternParens p _ -> patternOrderZero p + TuplePat ps _ -> all patternOrderZero ps + RecordPat fs _ -> all (patternOrderZero . snd) fs + PatParens p _ -> patternOrderZero p Id _ (Info t) _ -> orderZero t Wildcard (Info t) _ -> orderZero t - PatternAscription p _ _ -> patternOrderZero p - PatternLit _ (Info t) _ -> orderZero t - PatternConstr _ _ ps _ -> all patternOrderZero ps + PatAscription p _ _ -> patternOrderZero p + PatLit _ (Info t) _ -> orderZero t + PatConstr _ _ ps _ -> all patternOrderZero ps -- | The set of identifiers bound in a pattern. -patternIdents :: (Functor f, Ord vn) => PatternBase f vn -> S.Set (IdentBase f vn) -patternIdents (Id v t loc) = S.singleton $ Ident v t loc -patternIdents (PatternParens p _) = patternIdents p -patternIdents (TuplePattern pats _) = mconcat $ map patternIdents pats -patternIdents (RecordPattern fs _) = mconcat $ map (patternIdents . snd) fs -patternIdents Wildcard {} = mempty -patternIdents (PatternAscription p _ _) = patternIdents p -patternIdents PatternLit {} = mempty -patternIdents (PatternConstr _ _ ps _) = mconcat $ map patternIdents ps +patIdents :: (Functor f, Ord vn) => PatBase f vn -> S.Set (IdentBase f vn) +patIdents (Id v t loc) = S.singleton $ Ident v t loc +patIdents (PatParens p _) = patIdents p +patIdents (TuplePat pats _) = mconcat $ map patIdents pats +patIdents (RecordPat fs _) = mconcat $ map (patIdents . snd) fs +patIdents Wildcard {} = mempty +patIdents (PatAscription p _ _) = patIdents p +patIdents PatLit {} = mempty +patIdents (PatConstr _ _ ps _) = mconcat $ map patIdents ps -- | The set of names bound in a pattern. -patternNames :: (Functor f, Ord vn) => PatternBase f vn -> S.Set vn -patternNames (Id v _ _) = S.singleton v -patternNames (PatternParens p _) = patternNames p -patternNames (TuplePattern pats _) = mconcat $ map patternNames pats -patternNames (RecordPattern fs _) = mconcat $ map (patternNames . snd) fs -patternNames Wildcard {} = mempty -patternNames (PatternAscription p _ _) = patternNames p -patternNames PatternLit {} = mempty -patternNames (PatternConstr _ _ ps _) = mconcat $ map patternNames ps +patNames :: (Functor f, Ord vn) => PatBase f vn -> S.Set vn +patNames (Id v _ _) = S.singleton v +patNames (PatParens p _) = patNames p +patNames (TuplePat pats _) = mconcat $ map patNames pats +patNames (RecordPat fs _) = mconcat $ map (patNames . snd) fs +patNames Wildcard {} = mempty +patNames (PatAscription p _ _) = patNames p +patNames PatLit {} = mempty +patNames (PatConstr _ _ ps _) = mconcat $ map patNames ps -- | A mapping from names bound in a map to their identifier. -patternMap :: (Functor f) => PatternBase f VName -> M.Map VName (IdentBase f VName) +patternMap :: (Functor f) => PatBase f VName -> M.Map VName (IdentBase f VName) patternMap pat = M.fromList $ zip (map identName idents) idents where - idents = S.toList $ patternIdents pat + idents = S.toList $ patIdents pat -- | The type of values bound by the pattern. -patternType :: PatternBase Info VName -> PatternType +patternType :: PatBase Info VName -> PatType patternType (Wildcard (Info t) _) = t -patternType (PatternParens p _) = patternType p +patternType (PatParens p _) = patternType p patternType (Id _ (Info t) _) = t -patternType (TuplePattern pats _) = tupleRecord $ map patternType pats -patternType (RecordPattern fs _) = Scalar $ Record $ patternType <$> M.fromList fs -patternType (PatternAscription p _ _) = patternType p -patternType (PatternLit _ (Info t) _) = t -patternType (PatternConstr _ (Info t) _ _) = t +patternType (TuplePat pats _) = tupleRecord $ map patternType pats +patternType (RecordPat fs _) = Scalar $ Record $ patternType <$> M.fromList fs +patternType (PatAscription p _ _) = patternType p +patternType (PatLit _ (Info t) _) = t +patternType (PatConstr _ (Info t) _ _) = t -- | The type matched by the pattern, including shape declarations if present. -patternStructType :: PatternBase Info VName -> StructType +patternStructType :: PatBase Info VName -> StructType patternStructType = toStruct . patternType -- | When viewed as a function parameter, does this pattern correspond -- to a named parameter of some type? -patternParam :: PatternBase Info VName -> (PName, StructType) -patternParam (PatternParens p _) = +patternParam :: PatBase Info VName -> (PName, StructType) +patternParam (PatParens p _) = patternParam p -patternParam (PatternAscription (Id v _ _) td _) = +patternParam (PatAscription (Id v _ _) td _) = (Named v, unInfo $ expandedType td) patternParam (Id v (Info t) _) = (Named v, toStruct t) @@ -790,7 +784,6 @@ M.fromList $ zipWith namify [20 ..] $ map primFun (M.toList Primitive.primFuns) - ++ [("opaque", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)] ++ map unOpFun Primitive.allUnOps ++ map binOpFun Primitive.allBinOps ++ map cmpOpFun Primitive.allCmpOps @@ -1022,12 +1015,91 @@ arr_b $ shape [n] ] $ uarr_a $ shape [k] - ), - ("trace", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a), - ("break", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a) + ) ] + ++ + -- Experimental LMAD ones. + [ ( "flat_index_2d", + IntrinsicPolyFun + [tp_a, sp_n] + [ arr_a $ shape [n], + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64) + ] + $ arr_a $ ShapeDecl [AnyDim Nothing, AnyDim Nothing] + ), + ( "flat_update_2d", + IntrinsicPolyFun + [tp_a, sp_n, sp_k, sp_l] + [ uarr_a $ shape [n], + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + arr_a $ shape [k, l] + ] + $ uarr_a $ shape [n] + ), + ( "flat_index_3d", + IntrinsicPolyFun + [tp_a, sp_n] + [ arr_a $ shape [n], + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64) + ] + $ arr_a $ ShapeDecl [AnyDim Nothing, AnyDim Nothing, AnyDim Nothing] + ), + ( "flat_update_3d", + IntrinsicPolyFun + [tp_a, sp_n, sp_k, sp_l, sp_p] + [ uarr_a $ shape [n], + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + arr_a $ shape [k, l, p] + ] + $ uarr_a $ shape [n] + ), + ( "flat_index_4d", + IntrinsicPolyFun + [tp_a, sp_n] + [ arr_a $ shape [n], + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64) + ] + $ arr_a $ ShapeDecl [AnyDim Nothing, AnyDim Nothing, AnyDim Nothing, AnyDim Nothing] + ), + ( "flat_update_4d", + IntrinsicPolyFun + [tp_a, sp_n, sp_k, sp_l, sp_p, sp_q] + [ uarr_a $ shape [n], + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + Scalar (Prim $ Signed Int64), + arr_a $ shape [k, l, p, q] + ] + $ uarr_a $ shape [n] + ) + ] where - [a, b, n, m, k, l, p] = zipWith VName (map nameFromString ["a", "b", "n", "m", "k", "l", "p"]) [0 ..] + [a, b, n, m, k, l, p, q] = zipWith VName (map nameFromString ["a", "b", "n", "m", "k", "l", "p", "q"]) [0 ..] t_a = TypeVar () Nonunique (typeName a) [] arr_a = Array () Nonunique t_a @@ -1039,7 +1111,7 @@ uarr_b = Array () Unique t_b tp_b = TypeParamType Unlifted b mempty - [sp_n, sp_m, sp_k, sp_l, _sp_p] = map (`TypeParamDim` mempty) [n, m, k, l, p] + [sp_n, sp_m, sp_k, sp_l, sp_p, sp_q] = map (`TypeParamDim` mempty) [n, m, k, l, p, q] shape = ShapeDecl . map (NamedDim . qualName) @@ -1266,7 +1338,7 @@ type UncheckedTypeParam = TypeParamBase Name -- | A pattern with no type annotations. -type UncheckedPattern = PatternBase NoInfo Name +type UncheckedPat = PatBase NoInfo Name -- | A function declaration with no type annotations. type UncheckedValBind = ValBindBase NoInfo Name 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 @@ -48,20 +48,20 @@ sizeDefs (SizeBinder v loc) = M.singleton v $ DefBound $ BoundTerm (Scalar (Prim (Signed Int64))) (locOf loc) -patternDefs :: Pattern -> Defs +patternDefs :: Pat -> Defs patternDefs (Id vn (Info t) loc) = M.singleton vn $ DefBound $ BoundTerm (toStruct t) (locOf loc) -patternDefs (TuplePattern pats _) = +patternDefs (TuplePat pats _) = mconcat $ map patternDefs pats -patternDefs (RecordPattern fields _) = +patternDefs (RecordPat fields _) = mconcat $ map (patternDefs . snd) fields -patternDefs (PatternParens pat _) = +patternDefs (PatParens pat _) = patternDefs pat patternDefs Wildcard {} = mempty -patternDefs PatternLit {} = mempty -patternDefs (PatternAscription pat _ _) = +patternDefs PatLit {} = mempty +patternDefs (PatAscription pat _ _) = patternDefs pat -patternDefs (PatternConstr _ _ pats _) = +patternDefs (PatConstr _ _ pats _) = mconcat $ map patternDefs pats typeParamDefs :: TypeParamBase VName -> Defs @@ -80,7 +80,7 @@ mapOnName = pure, mapOnQualName = pure, mapOnStructType = pure, - mapOnPatternType = pure + mapOnPatType = pure } onExp e' = do modify (<> expDefs e') @@ -241,22 +241,22 @@ Just $ RawAtName qn $ locOf loc inDim _ = Nothing -atPosInPattern :: Pattern -> Pos -> Maybe RawAtPos -atPosInPattern (Id vn _ loc) pos = do +atPosInPat :: Pat -> Pos -> Maybe RawAtPos +atPosInPat (Id vn _ loc) pos = do guard $ loc `contains` pos Just $ RawAtName (qualName vn) $ locOf loc -atPosInPattern (TuplePattern pats _) pos = - msum $ map (`atPosInPattern` pos) pats -atPosInPattern (RecordPattern fields _) pos = - msum $ map ((`atPosInPattern` pos) . snd) fields -atPosInPattern (PatternParens pat _) pos = - atPosInPattern pat pos -atPosInPattern (PatternAscription pat tdecl _) pos = - atPosInPattern pat pos `mplus` atPosInTypeExp (declaredType tdecl) pos -atPosInPattern (PatternConstr _ _ pats _) pos = - msum $ map (`atPosInPattern` pos) pats -atPosInPattern PatternLit {} _ = Nothing -atPosInPattern Wildcard {} _ = Nothing +atPosInPat (TuplePat pats _) pos = + msum $ map (`atPosInPat` pos) pats +atPosInPat (RecordPat fields _) pos = + msum $ map ((`atPosInPat` pos) . snd) fields +atPosInPat (PatParens pat _) pos = + atPosInPat pat pos +atPosInPat (PatAscription pat tdecl _) pos = + atPosInPat pat pos `mplus` atPosInTypeExp (declaredType tdecl) pos +atPosInPat (PatConstr _ _ pats _) pos = + msum $ map (`atPosInPat` pos) pats +atPosInPat PatLit {} _ = Nothing +atPosInPat Wildcard {} _ = Nothing atPosInExp :: Exp -> Pos -> Maybe RawAtPos atPosInExp (Var qn _ loc) pos = do @@ -269,12 +269,12 @@ atPosInExp IntLit {} _ = Nothing atPosInExp FloatLit {} _ = Nothing atPosInExp (AppExp (LetPat _ pat _ _ _) _) pos - | pat `contains` pos = atPosInPattern pat pos + | pat `contains` pos = atPosInPat pat pos 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 - | merge `contains` pos = atPosInPattern merge pos + | merge `contains` pos = atPosInPat merge pos atPosInExp (Ascript _ tdecl _) pos | tdecl `contains` pos = atPosInTypeExp (declaredType tdecl) pos atPosInExp (AppExp (Coerce _ tdecl _) _) pos @@ -293,7 +293,7 @@ mapOnName = pure, mapOnQualName = pure, mapOnStructType = pure, - mapOnPatternType = pure + mapOnPatType = pure } onExp e' = case atPosInExp e' pos of @@ -339,7 +339,7 @@ atPosInValBind :: ValBind -> Pos -> Maybe RawAtPos atPosInValBind vbind pos = - msum (map (`atPosInPattern` pos) (valBindParams vbind)) + msum (map (`atPosInPat` pos) (valBindParams vbind)) `mplus` atPosInExp (valBindBody vbind) pos `mplus` join (atPosInTypeExp <$> valBindRetDecl vbind <*> pure 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 @@ -24,7 +24,6 @@ ShapeDecl (..), shapeRank, stripDims, - unifyShapes, TypeName (..), typeNameFromQualName, qualNameFromTypeName, @@ -35,7 +34,7 @@ TypeArgExp (..), PName (..), ScalarTypeBase (..), - PatternType, + PatType, StructType, ValueType, Diet (..), @@ -63,7 +62,7 @@ CaseBase (..), LoopFormBase (..), PatLit (..), - PatternBase (..), + PatBase (..), -- * Module language SpecBase (..), @@ -128,8 +127,8 @@ Show (f String), Show (f [VName]), Show (f ([VName], [VName])), - Show (f PatternType), - Show (f (PatternType, [VName])), + Show (f PatType), + Show (f (PatType, [VName])), Show (f (StructType, [VName])), Show (f EntryPoint), Show (f StructType), @@ -316,13 +315,6 @@ | i < length l = Just $ ShapeDecl $ drop i l | otherwise = Nothing --- | @unifyShapes x y@ combines @x@ and @y@ to contain their maximum --- common information, and fails if they conflict. -unifyShapes :: ArrayDim dim => ShapeDecl dim -> ShapeDecl dim -> Maybe (ShapeDecl dim) -unifyShapes (ShapeDecl xs) (ShapeDecl ys) = do - guard $ length xs == length ys - ShapeDecl <$> zipWithM unifyDims xs ys - -- | A type name consists of qualifiers (for error messages) and a -- 'VName' (for equality checking). data TypeName = TypeName {typeQuals :: [VName], typeLeaf :: VName} @@ -433,7 +425,7 @@ -- | A type with aliasing information and shape annotations, used for -- describing the type patterns and expressions. -type PatternType = TypeBase (DimDecl VName) Aliasing +type PatType = TypeBase (DimDecl VName) Aliasing -- | A "structural" type with shape annotations and no aliasing -- information, used for declarations. @@ -556,7 +548,7 @@ -- bound to the identifier. data IdentBase f vn = Ident { identName :: vn, - identType :: f PatternType, + identType :: f PatType, identSrcLoc :: SrcLoc } @@ -696,8 +688,10 @@ -- need, so we can pretend that an application expression was really -- bound to a name. data AppExpBase f vn - = -- | The @Maybe VName@ is a possible existential size - -- that is instantiated by this argument.. + = -- | The @Maybe VName@ is a possible existential size that is + -- instantiated by this argument. May have duplicates across the + -- program, but they will all produce the same value (the + -- expressions will be identical). Apply (ExpBase f vn) (ExpBase f vn) @@ -712,14 +706,14 @@ SrcLoc | LetPat [SizeBinder vn] - (PatternBase f vn) + (PatBase f vn) (ExpBase f vn) (ExpBase f vn) SrcLoc | LetFun vn ( [TypeParamBase vn], - [PatternBase f vn], + [PatBase f vn], Maybe (TypeExp vn), f StructType, ExpBase f vn @@ -729,14 +723,14 @@ | If (ExpBase f vn) (ExpBase f vn) (ExpBase f vn) SrcLoc | DoLoop [VName] -- Size parameters. - (PatternBase f vn) -- Merge variable pattern. + (PatBase f vn) -- Merge variable pattern. (ExpBase f vn) -- Initial values of merge variables. (LoopFormBase f vn) -- Do or while loop. (ExpBase f vn) -- Loop body. SrcLoc | BinOp (QualName vn, SrcLoc) - (f PatternType) + (f PatType) (ExpBase f vn, f (StructType, Maybe VName)) (ExpBase f vn, f (StructType, Maybe VName)) SrcLoc @@ -775,7 +769,7 @@ -- annotation encodes the result type, as well as any existential -- sizes that are generated here. data AppRes = AppRes - { appResType :: PatternType, + { appResType :: PatType, appResExt :: [VName] } deriving (Eq, Ord, Show) @@ -790,13 +784,13 @@ data ExpBase f vn = Literal PrimValue SrcLoc | -- | A polymorphic integral literal. - IntLit Integer (f PatternType) SrcLoc + IntLit Integer (f PatType) SrcLoc | -- | A polymorphic decimal literal. - FloatLit Double (f PatternType) SrcLoc + FloatLit Double (f PatType) SrcLoc | -- | A string literal is just a fancy syntax for an array -- of bytes. StringLit [Word8] SrcLoc - | Var (QualName vn) (f PatternType) SrcLoc + | Var (QualName vn) (f PatType) SrcLoc | -- | A parenthesized expression. Parens (ExpBase f vn) SrcLoc | QualParens (QualName vn, SrcLoc) (ExpBase f vn) SrcLoc @@ -806,48 +800,50 @@ RecordLit [FieldBase f vn] SrcLoc | -- | Array literals, e.g., @[ [1+x, 3], [2, 1+4] ]@. -- Second arg is the row type of the rows of the array. - ArrayLit [ExpBase f vn] (f PatternType) SrcLoc + ArrayLit [ExpBase f vn] (f PatType) SrcLoc | -- | An attribute applied to the following expression. Attr AttrInfo (ExpBase f vn) SrcLoc - | Project Name (ExpBase f vn) (f PatternType) SrcLoc + | Project Name (ExpBase f vn) (f PatType) SrcLoc | -- | Numeric negation (ugly special case; Haskell did it first). Negate (ExpBase f vn) SrcLoc + | -- | Logical and bitwise negation. + Not (ExpBase f vn) SrcLoc | -- | Fail if the first expression does not return true, -- and return the value of the second expression if it -- does. Assert (ExpBase f vn) (ExpBase f vn) (f String) SrcLoc | -- | An n-ary value constructor. - Constr Name [ExpBase f vn] (f PatternType) SrcLoc + Constr Name [ExpBase f vn] (f PatType) SrcLoc | Update (ExpBase f vn) (SliceBase f vn) (ExpBase f vn) SrcLoc - | RecordUpdate (ExpBase f vn) [Name] (ExpBase f vn) (f PatternType) SrcLoc + | RecordUpdate (ExpBase f vn) [Name] (ExpBase f vn) (f PatType) SrcLoc | Lambda - [PatternBase f vn] + [PatBase f vn] (ExpBase f vn) (Maybe (TypeExp vn)) (f (Aliasing, StructType)) SrcLoc | -- | @+@; first two types are operands, third is result. - OpSection (QualName vn) (f PatternType) SrcLoc + OpSection (QualName vn) (f PatType) SrcLoc | -- | @2+@; first type is operand, second is result. OpSectionLeft (QualName vn) - (f PatternType) + (f PatType) (ExpBase f vn) (f (PName, StructType, Maybe VName), f (PName, StructType)) - (f PatternType, f [VName]) + (f PatType, f [VName]) SrcLoc | -- | @+2@; first type is operand, second is result. OpSectionRight (QualName vn) - (f PatternType) + (f PatType) (ExpBase f vn) (f (PName, StructType), f (PName, StructType, Maybe VName)) - (f PatternType) + (f PatType) SrcLoc | -- | Field projection as a section: @(.x.y.z)@. - ProjectSection [Name] (f PatternType) SrcLoc + ProjectSection [Name] (f PatType) SrcLoc | -- | Array indexing as a section: @(.[i,j])@. - IndexSection (SliceBase f vn) (f PatternType) SrcLoc + IndexSection (SliceBase f vn) (f PatType) SrcLoc | -- | Type ascription: @e : t@. Ascript (ExpBase f vn) (TypeDeclBase f vn) SrcLoc | AppExp (AppExpBase f vn) (f AppRes) @@ -872,6 +868,7 @@ locOf (Var _ _ loc) = locOf loc locOf (Ascript _ _ loc) = locOf loc locOf (Negate _ pos) = locOf pos + locOf (Not _ pos) = locOf pos locOf (Update _ _ _ pos) = locOf pos locOf (RecordUpdate _ _ _ _ pos) = locOf pos locOf (Lambda _ _ _ _ loc) = locOf loc @@ -888,7 +885,7 @@ -- | An entry in a record literal. data FieldBase f vn = RecordFieldExplicit Name (ExpBase f vn) SrcLoc - | RecordFieldImplicit vn (f PatternType) SrcLoc + | RecordFieldImplicit vn (f PatType) SrcLoc deriving instance Showable f vn => Show (FieldBase f vn) @@ -901,7 +898,7 @@ locOf (RecordFieldImplicit _ _ loc) = locOf loc -- | A case in a match expression. -data CaseBase f vn = CasePat (PatternBase f vn) (ExpBase f vn) SrcLoc +data CaseBase f vn = CasePat (PatBase f vn) (ExpBase f vn) SrcLoc deriving instance Showable f vn => Show (CaseBase f vn) @@ -915,7 +912,7 @@ -- | Whether the loop is a @for@-loop or a @while@-loop. data LoopFormBase f vn = For (IdentBase f vn) (ExpBase f vn) - | ForIn (PatternBase f vn) (ExpBase f vn) + | ForIn (PatBase f vn) (ExpBase f vn) | While (ExpBase f vn) deriving instance Showable f vn => Show (LoopFormBase f vn) @@ -933,31 +930,31 @@ -- | A pattern as used most places where variables are bound (function -- parameters, @let@ expressions, etc). -data PatternBase f vn - = TuplePattern [PatternBase f vn] SrcLoc - | RecordPattern [(Name, PatternBase f vn)] SrcLoc - | PatternParens (PatternBase f vn) SrcLoc - | Id vn (f PatternType) SrcLoc - | Wildcard (f PatternType) SrcLoc -- Nothing, i.e. underscore. - | PatternAscription (PatternBase f vn) (TypeDeclBase f vn) SrcLoc - | PatternLit PatLit (f PatternType) SrcLoc - | PatternConstr Name (f PatternType) [PatternBase f vn] SrcLoc +data PatBase f vn + = TuplePat [PatBase f vn] SrcLoc + | RecordPat [(Name, PatBase f vn)] SrcLoc + | PatParens (PatBase f vn) SrcLoc + | Id vn (f PatType) SrcLoc + | Wildcard (f PatType) SrcLoc -- Nothing, i.e. underscore. + | PatAscription (PatBase f vn) (TypeDeclBase f vn) SrcLoc + | PatLit PatLit (f PatType) SrcLoc + | PatConstr Name (f PatType) [PatBase f vn] SrcLoc -deriving instance Showable f vn => Show (PatternBase f vn) +deriving instance Showable f vn => Show (PatBase f vn) -deriving instance Eq (PatternBase NoInfo VName) +deriving instance Eq (PatBase NoInfo VName) -deriving instance Ord (PatternBase NoInfo VName) +deriving instance Ord (PatBase NoInfo VName) -instance Located (PatternBase f vn) where - locOf (TuplePattern _ loc) = locOf loc - locOf (RecordPattern _ loc) = locOf loc - locOf (PatternParens _ loc) = locOf loc +instance Located (PatBase f vn) where + locOf (TuplePat _ loc) = locOf loc + locOf (RecordPat _ loc) = locOf loc + locOf (PatParens _ loc) = locOf loc locOf (Id _ _ loc) = locOf loc locOf (Wildcard _ loc) = locOf loc - locOf (PatternAscription _ _ loc) = locOf loc - locOf (PatternLit _ _ loc) = locOf loc - locOf (PatternConstr _ _ _ loc) = locOf loc + locOf (PatAscription _ _ loc) = locOf loc + locOf (PatLit _ _ loc) = locOf loc + locOf (PatConstr _ _ _ loc) = locOf loc -- | Documentation strings, including source location. data DocComment = DocComment String SrcLoc @@ -996,7 +993,7 @@ valBindRetDecl :: Maybe (TypeExp vn), valBindRetType :: f (StructType, [VName]), valBindTypeParams :: [TypeParamBase vn], - valBindParams :: [PatternBase f vn], + valBindParams :: [PatBase f vn], valBindBody :: ExpBase f vn, valBindDoc :: Maybe DocComment, valBindAttrs :: [AttrInfo], 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 @@ -41,7 +41,7 @@ mapOnName :: VName -> m VName, mapOnQualName :: QualName VName -> m (QualName VName), mapOnStructType :: StructType -> m StructType, - mapOnPatternType :: PatternType -> m PatternType + mapOnPatType :: PatType -> m PatType } -- | An 'ASTMapper' that just leaves its input unchanged. @@ -52,7 +52,7 @@ mapOnName = return, mapOnQualName = return, mapOnStructType = return, - mapOnPatternType = return + mapOnPatType = return } -- | The class of things that we can map an 'ASTMapper' across. @@ -97,7 +97,7 @@ Coerce <$> mapOnExp tv e <*> astMap tv tdecl <*> pure loc astMap tv (BinOp (fname, fname_loc) t (x, Info (xt, xext)) (y, Info (yt, yext)) loc) = BinOp <$> ((,) <$> mapOnQualName tv fname <*> pure fname_loc) - <*> traverse (mapOnPatternType tv) t + <*> traverse (mapOnPatType tv) t <*> ( (,) <$> mapOnExp tv x <*> (Info <$> ((,) <$> mapOnStructType tv xt <*> pure xext)) ) @@ -116,16 +116,16 @@ instance ASTMappable (ExpBase Info VName) where astMap tv (Var name t loc) = - Var <$> mapOnQualName tv name <*> traverse (mapOnPatternType tv) t + Var <$> mapOnQualName tv name <*> traverse (mapOnPatType tv) t <*> pure loc astMap _ (Literal val loc) = pure $ Literal val loc astMap _ (StringLit vs loc) = pure $ StringLit vs loc astMap tv (IntLit val t loc) = - IntLit val <$> traverse (mapOnPatternType tv) t <*> pure loc + IntLit val <$> traverse (mapOnPatType tv) t <*> pure loc astMap tv (FloatLit val t loc) = - FloatLit val <$> traverse (mapOnPatternType tv) t <*> pure loc + FloatLit val <$> traverse (mapOnPatType tv) t <*> pure loc astMap tv (Parens e loc) = Parens <$> mapOnExp tv e <*> pure loc astMap tv (QualParens (name, nameloc) e loc) = @@ -137,11 +137,13 @@ astMap tv (RecordLit fields loc) = RecordLit <$> astMap tv fields <*> pure loc astMap tv (ArrayLit els t loc) = - ArrayLit <$> mapM (mapOnExp tv) els <*> traverse (mapOnPatternType tv) t <*> pure loc + ArrayLit <$> mapM (mapOnExp tv) els <*> traverse (mapOnPatType tv) t <*> pure loc astMap tv (Ascript e tdecl loc) = Ascript <$> mapOnExp tv e <*> astMap tv tdecl <*> pure loc astMap tv (Negate x loc) = Negate <$> mapOnExp tv x <*> pure loc + astMap tv (Not x loc) = + Not <$> mapOnExp tv x <*> pure loc astMap tv (Update src slice v loc) = Update <$> mapOnExp tv src <*> mapM (astMap tv) slice <*> mapOnExp tv v @@ -149,10 +151,10 @@ astMap tv (RecordUpdate src fs v (Info t) loc) = RecordUpdate <$> mapOnExp tv src <*> pure fs <*> mapOnExp tv v - <*> (Info <$> mapOnPatternType tv t) + <*> (Info <$> mapOnPatType tv t) <*> pure loc astMap tv (Project field e t loc) = - Project field <$> mapOnExp tv e <*> traverse (mapOnPatternType tv) t <*> pure loc + Project field <$> mapOnExp tv e <*> traverse (mapOnPatType tv) t <*> pure loc astMap tv (Assert e1 e2 desc loc) = Assert <$> mapOnExp tv e1 <*> mapOnExp tv e2 <*> pure desc <*> pure loc astMap tv (Lambda params body ret t loc) = @@ -163,36 +165,36 @@ <*> pure loc astMap tv (OpSection name t loc) = OpSection <$> mapOnQualName tv name - <*> traverse (mapOnPatternType tv) t + <*> traverse (mapOnPatType tv) t <*> pure loc astMap tv (OpSectionLeft name t arg (Info (pa, t1a, argext), Info (pb, t1b)) (t2, retext) loc) = OpSectionLeft <$> mapOnQualName tv name - <*> traverse (mapOnPatternType tv) t + <*> traverse (mapOnPatType tv) t <*> mapOnExp tv arg <*> ( (,) <$> (Info <$> ((pa,,) <$> mapOnStructType tv t1a <*> pure argext)) <*> (Info <$> ((pb,) <$> mapOnStructType tv t1b)) ) - <*> ((,) <$> traverse (mapOnPatternType tv) t2 <*> pure retext) + <*> ((,) <$> traverse (mapOnPatType tv) t2 <*> pure retext) <*> pure loc astMap tv (OpSectionRight name t arg (Info (pa, t1a), Info (pb, t1b, argext)) t2 loc) = OpSectionRight <$> mapOnQualName tv name - <*> traverse (mapOnPatternType tv) t + <*> traverse (mapOnPatType tv) t <*> mapOnExp tv arg <*> ( (,) <$> (Info <$> ((pa,) <$> mapOnStructType tv t1a)) <*> (Info <$> ((pb,,) <$> mapOnStructType tv t1b <*> pure argext)) ) - <*> traverse (mapOnPatternType tv) t2 + <*> traverse (mapOnPatType tv) t2 <*> pure loc astMap tv (ProjectSection fields t loc) = - ProjectSection fields <$> traverse (mapOnPatternType tv) t <*> pure loc + ProjectSection fields <$> traverse (mapOnPatType tv) t <*> pure loc astMap tv (IndexSection idxs t loc) = IndexSection <$> mapM (astMap tv) idxs - <*> traverse (mapOnPatternType tv) t + <*> traverse (mapOnPatType tv) t <*> pure loc astMap tv (Constr name es ts loc) = - Constr name <$> traverse (mapOnExp tv) es <*> traverse (mapOnPatternType tv) ts <*> pure loc + Constr name <$> traverse (mapOnExp tv) es <*> traverse (mapOnPatType tv) ts <*> pure loc astMap tv (Attr attr e loc) = Attr attr <$> mapOnExp tv e <*> pure loc astMap tv (AppExp e res) = @@ -255,7 +257,7 @@ instance ASTMappable AppRes where astMap tv (AppRes t ext) = - AppRes <$> mapOnPatternType tv t <*> pure ext + AppRes <$> mapOnPatType tv t <*> pure ext type TypeTraverser f t dim1 als1 dim2 als2 = (TypeName -> f TypeName) -> @@ -302,7 +304,7 @@ where f = fmap typeNameFromQualName . mapOnQualName tv . qualNameFromTypeName -instance ASTMappable PatternType where +instance ASTMappable PatType where astMap tv = traverseType f (astMap tv) (astMap tv) where f = fmap typeNameFromQualName . mapOnQualName tv . qualNameFromTypeName @@ -313,36 +315,36 @@ instance ASTMappable (IdentBase Info VName) where astMap tv (Ident name (Info t) loc) = - Ident <$> mapOnName tv name <*> (Info <$> mapOnPatternType tv t) <*> pure loc + Ident <$> mapOnName tv name <*> (Info <$> mapOnPatType tv t) <*> pure loc instance ASTMappable (SizeBinder VName) where astMap tv (SizeBinder name loc) = SizeBinder <$> mapOnName tv name <*> pure loc -instance ASTMappable (PatternBase Info VName) where +instance ASTMappable (PatBase Info VName) where astMap tv (Id name (Info t) loc) = - Id <$> mapOnName tv name <*> (Info <$> mapOnPatternType tv t) <*> pure loc - astMap tv (TuplePattern pats loc) = - TuplePattern <$> mapM (astMap tv) pats <*> pure loc - astMap tv (RecordPattern fields loc) = - RecordPattern <$> mapM (traverse $ astMap tv) fields <*> pure loc - astMap tv (PatternParens pat loc) = - PatternParens <$> astMap tv pat <*> pure loc - astMap tv (PatternAscription pat t loc) = - PatternAscription <$> astMap tv pat <*> astMap tv t <*> pure loc + Id <$> mapOnName tv name <*> (Info <$> mapOnPatType tv t) <*> pure loc + astMap tv (TuplePat pats loc) = + TuplePat <$> mapM (astMap tv) pats <*> pure loc + astMap tv (RecordPat fields loc) = + RecordPat <$> mapM (traverse $ astMap tv) fields <*> pure loc + astMap tv (PatParens pat loc) = + PatParens <$> astMap tv pat <*> pure loc + astMap tv (PatAscription pat t loc) = + PatAscription <$> astMap tv pat <*> astMap tv t <*> pure loc astMap tv (Wildcard (Info t) loc) = - Wildcard <$> (Info <$> mapOnPatternType tv t) <*> pure loc - astMap tv (PatternLit v (Info t) loc) = - PatternLit v <$> (Info <$> mapOnPatternType tv t) <*> pure loc - astMap tv (PatternConstr n (Info t) ps loc) = - PatternConstr n <$> (Info <$> mapOnPatternType tv t) <*> mapM (astMap tv) ps <*> pure loc + Wildcard <$> (Info <$> mapOnPatType tv t) <*> pure loc + astMap tv (PatLit v (Info t) loc) = + PatLit v <$> (Info <$> mapOnPatType tv t) <*> pure loc + astMap tv (PatConstr n (Info t) ps loc) = + PatConstr n <$> (Info <$> mapOnPatType tv t) <*> mapM (astMap tv) ps <*> pure loc instance ASTMappable (FieldBase Info VName) where astMap tv (RecordFieldExplicit name e loc) = RecordFieldExplicit name <$> mapOnExp tv e <*> pure loc astMap tv (RecordFieldImplicit name t loc) = RecordFieldImplicit <$> mapOnName tv name - <*> traverse (mapOnPatternType tv) t + <*> traverse (mapOnPatType tv) t <*> pure loc instance ASTMappable (CaseBase Info VName) where @@ -380,16 +382,16 @@ bareField (RecordFieldImplicit name _ loc) = RecordFieldImplicit name NoInfo loc -barePat :: PatternBase Info VName -> PatternBase NoInfo VName -barePat (TuplePattern ps loc) = TuplePattern (map barePat ps) loc -barePat (RecordPattern fs loc) = RecordPattern (map (fmap barePat) fs) loc -barePat (PatternParens p loc) = PatternParens (barePat p) loc +barePat :: PatBase Info VName -> PatBase NoInfo VName +barePat (TuplePat ps loc) = TuplePat (map barePat ps) loc +barePat (RecordPat fs loc) = RecordPat (map (fmap barePat) fs) loc +barePat (PatParens p loc) = PatParens (barePat p) loc barePat (Id v _ loc) = Id v NoInfo loc barePat (Wildcard _ loc) = Wildcard NoInfo loc -barePat (PatternAscription pat (TypeDecl t _) loc) = - PatternAscription (barePat pat) (TypeDecl t NoInfo) loc -barePat (PatternLit v _ loc) = PatternLit v NoInfo loc -barePat (PatternConstr c _ ps loc) = PatternConstr c NoInfo (map barePat ps) loc +barePat (PatAscription pat (TypeDecl t _) loc) = + PatAscription (barePat pat) (TypeDecl t NoInfo) loc +barePat (PatLit v _ loc) = PatLit v NoInfo loc +barePat (PatConstr c _ ps loc) = PatConstr c NoInfo (map barePat ps) loc bareDimIndex :: DimIndexBase Info VName -> DimIndexBase NoInfo VName bareDimIndex (DimFix e) = @@ -421,6 +423,7 @@ bareExp (Ascript e tdecl loc) = Ascript (bareExp e) (bareTypeDecl tdecl) loc bareExp (Negate x loc) = Negate (bareExp x) loc +bareExp (Not x loc) = Not (bareExp x) loc bareExp (Update src slice v loc) = Update (bareExp src) (map bareDimIndex slice) (bareExp v) loc bareExp (RecordUpdate src fs v _ loc) = 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 @@ -103,7 +103,9 @@ ModExpBase NoInfo Name -> (Warnings, Either TypeError (MTy, ModExpBase Info VName)) checkModExp files src env me = - second (fmap fst) $ runTypeM env files' (mkInitialImport "") src $ checkOneModExp me + second (fmap fst) . runTypeM env files' (mkInitialImport "") src $ do + (_abs, mty, me') <- checkOneModExp me + pure (mty, me') where files' = M.map fileEnv $ M.fromList files @@ -270,7 +272,7 @@ checkSpecs (ModSpec name sig doc loc : specs) = bindSpaced [(Term, name)] $ do name' <- checkName Term name loc - (mty, sig') <- checkSigExp sig + (_sig_abs, mty, sig') <- checkSigExp sig let senv = mempty { envNameMap = M.singleton (Term, name) $ qualName name', @@ -283,13 +285,13 @@ ModSpec name' sig' doc loc : specs' ) checkSpecs (IncludeSpec e loc : specs) = do - (e_abs, e_env, e') <- checkSigExpToEnv e + (e_abs, env_abs, e_env, e') <- checkSigExpToEnv e - mapM_ (warnIfShadowing . fmap baseName) $ M.keys e_abs + mapM_ (warnIfShadowing . fmap baseName) $ M.keys env_abs (abstypes, env, specs') <- localEnv e_env $ checkSpecs specs return - ( abstypes <> e_abs, + ( e_abs <> env_abs <> abstypes, env <> e_env, IncludeSpec e' loc : specs' ) @@ -300,26 +302,26 @@ warnAbout qn = warn loc $ "Inclusion shadows type" <+> pquote (ppr qn) <+> "." -checkSigExp :: SigExpBase NoInfo Name -> TypeM (MTy, SigExpBase Info VName) +checkSigExp :: SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName) checkSigExp (SigParens e loc) = do - (mty, e') <- checkSigExp e - return (mty, SigParens e' loc) + (abs, mty, e') <- checkSigExp e + return (abs, mty, SigParens e' loc) checkSigExp (SigVar name NoInfo loc) = do (name', mty) <- lookupMTy loc name (mty', substs) <- newNamesForMTy mty - return (mty', SigVar name' (Info substs) loc) + return (mtyAbs mty', mty', SigVar name' (Info substs) loc) checkSigExp (SigSpecs specs loc) = do checkForDuplicateSpecs specs (abstypes, env, specs') <- checkSpecs specs - return (MTy abstypes $ ModEnv env, SigSpecs specs' loc) + return (abstypes, MTy abstypes $ ModEnv env, SigSpecs specs' loc) checkSigExp (SigWith s (TypeRef tname ps td trloc) loc) = do - (s_abs, s_env, s') <- checkSigExpToEnv s + (abs, s_abs, s_env, s') <- checkSigExpToEnv s checkTypeParams ps $ \ps' -> do (td', _) <- bindingTypeParams ps' $ checkTypeDecl td (tname', s_abs', s_env') <- refineEnv loc s_abs s_env tname ps' $ unInfo $ expandedType td' - return (MTy s_abs' $ ModEnv s_env', SigWith s' (TypeRef tname' ps' td' trloc) loc) + return (abs, MTy s_abs' $ ModEnv s_env', SigWith s' (TypeRef tname' ps' td' trloc) loc) checkSigExp (SigArrow maybe_pname e1 e2 loc) = do - (MTy s_abs e1_mod, e1') <- checkSigExp e1 + (e1_abs, MTy s_abs e1_mod, e1') <- checkSigExp e1 (env_for_e2, maybe_pname') <- case maybe_pname of Just pname -> bindSpaced [(Term, pname)] $ do @@ -333,41 +335,48 @@ ) Nothing -> return (mempty, Nothing) - (e2_mod, e2') <- localEnv env_for_e2 $ checkSigExp e2 + (e2_abs, e2_mod, e2') <- localEnv env_for_e2 $ checkSigExp e2 return - ( MTy mempty $ ModFun $ FunSig s_abs e1_mod e2_mod, + ( e1_abs <> e2_abs, + MTy mempty $ ModFun $ FunSig s_abs e1_mod e2_mod, SigArrow maybe_pname' e1' e2' loc ) -checkSigExpToEnv :: SigExpBase NoInfo Name -> TypeM (TySet, Env, SigExpBase Info VName) +checkSigExpToEnv :: + SigExpBase NoInfo Name -> + TypeM (TySet, TySet, Env, SigExpBase Info VName) checkSigExpToEnv e = do - (MTy abs mod, e') <- checkSigExp e + (abs, MTy mod_abs mod, e') <- checkSigExp e case mod of - ModEnv env -> return (abs, env, e') + ModEnv env -> return (abs, mod_abs, env, e') ModFun {} -> unappliedFunctor $ srclocOf e -checkSigBind :: SigBindBase NoInfo Name -> TypeM (Env, SigBindBase Info VName) +checkSigBind :: SigBindBase NoInfo Name -> TypeM (TySet, Env, SigBindBase Info VName) checkSigBind (SigBind name e doc loc) = do - (env, e') <- checkSigExp e + (abs, env, e') <- checkSigExp e bindSpaced [(Signature, name)] $ do name' <- checkName Signature name loc return - ( mempty + ( abs, + mempty { envSigTable = M.singleton name' env, envNameMap = M.singleton (Signature, name) (qualName name') }, SigBind name' e' doc loc ) -checkOneModExp :: ModExpBase NoInfo Name -> TypeM (MTy, ModExpBase Info VName) +checkOneModExp :: + ModExpBase NoInfo Name -> + TypeM (TySet, MTy, ModExpBase Info VName) checkOneModExp (ModParens e loc) = do - (mty, e') <- checkOneModExp e - return (mty, ModParens e' loc) + (abs, mty, e') <- checkOneModExp e + return (abs, mty, ModParens e' loc) checkOneModExp (ModDecs decs loc) = do checkForDuplicateDecs decs (abstypes, env, decs') <- checkDecs decs return - ( MTy abstypes $ ModEnv env, + ( abstypes, + MTy abstypes $ ModEnv env, ModDecs decs' loc ) checkOneModExp (ModVar v loc) = do @@ -377,40 +386,47 @@ && baseTag (qualLeaf v') <= maxIntrinsicTag ) $ typeError loc mempty "The 'intrinsics' module may not be used in module expressions." - return (MTy mempty env, ModVar v' loc) + return (mempty, MTy mempty env, ModVar v' loc) checkOneModExp (ModImport name NoInfo loc) = do (name', env) <- lookupImport loc name return - ( MTy mempty $ ModEnv env, + ( mempty, + MTy mempty $ ModEnv env, ModImport name (Info name') loc ) checkOneModExp (ModApply f e NoInfo NoInfo loc) = do - (f_mty, f') <- checkOneModExp f + (f_abs, f_mty, f') <- checkOneModExp f case mtyMod f_mty of ModFun functor -> do - (e_mty, e') <- checkOneModExp e + (e_abs, e_mty, e') <- checkOneModExp e (mty, psubsts, rsubsts) <- applyFunctor loc functor e_mty - return (mty, ModApply f' e' (Info psubsts) (Info rsubsts) loc) + return + ( mtyAbs mty <> f_abs <> e_abs, + mty, + ModApply f' e' (Info psubsts) (Info rsubsts) loc + ) _ -> typeError loc mempty "Cannot apply non-parametric module." checkOneModExp (ModAscript me se NoInfo loc) = do - (me_mod, me') <- checkOneModExp me - (se_mty, se') <- checkSigExp se + (me_abs, me_mod, me') <- checkOneModExp me + (se_abs, se_mty, se') <- checkSigExp se match_subst <- badOnLeft $ matchMTys me_mod se_mty loc - return (se_mty, ModAscript me' se' (Info match_subst) loc) + return (se_abs <> me_abs, se_mty, ModAscript me' se' (Info match_subst) loc) checkOneModExp (ModLambda param maybe_fsig_e body_e loc) = withModParam param $ \param' param_abs param_mod -> do - (maybe_fsig_e', body_e', mty) <- checkModBody (fst <$> maybe_fsig_e) body_e loc + (abs, maybe_fsig_e', body_e', mty) <- + checkModBody (fst <$> maybe_fsig_e) body_e loc return - ( MTy mempty $ ModFun $ FunSig param_abs param_mod mty, + ( abs, + MTy mempty $ ModFun $ FunSig param_abs param_mod mty, ModLambda param' maybe_fsig_e' body_e' loc ) checkOneModExpToEnv :: ModExpBase NoInfo Name -> TypeM (TySet, Env, ModExpBase Info VName) checkOneModExpToEnv e = do - (MTy abs mod, e') <- checkOneModExp e + (e_abs, MTy abs mod, e') <- checkOneModExp e case mod of - ModEnv env -> return (abs, env, e') + ModEnv env -> pure (e_abs <> abs, env, e') ModFun {} -> unappliedFunctor $ srclocOf e withModParam :: @@ -418,7 +434,7 @@ (ModParamBase Info VName -> TySet -> Mod -> TypeM a) -> TypeM a withModParam (ModParam pname psig_e NoInfo loc) m = do - (MTy p_abs p_mod, psig_e') <- checkSigExp psig_e + (_abs, MTy p_abs p_mod, psig_e') <- checkSigExp psig_e bindSpaced [(Term, pname)] $ do pname' <- checkName Term pname loc let in_body_env = mempty {envModTable = M.singleton pname' p_mod} @@ -439,27 +455,38 @@ ModExpBase NoInfo Name -> SrcLoc -> TypeM - ( Maybe (SigExp, Info (M.Map VName VName)), + ( TySet, + Maybe (SigExp, Info (M.Map VName VName)), ModExp, MTy ) checkModBody maybe_fsig_e body_e loc = do - (body_mty, body_e') <- checkOneModExp body_e + (body_e_abs, body_mty, body_e') <- checkOneModExp body_e case maybe_fsig_e of Nothing -> - return (Nothing, body_e', body_mty) + return + ( mtyAbs body_mty <> body_e_abs, + Nothing, + body_e', + body_mty + ) Just fsig_e -> do - (fsig_mty, fsig_e') <- checkSigExp fsig_e + (fsig_abs, fsig_mty, fsig_e') <- checkSigExp fsig_e fsig_subst <- badOnLeft $ matchMTys body_mty fsig_mty loc - return (Just (fsig_e', Info fsig_subst), body_e', fsig_mty) + return + ( fsig_abs <> body_e_abs, + Just (fsig_e', Info fsig_subst), + body_e', + fsig_mty + ) checkModBind :: ModBindBase NoInfo Name -> TypeM (TySet, Env, ModBindBase Info VName) checkModBind (ModBind name [] maybe_fsig_e e doc loc) = do - (maybe_fsig_e', e', mty) <- checkModBody (fst <$> maybe_fsig_e) e loc + (e_abs, maybe_fsig_e', e', mty) <- checkModBody (fst <$> maybe_fsig_e) e loc bindSpaced [(Term, name)] $ do name' <- checkName Term name loc return - ( mtyAbs mty, + ( e_abs, mempty { envModTable = M.singleton name' $ mtyMod mty, envNameMap = M.singleton (Term, name) $ qualName name' @@ -467,22 +494,23 @@ ModBind name' [] maybe_fsig_e' e' doc loc ) checkModBind (ModBind name (p : ps) maybe_fsig_e body_e doc loc) = do - (params', maybe_fsig_e', body_e', funsig) <- + (abs, params', maybe_fsig_e', body_e', funsig) <- withModParam p $ \p' p_abs p_mod -> withModParams ps $ \params_stuff -> do let (ps', ps_abs, ps_mod) = unzip3 params_stuff - (maybe_fsig_e', body_e', mty) <- checkModBody (fst <$> maybe_fsig_e) body_e loc + (abs, maybe_fsig_e', body_e', mty) <- checkModBody (fst <$> maybe_fsig_e) body_e loc let addParam (x, y) mty' = MTy mempty $ ModFun $ FunSig x y mty' return - ( p' : ps', + ( abs, + p' : ps', maybe_fsig_e', body_e', FunSig p_abs p_mod $ foldr addParam mty $ zip ps_abs ps_mod ) bindSpaced [(Term, name)] $ do name' <- checkName Term name loc - return - ( mempty, + pure + ( abs, mempty { envModTable = M.singleton name' $ ModFun funsig, @@ -559,16 +587,16 @@ TypeBind name' l tps' td' doc loc ) -entryPoint :: [Pattern] -> Maybe (TypeExp VName) -> StructType -> EntryPoint +entryPoint :: [Pat] -> Maybe (TypeExp VName) -> StructType -> EntryPoint entryPoint params orig_ret_te orig_ret = EntryPoint (map patternEntry params ++ more_params) rettype' where (more_params, rettype') = onRetType orig_ret_te orig_ret - patternEntry (PatternParens p _) = + patternEntry (PatParens p _) = patternEntry p - patternEntry (PatternAscription _ tdecl _) = + patternEntry (PatAscription _ tdecl _) = EntryType (unInfo (expandedType tdecl)) (Just (declaredType tdecl)) patternEntry p = EntryType (patternStructType p) Nothing @@ -659,11 +687,11 @@ nastyType' (Just te') _ | niceTypeExp te' = False nastyType' _ t' = nastyType t' -nastyParameter :: Pattern -> Bool +nastyParameter :: Pat -> Bool nastyParameter p = nastyType (patternType p) && not (ascripted p) where - ascripted (PatternAscription _ (TypeDecl te _) _) = niceTypeExp te - ascripted (PatternParens p' _) = ascripted p' + ascripted (PatAscription _ (TypeDecl te _) _) = niceTypeExp te + ascripted (PatParens p' _) = ascripted p' ascripted _ = False niceTypeExp :: TypeExp VName -> Bool @@ -677,8 +705,8 @@ (abs, modenv, struct') <- checkModBind struct return (abs, modenv, ModDec struct') checkOneDec (SigDec sig) = do - (sigenv, sig') <- checkSigBind sig - return (mempty, sigenv, SigDec sig') + (abs, sigenv, sig') <- checkSigBind sig + return (abs, sigenv, SigDec sig') checkOneDec (TypeDec tdec) = do (tenv, tdec') <- checkTypeBind tdec return (mempty, tenv, TypeDec tdec') diff --git a/src/Language/Futhark/TypeChecker/Match.hs b/src/Language/Futhark/TypeChecker/Match.hs --- a/src/Language/Futhark/TypeChecker/Match.hs +++ b/src/Language/Futhark/TypeChecker/Match.hs @@ -50,22 +50,22 @@ instance Pretty Match where ppr = pprMatch (-1) -patternToMatch :: Pattern -> Match +patternToMatch :: Pat -> Match patternToMatch (Id _ (Info t) _) = MatchWild $ toStruct t patternToMatch (Wildcard (Info t) _) = MatchWild $ toStruct t -patternToMatch (PatternParens p _) = patternToMatch p -patternToMatch (PatternAscription p _ _) = patternToMatch p -patternToMatch (PatternLit l (Info t) _) = +patternToMatch (PatParens p _) = patternToMatch p +patternToMatch (PatAscription p _ _) = patternToMatch p +patternToMatch (PatLit l (Info t) _) = MatchConstr (ConstrLit l) [] $ toStruct t -patternToMatch p@(TuplePattern ps _) = +patternToMatch p@(TuplePat ps _) = MatchConstr ConstrTuple (map patternToMatch ps) $ patternStructType p -patternToMatch p@(RecordPattern fs _) = +patternToMatch p@(RecordPat fs _) = MatchConstr (ConstrRecord fnames) (map patternToMatch ps) $ patternStructType p where (fnames, ps) = unzip $ sortFields $ M.fromList fs -patternToMatch (PatternConstr c (Info t) args _) = +patternToMatch (PatConstr c (Info t) args _) = MatchConstr (Constr c) (map patternToMatch args) $ toStruct t isConstr :: Match -> Maybe Name @@ -164,7 +164,7 @@ {-# NOINLINE unmatched #-} -- | Find the unmatched cases. -unmatched :: [Pattern] -> [Match] +unmatched :: [Pat] -> [Match] unmatched orig_ps = -- The algorithm may find duplicate example, which we filter away -- here. 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 @@ -208,7 +208,7 @@ "Cannot refine a type having" <+> tpMsg ps <> " with a type having " <> tpMsg cur_ps <> "." | otherwise = - typeError loc mempty $ ppr tname <+> "is not an abstract type in the module type." + typeError loc mempty $ pquote (ppr tname) <+> "is not an abstract type in the module type." where tpMsg [] = "no type parameters" tpMsg xs = "type parameters" <+> spread (map ppr xs) 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 @@ -40,6 +40,7 @@ MTy (..), anySignedType, anyUnsignedType, + anyIntType, anyFloatType, anyNumberType, anyPrimType, @@ -143,10 +144,7 @@ = TypeM ( ReaderT Context - ( StateT - TypeState - (Except (Warnings, TypeError)) - ) + (StateT TypeState (Except (Warnings, TypeError))) a ) deriving @@ -236,7 +234,7 @@ lookupType :: SrcLoc -> QualName Name -> m (QualName VName, [TypeParam], StructType, Liftedness) lookupMod :: SrcLoc -> QualName Name -> m (QualName VName, Mod) - lookupVar :: SrcLoc -> QualName Name -> m (QualName VName, PatternType) + lookupVar :: SrcLoc -> QualName Name -> m (QualName VName, PatType) checkNamedDim :: SrcLoc -> QualName Name -> m (QualName VName) checkNamedDim loc v = do @@ -469,7 +467,7 @@ where atTopLevel :: (Namespace, Name) -> Bool atTopLevel (Type, _) = True - atTopLevel (Term, v) = v `S.member` (type_names <> binop_names <> unop_names <> fun_names) + atTopLevel (Term, v) = v `S.member` (type_names <> binop_names <> fun_names) where type_names = S.fromList $ map (nameFromString . pretty) anyPrimType binop_names = @@ -477,6 +475,5 @@ map (nameFromString . pretty) [minBound .. (maxBound :: BinOp)] - unop_names = S.fromList $ map nameFromString ["!"] fun_names = S.fromList $ map nameFromString ["shape"] atTopLevel _ = False 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 @@ -158,7 +158,7 @@ | CheckingAscription StructType StructType | CheckingLetGeneralise Name | CheckingParams (Maybe Name) - | CheckingPattern UncheckedPattern InferredType + | CheckingPat UncheckedPat InferredType | CheckingLoopBody StructType StructType | CheckingLoopInitial StructType StructType | CheckingRecordUpdate [Name] StructType StructType @@ -193,10 +193,10 @@ "Invalid use of parameters in" <+> pquote fname' <> "." where fname' = maybe "anonymous function" ppr fname - ppr (CheckingPattern pat NoneInferred) = + ppr (CheckingPat pat NoneInferred) = "Invalid pattern" <+> pquote (ppr pat) <> "." - ppr (CheckingPattern pat (Ascribed t)) = - "Pattern" <+> pquote (ppr pat) + ppr (CheckingPat pat (Ascribed t)) = + "Pat" <+> pquote (ppr pat) <+> "cannot match value of type" indent 2 (ppr t) ppr (CheckingLoopBody expected actual) = @@ -233,7 +233,7 @@ data ValBinding = -- | Aliases in parameters indicate the lexical -- closure. - BoundV Locality [TypeParam] PatternType + BoundV Locality [TypeParam] PatType | OverloadedF [PrimType] [Maybe PrimType] (Maybe PrimType) | EqualityF | WasConsumed SrcLoc @@ -287,14 +287,14 @@ -- | Get the type of an expression, with top level type variables -- substituted. Never call 'typeOf' directly (except in a few -- carefully inspected locations)! -expType :: Exp -> TermTypeM PatternType -expType = normPatternType . typeOf +expType :: Exp -> TermTypeM PatType +expType = normPatType . typeOf -- | Get the type of an expression, with all type variables -- substituted. Slower than 'expType', but sometimes necessary. -- Never call 'typeOf' directly (except in a few carefully inspected -- locations)! -expTypeFully :: Exp -> TermTypeM PatternType +expTypeFully :: Exp -> TermTypeM PatType expTypeFully = normTypeFully . typeOf -- Wrap a function name to give it a vacuous Eq instance for SizeSource. @@ -462,7 +462,7 @@ Just d -> return ( NamedDim $ qualName d, - Nothing + Just d ) -- Any argument sizes created with 'extSize' inside the given action @@ -656,8 +656,8 @@ instantiateTypeScheme :: SrcLoc -> [TypeParam] -> - PatternType -> - TermTypeM ([VName], PatternType) + PatType -> + TermTypeM ([VName], PatType) instantiateTypeScheme loc tparams t = do let tnames = map typeParamName tparams (tparam_names, tparam_substs) <- unzip <$> mapM (instantiateTypeParam loc) tparams @@ -746,12 +746,12 @@ -- Mismatched dimensions are turned into fresh rigid type variables. -- Causes a 'TypeError' if they fail to match, and otherwise returns -- one of them. -unifyBranchTypes :: SrcLoc -> PatternType -> PatternType -> TermTypeM (PatternType, [VName]) +unifyBranchTypes :: SrcLoc -> PatType -> PatType -> TermTypeM (PatType, [VName]) unifyBranchTypes loc t1 t2 = onFailure (CheckingBranches (toStruct t1) (toStruct t2)) $ unifyMostCommon (mkUsage loc "unification of branch results") t1 t2 -unifyBranches :: SrcLoc -> Exp -> Exp -> TermTypeM (PatternType, [VName]) +unifyBranches :: SrcLoc -> Exp -> Exp -> TermTypeM (PatType, [VName]) unifyBranches loc e1 e2 = do e1_t <- expTypeFully e1 e2_t <- expTypeFully e2 @@ -764,7 +764,7 @@ data InferredType = NoneInferred - | Ascribed PatternType + | Ascribed PatType -- All this complexity is just so we can handle un-suffixed numeric -- literals in patterns. @@ -797,56 +797,56 @@ pure $ NamedDim $ qualName v' onDim d = pure d -checkPattern' :: +checkPat' :: [SizeBinder VName] -> - UncheckedPattern -> + UncheckedPat -> InferredType -> - TermTypeM Pattern -checkPattern' sizes (PatternParens p loc) t = - PatternParens <$> checkPattern' sizes p t <*> pure loc -checkPattern' _ (Id name _ loc) _ + TermTypeM Pat +checkPat' sizes (PatParens p loc) t = + PatParens <$> checkPat' sizes p t <*> pure loc +checkPat' _ (Id name _ loc) _ | name' `elem` doNotShadow = typeError loc mempty $ "The" <+> text name' <+> "operator may not be redefined." where name' = nameToString name -checkPattern' _ (Id name NoInfo loc) (Ascribed t) = do +checkPat' _ (Id name NoInfo loc) (Ascribed t) = do name' <- newID name return $ Id name' (Info t) loc -checkPattern' _ (Id name NoInfo loc) NoneInferred = do +checkPat' _ (Id name NoInfo loc) NoneInferred = do name' <- newID name t <- newTypeVar loc "t" return $ Id name' (Info t) loc -checkPattern' _ (Wildcard _ loc) (Ascribed t) = +checkPat' _ (Wildcard _ loc) (Ascribed t) = return $ Wildcard (Info $ t `setUniqueness` Nonunique) loc -checkPattern' _ (Wildcard NoInfo loc) NoneInferred = do +checkPat' _ (Wildcard NoInfo loc) NoneInferred = do t <- newTypeVar loc "t" return $ Wildcard (Info t) loc -checkPattern' sizes (TuplePattern ps loc) (Ascribed t) +checkPat' sizes (TuplePat ps loc) (Ascribed t) | Just ts <- isTupleRecord t, length ts == length ps = - TuplePattern - <$> zipWithM (checkPattern' sizes) ps (map Ascribed ts) + TuplePat + <$> zipWithM (checkPat' sizes) ps (map Ascribed ts) <*> pure loc -checkPattern' sizes p@(TuplePattern ps loc) (Ascribed t) = do +checkPat' sizes p@(TuplePat ps loc) (Ascribed t) = do ps_t <- replicateM (length ps) (newTypeVar loc "t") unify (mkUsage loc "matching a tuple pattern") (tupleRecord ps_t) $ toStruct t t' <- normTypeFully t - checkPattern' sizes p $ Ascribed t' -checkPattern' sizes (TuplePattern ps loc) NoneInferred = - TuplePattern <$> mapM (\p -> checkPattern' sizes p NoneInferred) ps <*> pure loc -checkPattern' _ (RecordPattern p_fs _) _ + checkPat' sizes p $ Ascribed t' +checkPat' sizes (TuplePat ps loc) NoneInferred = + TuplePat <$> mapM (\p -> checkPat' sizes p NoneInferred) ps <*> pure loc +checkPat' _ (RecordPat p_fs _) _ | Just (f, fp) <- find (("_" `isPrefixOf`) . nameToString . fst) p_fs = typeError fp mempty $ "Underscore-prefixed fields are not allowed." "Did you mean" <> dquotes (text (drop 1 (nameToString f)) <> "=_") <> "?" -checkPattern' sizes (RecordPattern p_fs loc) (Ascribed (Scalar (Record t_fs))) +checkPat' sizes (RecordPat p_fs loc) (Ascribed (Scalar (Record t_fs))) | sort (map fst p_fs) == sort (M.keys t_fs) = - RecordPattern . M.toList <$> check <*> pure loc + RecordPat . M.toList <$> check <*> pure loc where check = - traverse (uncurry (checkPattern' sizes)) $ + traverse (uncurry (checkPat' sizes)) $ M.intersectionWith (,) (M.fromList p_fs) (fmap Ascribed t_fs) -checkPattern' sizes p@(RecordPattern fields loc) (Ascribed t) = do +checkPat' sizes p@(RecordPat fields loc) (Ascribed t) = do fields' <- traverse (const $ newTypeVar loc "t") $ M.fromList fields when (sort (M.keys fields') /= sort (map fst fields)) $ @@ -854,12 +854,12 @@ unify (mkUsage loc "matching a record pattern") (Scalar (Record fields')) $ toStruct t t' <- normTypeFully t - checkPattern' sizes p $ Ascribed t' -checkPattern' sizes (RecordPattern fs loc) NoneInferred = - RecordPattern . M.toList - <$> traverse (\p -> checkPattern' sizes p NoneInferred) (M.fromList fs) + checkPat' sizes p $ Ascribed t' +checkPat' sizes (RecordPat fs loc) NoneInferred = + RecordPat . M.toList + <$> traverse (\p -> checkPat' sizes p NoneInferred) (M.fromList fs) <*> pure loc -checkPattern' sizes (PatternAscription p (TypeDecl t NoInfo) loc) maybe_outer_t = do +checkPat' sizes (PatAscription p (TypeDecl t NoInfo) loc) maybe_outer_t = do (t', st_nodims, _) <- checkTypeExp t (st, _) <- instantiateEmptyArrayDims loc "impl" Nonrigid st_nodims @@ -875,7 +875,7 @@ outer_t' <- normTypeFully outer_t case unifyTypesU unifyUniqueness st'' outer_t' of Just outer_t'' -> - PatternAscription <$> checkPattern' sizes p (Ascribed outer_t'') + PatAscription <$> checkPat' sizes p (Ascribed outer_t'') <*> pure (TypeDecl t' (Info st)) <*> pure loc Nothing -> @@ -883,53 +883,53 @@ "Cannot match type" <+> pquote (ppr outer_t') <+> "with expected type" <+> pquote (ppr st'') <> "." NoneInferred -> - PatternAscription <$> checkPattern' sizes p (Ascribed st') + PatAscription <$> checkPat' sizes p (Ascribed st') <*> pure (TypeDecl t' (Info st)) <*> pure loc where unifyUniqueness u1 u2 = if u2 `subuniqueOf` u1 then Just u1 else Nothing -checkPattern' _ (PatternLit l NoInfo loc) (Ascribed t) = do +checkPat' _ (PatLit l NoInfo loc) (Ascribed t) = do t' <- patLitMkType l loc unify (mkUsage loc "matching against literal") t' (toStruct t) - return $ PatternLit l (Info (fromStruct t')) loc -checkPattern' _ (PatternLit l NoInfo loc) NoneInferred = do + return $ PatLit l (Info (fromStruct t')) loc +checkPat' _ (PatLit l NoInfo loc) NoneInferred = do t' <- patLitMkType l loc - return $ PatternLit l (Info (fromStruct t')) loc -checkPattern' sizes (PatternConstr n NoInfo ps loc) (Ascribed (Scalar (Sum cs))) + return $ PatLit l (Info (fromStruct t')) loc +checkPat' sizes (PatConstr n NoInfo ps loc) (Ascribed (Scalar (Sum cs))) | Just ts <- M.lookup n cs = do - ps' <- zipWithM (checkPattern' sizes) ps $ map Ascribed ts - return $ PatternConstr n (Info (Scalar (Sum cs))) ps' loc -checkPattern' sizes (PatternConstr n NoInfo ps loc) (Ascribed t) = do + ps' <- zipWithM (checkPat' sizes) ps $ map Ascribed ts + return $ PatConstr n (Info (Scalar (Sum cs))) ps' loc +checkPat' sizes (PatConstr n NoInfo ps loc) (Ascribed t) = do t' <- newTypeVar loc "t" - ps' <- mapM (\p -> checkPattern' sizes p NoneInferred) ps + ps' <- mapM (\p -> checkPat' sizes p NoneInferred) ps mustHaveConstr usage n t' (patternStructType <$> ps') unify usage t' (toStruct t) t'' <- normTypeFully t - return $ PatternConstr n (Info t'') ps' loc + return $ PatConstr n (Info t'') ps' loc where usage = mkUsage loc "matching against constructor" -checkPattern' sizes (PatternConstr n NoInfo ps loc) NoneInferred = do - ps' <- mapM (\p -> checkPattern' sizes p NoneInferred) ps +checkPat' sizes (PatConstr n NoInfo ps loc) NoneInferred = do + ps' <- mapM (\p -> checkPat' sizes p NoneInferred) ps t <- newTypeVar loc "t" mustHaveConstr usage n t (patternStructType <$> ps') - return $ PatternConstr n (Info $ fromStruct t) ps' loc + return $ PatConstr n (Info $ fromStruct t) ps' loc where usage = mkUsage loc "matching against constructor" -patternNameMap :: Pattern -> NameMap -patternNameMap = M.fromList . map asTerm . S.toList . patternNames +patternNameMap :: Pat -> NameMap +patternNameMap = M.fromList . map asTerm . S.toList . patNames where asTerm v = ((Term, baseName v), qualName v) -checkPattern :: +checkPat :: [SizeBinder VName] -> - UncheckedPattern -> + UncheckedPat -> InferredType -> - (Pattern -> TermTypeM a) -> + (Pat -> TermTypeM a) -> TermTypeM a -checkPattern sizes p t m = do +checkPat sizes p t m = do checkForDuplicateNames [p] - p' <- onFailure (CheckingPattern p t) $ checkPattern' sizes p t + p' <- onFailure (CheckingPat p t) $ checkPat' sizes p t let explicit = mustBeExplicitInType $ patternStructType p' @@ -1047,7 +1047,7 @@ bindingIdent :: IdentBase NoInfo Name -> - PatternType -> + PatType -> (Ident -> TermTypeM a) -> TermTypeM a bindingIdent (Ident v NoInfo vloc) t m = @@ -1058,15 +1058,15 @@ bindingParams :: [UncheckedTypeParam] -> - [UncheckedPattern] -> - ([TypeParam] -> [Pattern] -> TermTypeM a) -> + [UncheckedPat] -> + ([TypeParam] -> [Pat] -> TermTypeM a) -> TermTypeM a bindingParams tps orig_ps m = do checkForDuplicateNames orig_ps checkTypeParams tps $ \tps' -> bindingTypeParams tps' $ do let descend ps' (p : ps) = - checkPattern [] p NoneInferred $ \p' -> - binding (S.toList $ patternIdents p') $ descend (p' : ps') ps + checkPat [] p NoneInferred $ \p' -> + binding (S.toList $ patIdents p') $ descend (p' : ps') ps descend ps' [] = do -- Perform an observation of every type parameter. This -- prevents unused-name warnings for otherwise unused @@ -1101,15 +1101,15 @@ check (SizeBinder v loc) = SizeBinder <$> checkName Term v loc <*> pure loc -bindingPattern :: +bindingPat :: [SizeBinder VName] -> - PatternBase NoInfo Name -> + PatBase NoInfo Name -> InferredType -> - (Pattern -> TermTypeM a) -> + (Pat -> TermTypeM a) -> TermTypeM a -bindingPattern sizes p t m = do +bindingPat sizes p t m = do checkForDuplicateNames [p] - checkPattern sizes p t $ \p' -> binding (S.toList $ patternIdents p') $ do + checkPat sizes p t $ \p' -> binding (S.toList $ patIdents p') $ do -- Perform an observation of every declared dimension. This -- prevents unused-name warnings for otherwise unused dimensions. mapM_ observe $ patternDims p' @@ -1120,10 +1120,10 @@ size : _ -> typeError size mempty $ "Size" <+> ppr size <+> "unused in pattern." -patternDims :: Pattern -> [Ident] -patternDims (PatternParens p _) = patternDims p -patternDims (TuplePattern pats _) = concatMap patternDims pats -patternDims (PatternAscription p (TypeDecl _ (Info t)) _) = +patternDims :: Pat -> [Ident] +patternDims (PatParens p _) = patternDims p +patternDims (TuplePat pats _) = concatMap patternDims pats +patternDims (PatAscription p (TypeDecl _ (Info t)) _) = patternDims p <> mapMaybe (dimIdent (srclocOf p)) (nestedDims t) where dimIdent _ (AnyDim _) = Nothing @@ -1172,7 +1172,7 @@ adjustDims (DimFix {} : idxes') (_ : dims) = adjustDims idxes' dims - -- Pattern match some known slices to be non-existential. + -- Pat match some known slices to be non-existential. adjustDims (DimSlice i j stride : idxes') (_ : dims) | refine_sizes, maybe True ((== Just 0) . isInt64) i, @@ -1205,7 +1205,7 @@ -- The closure of a lambda or local function are those variables that -- it references, and which local to the current top-level function. -lexicalClosure :: [Pattern] -> Occurences -> TermTypeM Aliasing +lexicalClosure :: [Pat] -> Occurences -> TermTypeM Aliasing lexicalClosure params closure = do vtable <- asks $ scopeVtable . termScope let isLocal v = case v `M.lookup` vtable of @@ -1214,9 +1214,9 @@ return $ S.map AliasBound $ S.filter isLocal $ - allOccuring closure S.\\ mconcat (map patternNames params) + allOccuring closure S.\\ mconcat (map patNames params) -noAliasesIfOverloaded :: PatternType -> TermTypeM PatternType +noAliasesIfOverloaded :: PatType -> TermTypeM PatType noAliasesIfOverloaded t@(Scalar (TypeVar _ u tn [])) = do subst <- fmap snd . M.lookup (typeLeaf tn) <$> getConstraints case subst of @@ -1258,8 +1258,8 @@ unscopeType :: SrcLoc -> M.Map VName Ident -> - PatternType -> - TermTypeM (PatternType, [VName]) + PatType -> + TermTypeM (PatType, [VName]) unscopeType tloc unscoped t = do (t', m) <- runStateT (traverseDims onDim t) mempty return (t' `addAliases` S.map unAlias, M.elems m) @@ -1286,7 +1286,7 @@ -- When a function result is not immediately bound to a name, we need -- to invent a name for it so we can track it during aliasing -- (uniqueness-error54.fut, uniqueness-error55.fut). -addResultAliases :: NameReason -> PatternType -> TermTypeM PatternType +addResultAliases :: NameReason -> PatType -> TermTypeM PatType addResultAliases r (Scalar (Record fs)) = Scalar . Record <$> traverse (addResultAliases r) fs addResultAliases r (Scalar (Sum fs)) = @@ -1306,8 +1306,8 @@ -- function", for better error messages. checkApplyExp :: UncheckedExp -> TermTypeM (Exp, ApplyOp) checkApplyExp (AppExp (Apply e1 e2 _ loc) _) = do - (e1', (fname, i)) <- checkApplyExp e1 arg <- checkArg e2 + (e1', (fname, i)) <- checkApplyExp e1 t <- expType e1' (t1, rt, argext, exts) <- checkApply loc (fname, i) t arg rt' <- addResultAliases (NameAppRes fname loc) rt @@ -1545,6 +1545,9 @@ checkExp (Negate arg loc) = do arg' <- require "numeric negation" anyNumberType =<< checkExp arg return $ Negate arg' loc +checkExp (Not arg loc) = do + arg' <- require "logical negation" (Bool : anyIntType) =<< checkExp arg + return $ Not arg' loc checkExp e@(AppExp Apply {} _) = fst <$> checkApplyExp e checkExp (AppExp (LetPat sizes pat e body loc) _) = sequentially (checkExp e) $ \e' e_occs -> do @@ -1558,7 +1561,7 @@ _ -> return () incLevel . bindingSizes sizes $ \sizes' -> - bindingPattern sizes' pat (Ascribed t) $ \pat' -> do + bindingPat sizes' pat (Ascribed t) $ \pat' -> do body' <- checkExp body (body_t, retext) <- unscopeType loc (sizesMap sizes' <> patternMap pat') =<< expTypeFully body' @@ -1930,7 +1933,7 @@ uboundexp' <- require "being the bound in a 'for' loop" anySignedType =<< checkExp uboundexp bound_t <- expTypeFully uboundexp' bindingIdent i bound_t $ \i' -> - noUnique . bindingPattern [] mergepat (Ascribed merge_t) $ + noUnique . bindingPat [] mergepat (Ascribed merge_t) $ \mergepat' -> onlySelfAliasing $ tapOccurences $ do loopbody' <- noSizeEscape $ checkExp loopbody @@ -1948,8 +1951,8 @@ case t of _ | Just t' <- peelArray 1 t -> - bindingPattern [] xpat (Ascribed t') $ \xpat' -> - noUnique . bindingPattern [] mergepat (Ascribed merge_t) $ + bindingPat [] xpat (Ascribed t') $ \xpat' -> + noUnique . bindingPat [] mergepat (Ascribed merge_t) $ \mergepat' -> onlySelfAliasing . tapOccurences $ do loopbody' <- noSizeEscape $ checkExp loopbody (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody' @@ -1964,7 +1967,7 @@ "Iteratee of a for-in loop must be an array, but expression has type" <+> ppr t While cond -> - noUnique . bindingPattern [] mergepat (Ascribed merge_t) $ \mergepat' -> + noUnique . bindingPat [] mergepat (Ascribed merge_t) $ \mergepat' -> onlySelfAliasing . tapOccurences $ sequentially ( checkExp cond @@ -1982,17 +1985,17 @@ mergepat'' <- do loopbody_t <- expTypeFully loopbody' - convergePattern mergepat' (allConsumed bodyflow) loopbody_t $ + convergePat mergepat' (allConsumed bodyflow) loopbody_t $ mkUsage (srclocOf loopbody') "being (part of) the result of the loop body" let consumeMerge (Id _ (Info pt) ploc) mt | unique pt = consume ploc $ aliases mt - consumeMerge (TuplePattern pats _) t + consumeMerge (TuplePat pats _) t | Just ts <- isTupleRecord t = zipWithM_ consumeMerge pats ts - consumeMerge (PatternParens pat _) t = + consumeMerge (PatParens pat _) t = consumeMerge pat t - consumeMerge (PatternAscription pat _ _) t = + consumeMerge (PatAscription pat _ _) t = consumeMerge pat t consumeMerge _ _ = return () @@ -2017,11 +2020,11 @@ -- and matches what happens for function calls. Those arrays that -- really *cannot* be consumed will alias something unconsumable, -- and will be caught that way. - let bound_here = patternNames mergepat'' <> S.fromList sparams <> form_bound + let bound_here = patNames mergepat'' <> S.fromList sparams <> form_bound form_bound = case form' of For v _ -> S.singleton $ identName v - ForIn forpat _ -> patternNames forpat + ForIn forpat _ -> patNames forpat While {} -> mempty loopt' = second (`S.difference` S.map AliasBound bound_here) $ @@ -2042,13 +2045,13 @@ | v `elem` to_hide = AnyDim Nothing onDim d = d - convergePattern pat body_cons body_t body_loc = do - let consumed_merge = patternNames pat `S.intersection` body_cons + convergePat pat body_cons body_t body_loc = do + let consumed_merge = patNames pat `S.intersection` body_cons uniquePat (Wildcard (Info t) wloc) = Wildcard (Info $ t `setUniqueness` Nonunique) wloc - uniquePat (PatternParens p ploc) = - PatternParens (uniquePat p) ploc + uniquePat (PatParens p ploc) = + PatParens (uniquePat p) ploc uniquePat (Id name (Info t) iloc) | name `S.member` consumed_merge = let t' = t `setUniqueness` Unique `setAliases` mempty @@ -2056,15 +2059,15 @@ | otherwise = let t' = t `setUniqueness` Nonunique in Id name (Info t') iloc - uniquePat (TuplePattern pats ploc) = - TuplePattern (map uniquePat pats) ploc - uniquePat (RecordPattern fs ploc) = - RecordPattern (map (fmap uniquePat) fs) ploc - uniquePat (PatternAscription p t ploc) = - PatternAscription p t ploc - uniquePat p@PatternLit {} = p - uniquePat (PatternConstr n t ps ploc) = - PatternConstr n t (map uniquePat ps) ploc + uniquePat (TuplePat pats ploc) = + TuplePat (map uniquePat pats) ploc + uniquePat (RecordPat fs ploc) = + RecordPat (map (fmap uniquePat) fs) ploc + uniquePat (PatAscription p t ploc) = + PatAscription p t ploc + uniquePat p@PatLit {} = p + uniquePat (PatConstr n t ps ploc) = + PatConstr n t (map uniquePat ps) ploc -- Make the pattern unique where needed. pat' = uniquePat pat @@ -2118,21 +2121,21 @@ return $ Id pat_v (Info (combAliases pat_v_t t)) patloc checkMergeReturn (Wildcard (Info pat_v_t) patloc) t = return $ Wildcard (Info (combAliases pat_v_t t)) patloc - checkMergeReturn (PatternParens p _) t = + checkMergeReturn (PatParens p _) t = checkMergeReturn p t - checkMergeReturn (PatternAscription p _ _) t = + checkMergeReturn (PatAscription p _ _) t = checkMergeReturn p t - checkMergeReturn (RecordPattern pfs patloc) (Scalar (Record tfs)) = - RecordPattern . M.toList <$> sequence pfs' <*> pure patloc + checkMergeReturn (RecordPat pfs patloc) (Scalar (Record tfs)) = + RecordPat . M.toList <$> sequence pfs' <*> pure patloc where pfs' = M.intersectionWith checkMergeReturn (M.fromList pfs) tfs - checkMergeReturn (TuplePattern pats patloc) t + checkMergeReturn (TuplePat pats patloc) t | Just ts <- isTupleRecord t = - TuplePattern + TuplePat <$> zipWithM checkMergeReturn pats ts <*> pure patloc checkMergeReturn p _ = @@ -2144,7 +2147,7 @@ let body_cons' = body_cons <> S.map aliasVar pat_cons if body_cons' == body_cons && patternType pat'' == patternType pat then return pat' - else convergePattern pat'' body_cons' body_t body_loc + else convergePat pat'' body_cons' body_t body_loc checkExp (Constr name es NoInfo loc) = do t <- newTypeVar loc "t" es' <- mapM checkExp es @@ -2166,9 +2169,9 @@ Attr info <$> checkExp e <*> pure loc checkCases :: - PatternType -> + PatType -> NE.NonEmpty (CaseBase NoInfo Name) -> - TermTypeM (NE.NonEmpty (CaseBase Info VName), PatternType, [VName]) + TermTypeM (NE.NonEmpty (CaseBase Info VName), PatType, [VName]) checkCases mt rest_cs = case NE.uncons rest_cs of (c, Nothing) -> do @@ -2185,11 +2188,11 @@ return (NE.cons c' cs', t, retext) checkCase :: - PatternType -> + PatType -> CaseBase NoInfo Name -> - TermTypeM (CaseBase Info VName, PatternType, [VName]) + TermTypeM (CaseBase Info VName, PatType, [VName]) checkCase mt (CasePat p e loc) = - bindingPattern [] p (Ascribed mt) $ \p' -> do + bindingPat [] p (Ascribed mt) $ \p' -> do e' <- checkExp e (t, retext) <- unscopeType loc (patternMap p') =<< expTypeFully e' return (CasePat p' e' loc, t, retext) @@ -2203,23 +2206,23 @@ | Unmatched p deriving (Functor, Show) -instance Pretty (Unmatched (PatternBase Info VName)) where +instance Pretty (Unmatched (PatBase Info VName)) where ppr um = case um of (UnmatchedNum p nums) -> ppr' p <+> "where p is not one of" <+> ppr nums (UnmatchedBool p) -> ppr' p (UnmatchedConstr p) -> ppr' p (Unmatched p) -> ppr' p where - ppr' (PatternAscription p t _) = ppr p <> ":" <+> ppr t - ppr' (PatternParens p _) = parens $ ppr' p + ppr' (PatAscription p t _) = ppr p <> ":" <+> ppr t + ppr' (PatParens p _) = parens $ ppr' p ppr' (Id v _ _) = pprName v - ppr' (TuplePattern pats _) = parens $ commasep $ map ppr' pats - ppr' (RecordPattern fs _) = braces $ commasep $ map ppField fs + ppr' (TuplePat pats _) = parens $ commasep $ map ppr' pats + ppr' (RecordPat fs _) = braces $ commasep $ map ppField fs where ppField (name, t) = text (nameToString name) <> equals <> ppr' t ppr' Wildcard {} = "_" - ppr' (PatternLit e _ _) = ppr e - ppr' (PatternConstr n _ ps _) = "#" <> ppr n <+> sep (map ppr' ps) + ppr' (PatLit e _ _) = ppr e + ppr' (PatConstr n _ ps _) = "#" <> ppr n <+> sep (map ppr' ps) checkUnmatched :: Exp -> TermTypeM () checkUnmatched e = void $ checkUnmatched' e >> astMap tv e @@ -2240,7 +2243,7 @@ mapOnName = pure, mapOnQualName = pure, mapOnStructType = pure, - mapOnPatternType = pure + mapOnPatType = pure } checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident @@ -2272,12 +2275,12 @@ occur $ m1flow `seqOccurences` m2flow return b -type Arg = (Exp, PatternType, Occurences, SrcLoc) +type Arg = (Exp, PatType, Occurences, SrcLoc) argExp :: Arg -> Exp argExp (e, _, _, _) = e -argType :: Arg -> PatternType +argType :: Arg -> PatType argType (_, t, _, _) = t checkArg :: UncheckedExp -> TermTypeM Arg @@ -2310,9 +2313,9 @@ checkApply :: SrcLoc -> ApplyOp -> - PatternType -> + PatType -> Arg -> - TermTypeM (PatternType, PatternType, Maybe VName, [VName]) + TermTypeM (PatType, PatType, Maybe VName, [VName]) checkApply loc (fname, _) @@ -2375,7 +2378,7 @@ -- to infer that a function is consuming. unify (mkUsage loc "use as function") (toStruct tfun) $ Scalar $ Arrow mempty Unnamed (toStruct (argType arg) `setUniqueness` Nonunique) tv - tfun' <- normPatternType tfun + tfun' <- normPatType tfun checkApply loc fname tfun' arg checkApply loc (fname, prev_applied) ftype (argexp, _, _, _) = do let fname' = maybe "expression" (pquote . ppr) fname @@ -2426,10 +2429,10 @@ -- an argument the given types to a function with the given return -- type, consuming the argument with the given diet. returnType :: - PatternType -> + PatType -> Diet -> - PatternType -> - PatternType + PatType -> + PatType returnType (Array _ Unique et shape) _ _ = Array mempty Unique et shape returnType (Array als Nonunique et shape) d arg = @@ -2468,7 +2471,7 @@ maskAliases t FuncDiet {} = t maskAliases _ _ = error "Invalid arguments passed to maskAliases." -consumeArg :: SrcLoc -> PatternType -> Diet -> TermTypeM [Occurence] +consumeArg :: SrcLoc -> PatType -> Diet -> TermTypeM [Occurence] consumeArg loc (Scalar (Record ets)) (RecordDiet ds) = concat . M.elems <$> traverse (uncurry $ consumeArg loc) (M.intersectionWith (,) ets ds) consumeArg loc (Array _ Nonunique _ _) Consume = @@ -2637,9 +2640,11 @@ bitWidth ty = 8 * intByteSize ty :: Int inBoundsI x (Signed t) = x >= -2 ^ (bitWidth t - 1) && x < 2 ^ (bitWidth t - 1) inBoundsI x (Unsigned t) = x >= 0 && x < 2 ^ bitWidth t + inBoundsI x (FloatType Float16) = not $ isInfinite (fromIntegral x :: Half) inBoundsI x (FloatType Float32) = not $ isInfinite (fromIntegral x :: Float) inBoundsI x (FloatType Float64) = not $ isInfinite (fromIntegral x :: Double) inBoundsI _ Bool = error "Inferred type of int literal is not a number" + inBoundsF x Float16 = not $ isInfinite (realToFrac x :: Float) inBoundsF x Float32 = not $ isInfinite (realToFrac x :: Float) inBoundsF x Float64 = not $ isInfinite x warnBounds inBounds x ty loc = @@ -2657,14 +2662,14 @@ ( Name, Maybe UncheckedTypeExp, [UncheckedTypeParam], - [UncheckedPattern], + [UncheckedPat], UncheckedExp, SrcLoc ) -> TypeM ( VName, [TypeParam], - [Pattern], + [Pat], Maybe (TypeExp VName), StructType, [VName], @@ -2749,17 +2754,17 @@ typeError usage mempty $ "Size" <+> pquote (pprName v) <+> "is ambiguous.\n" fixOverloaded _ = return () -hiddenParamNames :: [Pattern] -> Names +hiddenParamNames :: [Pat] -> Names hiddenParamNames params = hidden where - param_all_names = mconcat $ map patternNames params + param_all_names = mconcat $ map patNames params named (Named x, _) = Just x named (Unnamed, _) = Nothing param_names = S.fromList $ mapMaybe (named . patternParam) params hidden = param_all_names `S.difference` param_names -inferredReturnType :: SrcLoc -> [Pattern] -> PatternType -> TermTypeM StructType +inferredReturnType :: SrcLoc -> [Pat] -> PatType -> TermTypeM StructType inferredReturnType loc params t = -- The inferred type may refer to names that are bound by the -- parameter patterns, but which will not be visible in the type. @@ -2777,13 +2782,13 @@ ( Name, Maybe UncheckedTypeExp, [UncheckedTypeParam], - [UncheckedPattern], + [UncheckedPat], UncheckedExp, SrcLoc ) -> TermTypeM ( [TypeParam], - [Pattern], + [Pat], Maybe (TypeExp VName), StructType, [VName], @@ -2855,7 +2860,7 @@ forM_ params' $ \p -> let consumedNonunique p' = not (unique $ unInfo $ identType p') && (identName p' `S.member` names) - in case find consumedNonunique $ S.toList $ patternIdents p of + in case find consumedNonunique $ S.toList $ patIdents p of Just p' -> returnAliased fname (baseName $ identName p') loc Nothing -> @@ -2883,7 +2888,7 @@ onTypeArg (TypeArgType t _) = onParam t typeDimNamesPos _ = mempty -checkGlobalAliases :: [Pattern] -> PatternType -> SrcLoc -> TermTypeM () +checkGlobalAliases :: [Pat] -> PatType -> SrcLoc -> TermTypeM () checkGlobalAliases params body_t loc = do vtable <- asks $ scopeVtable . termScope let isLocal v = case v `M.lookup` vtable of @@ -2893,7 +2898,7 @@ filter (not . isLocal) $ S.toList $ boundArrayAliases body_t - `S.difference` foldMap patternNames params + `S.difference` foldMap patNames params case als of v : _ | not $ null params -> @@ -2905,7 +2910,7 @@ _ -> return () -inferReturnUniqueness :: [Pattern] -> PatternType -> PatternType +inferReturnUniqueness :: [Pat] -> PatType -> PatType inferReturnUniqueness params t = let forbidden = aliasesMultipleTimes t uniques = uniqueParamNames params @@ -2920,7 +2925,7 @@ in delve t -- An alias inhibits uniqueness if it is used in disjoint values. -aliasesMultipleTimes :: PatternType -> Names +aliasesMultipleTimes :: PatType -> Names aliasesMultipleTimes = S.fromList . map fst . filter ((> 1) . snd) . M.toList . delve where delve (Scalar (Record fs)) = @@ -2928,13 +2933,13 @@ delve t = M.fromList $ zip (map aliasVar $ S.toList (aliases t)) $ repeat (1 :: Int) -uniqueParamNames :: [Pattern] -> Names +uniqueParamNames :: [Pat] -> Names uniqueParamNames = S.map identName . S.filter (unique . unInfo . identType) - . foldMap patternIdents + . foldMap patIdents -boundArrayAliases :: PatternType -> S.Set VName +boundArrayAliases :: PatType -> S.Set VName boundArrayAliases (Array als _ _ _) = boundAliases als boundArrayAliases (Scalar Prim {}) = mempty boundArrayAliases (Scalar (Record fs)) = foldMap boundArrayAliases fs @@ -2966,10 +2971,10 @@ -- These restrictions apply to all functions (anonymous or otherwise). -- Top-level functions have further restrictions that are checked -- during let-generalisation. -verifyFunctionParams :: Maybe Name -> [Pattern] -> TermTypeM () +verifyFunctionParams :: Maybe Name -> [Pat] -> TermTypeM () verifyFunctionParams fname params = onFailure (CheckingParams fname) $ - verifyParams (foldMap patternNames params) =<< mapM updateTypes params + verifyParams (foldMap patNames params) =<< mapM updateTypes params where verifyParams forbidden (p : ps) | d : _ <- S.toList $ patternDimNames p `S.intersection` forbidden = @@ -3065,9 +3070,9 @@ Name -> SrcLoc -> [TypeParam] -> - [Pattern] -> + [Pat] -> StructType -> - TermTypeM ([TypeParam], [Pattern], StructType, [VName]) + TermTypeM ([TypeParam], [Pat], StructType, [VName]) letGeneralise defname defloc tparams params rettype = onFailure (CheckingLetGeneralise defname) $ do now_substs <- getConstraints @@ -3120,7 +3125,7 @@ return (tparams', params, rettype'', retext) checkFunBody :: - [Pattern] -> + [Pat] -> UncheckedExp -> Maybe StructType -> SrcLoc -> @@ -3301,5 +3306,5 @@ mapOnName = pure, mapOnQualName = pure, mapOnStructType = normTypeFully, - mapOnPatternType = normTypeFully + mapOnPatType = normTypeFully } 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 @@ -15,13 +15,11 @@ Subst (..), substFromAbbr, TypeSubs, - unionSubs, Substitutable (..), substTypesAny, ) where -import Control.Applicative import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State @@ -279,18 +277,18 @@ -- a description of all names used in the pattern group. checkForDuplicateNames :: MonadTypeChecker m => - [UncheckedPattern] -> + [UncheckedPat] -> m () checkForDuplicateNames = (`evalStateT` mempty) . mapM_ check where check (Id v _ loc) = seen v loc - check (PatternParens p _) = check p + check (PatParens p _) = check p check Wildcard {} = return () - check (TuplePattern ps _) = mapM_ check ps - check (RecordPattern fs _) = mapM_ (check . snd) fs - check (PatternAscription p _ _) = check p - check PatternLit {} = return () - check (PatternConstr _ _ ps _) = mapM_ check ps + check (TuplePat ps _) = mapM_ check ps + check (RecordPat fs _) = mapM_ (check . snd) fs + check (PatAscription p _ _) = check p + check PatLit {} = return () + check (PatConstr _ _ ps _) = mapM_ check ps seen v loc = do already <- gets $ M.lookup v @@ -384,16 +382,13 @@ data Subst t = Subst [TypeParam] t | PrimSubst | SizeSubst (DimDecl VName) deriving (Show) +-- | Create a type substitution corresponding to a type binding. substFromAbbr :: TypeBinding -> Subst StructType substFromAbbr (TypeAbbr _ ps t) = Subst ps t -- | Substitutions to apply in a type. type TypeSubs = VName -> Maybe (Subst StructType) --- | Additively combine two non-intersecting substitutions. -unionSubs :: TypeSubs -> TypeSubs -> TypeSubs -unionSubs f g v = g v <|> f v - instance Functor Subst where fmap f (Subst ps t) = Subst ps $ f t fmap _ PrimSubst = PrimSubst @@ -418,7 +413,7 @@ instance Substitutable d => Substitutable (ShapeDecl d) where applySubst f = fmap $ applySubst f -instance Substitutable Pattern where +instance Substitutable Pat where applySubst f = runIdentity . astMap mapper where mapper = @@ -427,7 +422,7 @@ mapOnName = return, mapOnQualName = return, mapOnStructType = return . applySubst f, - mapOnPatternType = return . applySubst f + mapOnPatType = return . applySubst f } applyType :: 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 @@ -27,7 +27,7 @@ mustHaveField, mustBeOneOf, equalityType, - normPatternType, + normPatType, normTypeFully, instantiateEmptyArrayDims, unify, @@ -312,14 +312,14 @@ normType t = return t -- | Replace any top-level type variable with its substitution. -normPatternType :: MonadUnify m => PatternType -> m PatternType -normPatternType t@(Scalar (TypeVar als u (TypeName [] v) [])) = do +normPatType :: MonadUnify m => PatType -> m PatType +normPatType t@(Scalar (TypeVar als u (TypeName [] v) [])) = do constraints <- getConstraints case snd <$> M.lookup v constraints of Just (Constraint t' _) -> - normPatternType $ t' `setUniqueness` u `setAliases` als + normPatType $ t' `setUniqueness` u `setAliases` als _ -> return t -normPatternType t = return t +normPatType t = return t rigidConstraint :: Constraint -> Bool rigidConstraint ParamType {} = True @@ -1017,8 +1017,8 @@ Usage -> BreadCrumbs -> Name -> - PatternType -> - m PatternType + PatType -> + m PatType mustHaveFieldWith onDims usage bcs l t = do constraints <- getConstraints l_type <- newTypeVar (srclocOf usage) "t" @@ -1055,8 +1055,8 @@ MonadUnify m => Usage -> Name -> - PatternType -> - m PatternType + PatType -> + m PatType mustHaveField usage = mustHaveFieldWith (unifyDims usage) usage noBreadCrumbs -- | Replace dimension mismatches with AnyDim. @@ -1102,9 +1102,9 @@ unifyMostCommon :: MonadUnify m => Usage -> - PatternType -> - PatternType -> - m (PatternType, [VName]) + PatType -> + PatType -> + m (PatType, [VName]) unifyMostCommon usage t1 t2 = do -- We are ignoring the dimensions here, because any mismatches -- should be turned into fresh size variables. diff --git a/src/futhark.hs b/src/futhark.hs --- a/src/futhark.hs +++ b/src/futhark.hs @@ -21,6 +21,7 @@ import qualified Futhark.CLI.Literate as Literate import qualified Futhark.CLI.Misc as Misc import qualified Futhark.CLI.Multicore as Multicore +import qualified Futhark.CLI.MulticoreWASM as MulticoreWASM import qualified Futhark.CLI.OpenCL as OpenCL import qualified Futhark.CLI.Pkg as Pkg import qualified Futhark.CLI.PyOpenCL as PyOpenCL @@ -29,6 +30,7 @@ import qualified Futhark.CLI.REPL as REPL import qualified Futhark.CLI.Run as Run import qualified Futhark.CLI.Test as Test +import qualified Futhark.CLI.WASM as WASM import Futhark.Error import Futhark.Util (maxinum) import Futhark.Util.Options @@ -54,6 +56,8 @@ ("multicore", (Multicore.main, "Compile to multicore C.")), ("python", (Python.main, "Compile to sequential Python.")), ("pyopencl", (PyOpenCL.main, "Compile to Python calling PyOpenCL.")), + ("wasm", (WASM.main, "Compile to WASM with sequential C")), + ("wasm-multicore", (MulticoreWASM.main, "Compile to WASM with multicore C")), ("test", (Test.main, "Test Futhark programs.")), ("bench", (Bench.main, "Benchmark Futhark programs.")), ("dataset", (Dataset.main, "Generate random test data.")), 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 @@ -8,6 +8,7 @@ rotate, reshape, slice, + flatSlice, rebase, shape, index, @@ -19,8 +20,11 @@ import Futhark.IR.Syntax ( DimChange (..), DimIndex (..), + FlatDimIndex (..), + FlatSlice (..), ShapeChange, - Slice, + Slice (..), + flatSliceDims, sliceDims, unitSlice, ) @@ -39,6 +43,7 @@ | Permute (IxFun num) Permutation | Rotate (IxFun num) (Indices num) | Index (IxFun num) (Slice num) + | FlatIndex (IxFun num) (FlatSlice num) | Reshape (IxFun num) (ShapeChange num) | OffsetIndex (IxFun num) num | Rebase (IxFun num) (IxFun num) @@ -49,7 +54,8 @@ text "Direct" <> parens (commasep $ map ppr dims) ppr (Permute fun perm) = ppr fun <> ppr perm ppr (Rotate fun offsets) = ppr fun <> brackets (commasep $ map ((text "+" <>) . ppr) offsets) - ppr (Index fun is) = ppr fun <> brackets (commasep $ map ppr is) + ppr (Index fun is) = ppr fun <> ppr is + ppr (FlatIndex fun is) = ppr fun <> ppr is ppr (Reshape fun oldshape) = ppr fun <> text "->reshape" <> parens (commasep (map ppr oldshape)) @@ -73,6 +79,9 @@ slice :: IxFun num -> Slice num -> IxFun num slice = Index +flatSlice :: IxFun num -> FlatSlice num -> IxFun num +flatSlice = FlatIndex + rebase :: IxFun num -> IxFun num -> IxFun num rebase = Rebase @@ -91,6 +100,8 @@ shape ixfun shape (Index _ how) = sliceDims how +shape (FlatIndex ixfun how) = + flatSliceDims how <> tail (shape ixfun) shape (Reshape _ dims) = map newDim dims shape (OffsetIndex ixfun _) = @@ -115,19 +126,23 @@ index fun $ zipWith mod (zipWith (+) is offsets) dims where dims = shape fun -index (Index fun js) is = +index (Index fun (Slice js)) is = index fun (adjust js is) where adjust (DimFix j : js') is' = j : adjust js' is' adjust (DimSlice j _ s : js') (i : is') = j + i * s : adjust js' is' adjust _ _ = [] +index (FlatIndex fun (FlatSlice offset js)) is = + index fun $ sum (offset : zipWith f is js) : drop (length js) is + where + f i (FlatDimIndex _ s) = i * s index (Reshape fun newshape) is = let new_indices = reshapeIndex (shape fun) (newDims newshape) is in index fun new_indices index (OffsetIndex fun i) is = case shape fun of d : ds -> - index (Index fun (DimSlice i (d - i) 1 : map (unitSlice 0) ds)) is + 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 @@ -141,6 +156,8 @@ rotate (rebase new_base ixfun) offsets 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 OffsetIndex ixfun s -> 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 @@ -80,12 +80,13 @@ n :: Int n = 19 -slice3 :: [DimIndex Int] +slice3 :: Slice Int slice3 = - [ DimSlice 2 (n `P.div` 3) 3, - DimFix (n `P.div` 2), - DimSlice 1 (n `P.div` 2) 2 - ] + Slice + [ DimSlice 2 (n `P.div` 3) 3, + DimFix (n `P.div` 2), + DimSlice 1 (n `P.div` 2) 2 + ] -- Actual tests. tests :: TestTree @@ -110,7 +111,15 @@ test_rebase1, test_rebase2, test_rebase3, - test_rebase4_5 + test_rebase4_5, + test_flatSlice_iota, + test_slice_flatSlice_iota, + test_flatSlice_flatSlice_iota, + test_flatSlice_slice_iota, + test_flatSlice_rotate_iota, + test_flatSlice_rotate_slice_iota, + test_flatSlice_transpose_slice_iota, + test_rotate_flatSlice_transpose_slice_iota ] singleton :: TestTree -> [TestTree] @@ -160,15 +169,17 @@ testCase "slice . rotate . permute . slice . iota 1" $ compareOps $ let slice2 = - [ DimSlice 0 n 1, - DimSlice 1 (n `P.div` 2) 2, - DimSlice 0 n 1 - ] + Slice + [ DimSlice 0 n 1, + DimSlice 1 (n `P.div` 2) 2, + DimSlice 0 n 1 + ] slice13 = - [ DimSlice 2 (n `P.div` 3) 3, - DimSlice 0 (n `P.div` 2) 1, - DimSlice 1 (n `P.div` 2) 2 - ] + Slice + [ DimSlice 2 (n `P.div` 3) 3, + DimSlice 0 (n `P.div` 2) 1, + DimSlice 1 (n `P.div` 2) 2 + ] ixfun = permute (slice (iota [n, n, n]) slice2) [2, 1, 0] ixfun' = slice (rotate ixfun [3, 1, 2]) slice13 in ixfun' @@ -179,15 +190,17 @@ testCase "slice . rotate . permute . slice . iota 2" $ compareOps $ let slice2 = - [ DimSlice 0 (n `P.div` 2) 1, - DimFix (n `P.div` 2), - DimSlice 0 (n `P.div` 3) 1 - ] + Slice + [ DimSlice 0 (n `P.div` 2) 1, + DimFix (n `P.div` 2), + DimSlice 0 (n `P.div` 3) 1 + ] slice13 = - [ DimSlice 2 (n `P.div` 3) 3, - DimSlice 0 n 1, - DimSlice 1 (n `P.div` 2) 2 - ] + Slice + [ DimSlice 2 (n `P.div` 3) 3, + DimSlice 0 n 1, + DimSlice 1 (n `P.div` 2) 2 + ] ixfun = permute (slice (iota [n, n, n]) slice13) [2, 1, 0] ixfun' = slice (rotate ixfun [3, 1, 2]) slice2 in ixfun' @@ -204,7 +217,11 @@ (n1, m1) = case IxFunLMAD.shape (fst ixfun') of [a, b] -> (a, b) _ -> error "expecting 2 dimensions at this point!" - negslice = [DimSlice 0 n1 1, DimSlice (m1 - 1) m1 (-1)] + negslice = + Slice + [ DimSlice 0 n1 1, + DimSlice (m1 - 1) m1 (-1) + ] ixfun'' = rotate (slice ixfun' negslice) [1, 2] in ixfun'' @@ -215,13 +232,18 @@ compareOps $ -- contiguousness let slice33 = - [ DimFix (n `P.div` 2), - DimSlice (n - 1) (n `P.div` 3) (-1), - DimSlice 0 n 1 - ] + Slice + [ DimFix (n `P.div` 2), + DimSlice (n - 1) (n `P.div` 3) (-1), + DimSlice 0 n 1 + ] ixfun = permute (slice (iota [n, n, n]) slice33) [1, 0] m = n `P.div` 3 - slice1 = [DimSlice (n - 1) n (-1), DimSlice 2 (m - 2) 1] + slice1 = + Slice + [ DimSlice (n - 1) n (-1), + DimSlice 2 (m - 2) 1 + ] ixfun' = permute (rotate (slice ixfun slice1) [1, 2]) [1, 0] in ixfun' @@ -251,11 +273,12 @@ compareOps $ let newdims = [DimNew (n * n), DimCoercion n] slc = - [ DimFix (n `P.div` 2), - DimSlice (n -1) n (-1), - DimSlice 0 n 1, - DimSlice (n -1) n (-1) - ] + Slice + [ DimFix (n `P.div` 2), + DimSlice (n -1) n (-1), + DimSlice 0 n 1, + DimSlice (n -1) n (-1) + ] in reshape (slice (iota [n, n, n, n]) slc) newdims test_reshape_slice_iota3 :: [TestTree] @@ -266,11 +289,12 @@ compareOps $ let newdims = [DimNew (n * n), DimCoercion n] slc = - [ DimFix (n `P.div` 2), - DimSlice 0 n 1, - DimSlice 0 (n `P.div` 2) 1, - DimSlice 0 n 1 - ] + Slice + [ DimFix (n `P.div` 2), + DimSlice 0 n 1, + DimSlice 0 (n `P.div` 2) 1, + DimSlice 0 n 1 + ] in reshape (slice (iota [n, n, n, n]) slc) newdims test_complex1 :: [TestTree] @@ -285,14 +309,21 @@ DimCoercion ((n `P.div` 3) - 2) ] slice33 = - [ DimSlice (n -1) (n `P.div` 3) (-1), - DimSlice (n -1) n (-1), - DimSlice (n -1) n (-1), - DimSlice 0 n 1 - ] + Slice + [ DimSlice (n -1) (n `P.div` 3) (-1), + DimSlice (n -1) n (-1), + DimSlice (n -1) n (-1), + DimSlice 0 n 1 + ] ixfun = permute (slice (iota [n, n, n, n, n]) slice33) [3, 1, 2, 0] m = n `P.div` 3 - slice1 = [DimSlice 0 n 1, DimSlice (n -1) n (-1), DimSlice (n -1) n (-1), DimSlice 1 (m -2) (-1)] + slice1 = + Slice + [ DimSlice 0 n 1, + DimSlice (n -1) n (-1), + DimSlice (n -1) n (-1), + DimSlice 1 (m -2) (-1) + ] ixfun' = reshape (rotate (slice ixfun slice1) [1, 2, 3, 4]) newdims in ixfun' @@ -307,15 +338,22 @@ DimCoercion ((n `P.div` 3) - 2) ] slc2 = - [ DimFix (n `P.div` 2), - DimSlice (n -1) (n `P.div` 3) (-1), - DimSlice (n -1) n (-1), - DimSlice (n -1) n (-1), - DimSlice 0 n 1 - ] + Slice + [ DimFix (n `P.div` 2), + DimSlice (n -1) (n `P.div` 3) (-1), + DimSlice (n -1) n (-1), + DimSlice (n -1) n (-1), + DimSlice 0 n 1 + ] ixfun = permute (slice (iota [n, n, n, n, n]) slc2) [3, 1, 2, 0] m = n `P.div` 3 - slice1 = [DimSlice 0 n 1, DimSlice (n -1) n (-1), DimSlice (n -1) n (-1), DimSlice 1 (m -2) (-1)] + slice1 = + Slice + [ DimSlice 0 n 1, + DimSlice (n -1) n (-1), + DimSlice (n -1) n (-1), + DimSlice 1 (m -2) (-1) + ] ixfun' = reshape (rotate (slice ixfun slice1) [1, 0, 0, 2]) newdims in ixfun' @@ -325,10 +363,11 @@ testCase "rebase 1" $ compareOps $ let slice_base = - [ DimFix (n `P.div` 2), - DimSlice 2 (n -2) 1, - DimSlice 3 (n -3) 1 - ] + Slice + [ DimFix (n `P.div` 2), + DimSlice 2 (n -2) 1, + DimSlice 3 (n -3) 1 + ] ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] ixfn_orig = rotate (permute (iota [n -3, n -2]) [1, 0]) [1, 2] ixfn_rebase = rebase ixfn_base ixfn_orig @@ -340,14 +379,16 @@ testCase "rebase 2" $ compareOps $ let slice_base = - [ DimFix (n `P.div` 2), - DimSlice (n -1) (n -2) (-1), - DimSlice (n -1) (n -3) (-1) - ] + Slice + [ DimFix (n `P.div` 2), + DimSlice (n -1) (n -2) (-1), + DimSlice (n -1) (n -3) (-1) + ] slice_orig = - [ DimSlice (n -4) (n -3) (-1), - DimSlice (n -3) (n -2) (-1) - ] + Slice + [ DimSlice (n -4) (n -3) (-1), + DimSlice (n -3) (n -2) (-1) + ] ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] ixfn_orig = rotate (permute (slice (iota [n -3, n -2]) slice_orig) [1, 0]) [1, 2] ixfn_rebase = rebase ixfn_base ixfn_orig @@ -361,14 +402,16 @@ let n2 = (n -2) `P.div` 3 n3 = (n -3) `P.div` 2 slice_base = - [ DimFix (n `P.div` 2), - DimSlice (n -1) n2 (-3), - DimSlice (n -1) n3 (-2) - ] + Slice + [ DimFix (n `P.div` 2), + DimSlice (n -1) n2 (-3), + DimSlice (n -1) n3 (-2) + ] slice_orig = - [ DimSlice (n3 -1) n3 (-1), - DimSlice (n2 -1) n2 (-1) - ] + Slice + [ DimSlice (n3 -1) n3 (-1), + DimSlice (n2 -1) n2 (-1) + ] ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] ixfn_rebase = rebase ixfn_base ixfn_orig @@ -379,17 +422,92 @@ let n2 = (n -2) `P.div` 3 n3 = (n -3) `P.div` 2 slice_base = - [ DimFix (n `P.div` 2), - DimSlice (n -1) n2 (-3), - DimSlice 3 n3 2 - ] + Slice + [ DimFix (n `P.div` 2), + DimSlice (n -1) n2 (-3), + DimSlice 3 n3 2 + ] slice_orig = - [ DimSlice (n3 -1) n3 (-1), - DimSlice 0 n2 1 - ] + Slice + [ DimSlice (n3 -1) n3 (-1), + DimSlice 0 n2 1 + ] ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] in [ testCase "rebase mixed monotonicities" $ compareOps $ rebase ixfn_base ixfn_orig ] + +test_flatSlice_iota :: [TestTree] +test_flatSlice_iota = + singleton $ + testCase "flatSlice . iota" $ + compareOps $ + flatSlice (iota [n * n * n * n]) $ + FlatSlice 2 [FlatDimIndex (n * 2) 4, FlatDimIndex n 3, FlatDimIndex 1 2] + +test_slice_flatSlice_iota :: [TestTree] +test_slice_flatSlice_iota = + singleton $ + testCase "slice . flatSlice . iota " $ + compareOps $ + slice (flatSlice (iota [2 + n * n * n]) flat_slice) $ + Slice [DimFix 2, DimSlice 0 n 1, DimFix 0] + where + flat_slice = FlatSlice 2 [FlatDimIndex (n * n) 1, FlatDimIndex n 1, FlatDimIndex 1 1] + +test_flatSlice_flatSlice_iota :: [TestTree] +test_flatSlice_flatSlice_iota = + singleton $ + testCase "flatSlice . flatSlice . iota " $ + compareOps $ + flatSlice (flatSlice (iota [10 * 10]) flat_slice_1) flat_slice_2 + where + flat_slice_1 = FlatSlice 17 [FlatDimIndex 3 27, FlatDimIndex 3 10, FlatDimIndex 3 1] + flat_slice_2 = FlatSlice 2 [FlatDimIndex 2 (-2)] + +test_flatSlice_slice_iota :: [TestTree] +test_flatSlice_slice_iota = + singleton $ + testCase "flatSlice . slice . iota " $ + compareOps $ + flatSlice (slice (iota [210, 100]) $ Slice [DimSlice 10 100 2, DimFix 10]) flat_slice_1 + where + flat_slice_1 = FlatSlice 17 [FlatDimIndex 3 27, FlatDimIndex 3 10, FlatDimIndex 3 1] + +test_flatSlice_rotate_iota :: [TestTree] +test_flatSlice_rotate_iota = + singleton $ + testCase "flatSlice . rotate . iota " $ + compareOps $ + flatSlice (rotate (iota [10, 10]) [2, 5]) flat_slice_1 + where + flat_slice_1 = FlatSlice 3 [FlatDimIndex 2 2, FlatDimIndex 2 1] + +test_flatSlice_rotate_slice_iota :: [TestTree] +test_flatSlice_rotate_slice_iota = + singleton $ + testCase "flatSlice . rotate . slice . iota " $ + compareOps $ + flatSlice (rotate (slice (iota [20, 20]) $ Slice [DimSlice 1 5 2, DimSlice 0 5 2]) [2, 3]) flat_slice_1 + where + flat_slice_1 = FlatSlice 1 [FlatDimIndex 2 2] + +test_flatSlice_transpose_slice_iota :: [TestTree] +test_flatSlice_transpose_slice_iota = + singleton $ + testCase "flatSlice . transpose . slice . iota " $ + compareOps $ + flatSlice (permute (slice (iota [20, 20]) $ Slice [DimSlice 1 5 2, DimSlice 0 5 2]) [1, 0]) flat_slice_1 + where + flat_slice_1 = FlatSlice 1 [FlatDimIndex 2 2] + +test_rotate_flatSlice_transpose_slice_iota :: [TestTree] +test_rotate_flatSlice_transpose_slice_iota = + singleton $ + testCase "flatSlice . transpose . slice . iota " $ + compareOps $ + rotate (flatSlice (permute (slice (iota [20, 20]) $ Slice [DimSlice 1 5 2, DimSlice 1 5 2]) [1, 0]) flat_slice_1) [2, 1] + where + flat_slice_1 = FlatSlice 1 [FlatDimIndex 2 2] 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 @@ -7,13 +7,14 @@ rotate, reshape, slice, + flatSlice, rebase, ) where import qualified Futhark.IR.Mem.IxFun as I import qualified Futhark.IR.Mem.IxFun.Alg as IA -import Futhark.IR.Syntax (ShapeChange, Slice) +import Futhark.IR.Syntax (FlatSlice, ShapeChange, Slice) import Futhark.Util.IntegralExp type Shape num = [num] @@ -57,6 +58,13 @@ Slice num -> IxFun num slice (l, a) x = (I.slice l x, IA.slice a x) + +flatSlice :: + (Eq num, IntegralExp num) => + IxFun num -> + FlatSlice num -> + IxFun num +flatSlice (l, a) x = (I.flatSlice l x, IA.flatSlice a x) rebase :: (Eq num, IntegralExp num) => diff --git a/unittests/Futhark/IR/PrimitiveTests.hs b/unittests/Futhark/IR/PrimitiveTests.hs --- a/unittests/Futhark/IR/PrimitiveTests.hs +++ b/unittests/Futhark/IR/PrimitiveTests.hs @@ -9,6 +9,7 @@ import Control.Applicative import Futhark.IR.Primitive +import Futhark.Util (convFloat) import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit @@ -44,10 +45,14 @@ Int64Value <$> arbitrary ] +instance Arbitrary Half where + arbitrary = (convFloat :: Float -> Half) <$> arbitrary + instance Arbitrary FloatValue where arbitrary = oneof - [ Float32Value <$> arbitrary, + [ Float16Value <$> arbitrary, + Float32Value <$> arbitrary, Float64Value <$> arbitrary ] @@ -65,6 +70,7 @@ arbitraryPrimValOfType (IntType Int16) = IntValue . Int16Value <$> arbitrary arbitraryPrimValOfType (IntType Int32) = IntValue . Int32Value <$> arbitrary arbitraryPrimValOfType (IntType Int64) = IntValue . Int64Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float16) = FloatValue . Float16Value <$> arbitrary arbitraryPrimValOfType (FloatType Float32) = FloatValue . Float32Value <$> arbitrary arbitraryPrimValOfType (FloatType Float64) = FloatValue . Float32Value <$> arbitrary arbitraryPrimValOfType Bool = BoolValue <$> arbitrary diff --git a/unittests/Futhark/Optimise/ReuseAllocations/GreedyColoringTests.hs b/unittests/Futhark/Optimise/ReuseAllocations/GreedyColoringTests.hs --- a/unittests/Futhark/Optimise/ReuseAllocations/GreedyColoringTests.hs +++ b/unittests/Futhark/Optimise/ReuseAllocations/GreedyColoringTests.hs @@ -5,8 +5,8 @@ import Control.Arrow ((***)) import Data.Function ((&)) -import qualified Data.Map as Map -import qualified Data.Set as Set +import qualified Data.Map as M +import qualified Data.Set as S import qualified Futhark.Optimise.ReuseAllocations.GreedyColoring as GreedyColoring import Test.Tasty import Test.Tasty.HUnit @@ -23,10 +23,10 @@ assertEqual "Color simple 1-2-3 using two colors" ([(0, "local"), (1, "local")], [(1 :: Int, 0), (2, 1), (3, 0)]) - $ (Map.toList *** Map.toList) $ + $ (M.toList *** M.toList) $ GreedyColoring.colorGraph - (Map.fromList [(1, "local"), (2, "local"), (3, "local")]) - $ Set.fromList [(1, 2), (2, 3)] + (M.fromList [(1, "local"), (2, "local"), (3, "local")]) + $ S.fromList [(1, 2), (2, 3)] allIntersect :: TestTree allIntersect = @@ -34,10 +34,10 @@ assertEqual "Color a graph where all values intersect" ([(0, "local"), (1, "local"), (2, "local")], [(1 :: Int, 2), (2, 1), (3, 0)]) - $ (Map.toList *** Map.toList) $ + $ (M.toList *** M.toList) $ GreedyColoring.colorGraph - (Map.fromList [(1, "local"), (2, "local"), (3, "local")]) - $ Set.fromList [(1, 2), (2, 3), (1, 3)] + (M.fromList [(1, "local"), (2, "local"), (3, "local")]) + $ S.fromList [(1, 2), (2, 3), (1, 3)] emptyGraph :: TestTree emptyGraph = @@ -45,14 +45,14 @@ assertEqual "Color an empty graph" ([] :: [(Int, Char)], [] :: [(Int, Int)]) - $ (Map.toList *** Map.toList) $ GreedyColoring.colorGraph Map.empty $ Set.fromList [] + $ (M.toList *** M.toList) $ GreedyColoring.colorGraph M.empty $ S.fromList [] noIntersections :: TestTree noIntersections = GreedyColoring.colorGraph - (Map.fromList [(1, "local"), (2, "local"), (3, "local")]) - (Set.fromList []) - & Map.toList *** Map.toList + (M.fromList [(1, "local"), (2, "local"), (3, "local")]) + (S.fromList []) + & M.toList *** M.toList & assertEqual "Color nodes with no intersections" ([(0, "local")], [(1, 0), (2, 0), (3, 0)] :: [(Int, Int)]) @@ -61,9 +61,9 @@ differentSpaces :: TestTree differentSpaces = GreedyColoring.colorGraph - (Map.fromList [(1, "a"), (2, "b"), (3, "c")]) - (Set.fromList []) - & Map.toList *** Map.toList + (M.fromList [(1, "a"), (2, "b"), (3, "c")]) + (S.fromList []) + & M.toList *** M.toList & assertEqual "Color nodes with no intersections but in different spaces" ([(0, "c"), (1, "b"), (2, "a")], [(1, 2), (2, 1), (3, 0)] :: [(Int, Int)])