diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ ISC License -Copyright (c) 2013-2018. DIKU, University of Copenhagen +Copyright (c) 2013-2022. DIKU, University of Copenhagen Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -332,19 +332,68 @@ * Otherwise, the serialised representation of the value will be stored at ``*p``, which *must* have room for at least ``*n`` - bytes. + bytes. This is done asynchronously. Returns 0 on success. .. c:function:: struct futhark_opaque_foo* futhark_restore_opaque_foo(struct futhark_context *ctx, const void *p) - Restore a byte sequence previously written with + Asynchronously restore a byte sequence previously written with :c:func:`futhark_store_opaque_foo`. Returns ``NULL`` on failure. The byte sequence does not need to have been generated by the same program *instance*, but it *must* have been generated by the same Futhark program, and compiled with the same version of the Futhark compiler. +Records +~~~~~~~ + +A record is an opaque type (see above) that supports additional +functions to *project* individual fields (read their values) to +construct a value given values for the fields. An opaque type is a +record if its definition is a record at the Futhark level. + +The projection and construction functions are equivalent in +functionality to writing entry points by hand, and so serve only to +cut down on boilerplate. Important things to be aware of: + +1. The objects constructed though these functions have their own + lifetime (like any objects returned from an entry point) and must + be manually freed, independently of the records from which they are + projected, or the fields they are constructed from. + +2. The objects are however in an *aliasing* relationship with the + fields or original record. This means you must be careful when + passing them to entry points that consume their arguments. As + always, you don't have to worry about this if you never write entry + points that consume their arguments. + +The precise functions generated depend on the fields of the record. +The following functions assume a record with Futhark-level type ``type +t = {foo: t1, bar: t2}`` where ``t1`` and ``t2`` are also opaque +types. + +.. c:function:: int futhark_new_opaque_t(struct futhark_context *ctx, struct futhark_opaque_t **out, const struct futhark_opaque_t2 *bar, const struct futhark_opaque_t1 *foo); + + Construct a record in ``*out`` which has the given values for the + ``bar`` and ``foo`` fields. The parameter ordering constitutes the + fields in alphabetic order. Tuple fields are named ``vX`` where + ``X`` is an integer. The resulting record *aliases* the values + provided for ``bar`` and ``foo``, but has its own lifetime, and all + values must be individually freed when they are no longer needed. + +.. c:function:: int futhark_project_opaque_t_bar(struct futhark_context *ctx, struct futhark_opaque_t2 **out, const struct futhark_opaque_t *obj); + + Extract the value of the field ``bar`` from the provided record. + The resulting value *aliases* the record, but has its own lifetime, + and must eventually be freed. + +.. c:function:: int futhark_project_opaque_t_foo(struct futhark_context *ctx, struct futhark_opaque_t1 **out, const struct futhark_opaque_t *obj); + + Extract the value of the field ``bar`` from the provided record. + The resulting value *aliases* the record, but has its own lifetime, + and must eventually be freed. + Entry points ------------ @@ -507,7 +556,7 @@ The following API functions are available when using the ``multicore`` backend. -.. c:function:: void context_config_set_num_threads(struct futhark_context_config *cfg, int n) +.. c:function:: void futhark_context_config_set_num_threads(struct futhark_context_config *cfg, int n) The number of threads used to run parallel operations. If set to a value less than ``1``, then the runtime system will use one thread @@ -564,15 +613,15 @@ * A list of all *outputs*, including their type and whether they are *unique*. -* A mapping from the name of each non-scalar types to: +* A mapping from the name of each non-scalar type to: - * The C type of used to represent type type (which is practice + * The C type of used to represent the type (which is in practice always a pointer of some kind). * For arrays, the element type and rank. - * A mapping from names of *operations* to the name of the C function - that implements that operation for the type. The type of the C + * A mapping from *operations* to the names of the C functions that + implement the operations for the type. The types of the C functions are as documented above. The following operations are listed: diff --git a/docs/conf.py b/docs/conf.py --- a/docs/conf.py +++ b/docs/conf.py @@ -343,6 +343,7 @@ ('man/futhark-autotune', 'futhark-autotune', 'calibrate run-time parameters', [], 1), ('man/futhark-c', 'futhark-c', 'compile Futhark to sequential C', [], 1), ('man/futhark-multicore', 'futhark-multicore', 'compile Futhark to multithreaded C', [], 1), + ('man/futhark-ispc', 'futhark-ispc', 'compile Futhark to multithreaded ISPC', [], 1), ('man/futhark-opencl', 'futhark-opencl', 'compile Futhark to OpenCL', [], 1), ('man/futhark-cuda', 'futhark-cuda', 'compile Futhark to CUDA', [], 1), ('man/futhark-python', 'futhark-python', 'compile Futhark to sequential Python', [], 1), diff --git a/docs/index.rst b/docs/index.rst --- a/docs/index.rst +++ b/docs/index.rst @@ -53,6 +53,7 @@ man/futhark-doc.rst man/futhark-literate.rst man/futhark-multicore.rst + man/futhark-ispc.rst man/futhark-opencl.rst man/futhark-pkg.rst man/futhark-pyopencl.rst diff --git a/docs/installation.rst b/docs/installation.rst --- a/docs/installation.rst +++ b/docs/installation.rst @@ -37,7 +37,7 @@ --------------------- To compile Futhark you must first install an appropriate version of -GHC, either with [ghcup](https://www.haskell.org/ghcup/) or a package +GHC, either with `ghcup `_ or a package manager. Any version since GHC 8.10 should work. You also need the ``cabal`` command line program, which ghcup will install for you as well. diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -396,8 +396,8 @@ A type abbreviation can have zero or more parameters. A type parameter enclosed with square brackets is a *size parameter*, and -can be used in the definition as an array dimension size, or as a -dimension argument to other type abbreviations. When passing an +can be used in the definition as an array size, or as a +size argument to other type abbreviations. When passing an argument for a shape parameter, it must be enclosed in square brackets. Example:: diff --git a/docs/man/futhark-ispc.rst b/docs/man/futhark-ispc.rst new file mode 100644 --- /dev/null +++ b/docs/man/futhark-ispc.rst @@ -0,0 +1,61 @@ +.. role:: ref(emphasis) + +.. _futhark-ispc(1): + +============ +futhark-ispc +============ + +SYNOPSIS +======== + +futhark ispc [options...] + +DESCRIPTION +=========== + +``futhark ispc`` translates a Futhark program to a combination of C +and ISPC code, with ISPC used for parallel loops. It otherwise +operates similarly to :ref:`futhark-multicore(1)`. You need to have +``ispc`` on your ``PATH``. + +OPTIONS +======= + +Accepts the same options as :ref:`futhark-multicore(1)`. + + +ENVIRONMENT VARIABLES +===================== + +``CC`` + + The C compiler used to compile the program. Defaults to ``cc`` if + unset. + +``CFLAGS`` + + Space-separated list of options passed to the C compiler. Defaults + to ``-O3 -std=c99 -pthread`` if unset. + +``ISPCFLAGS`` + + Space-separated list of options passed to ``ispc``. Defaults to + ``-O3 --woff`` if unset. + +EXECUTABLE OPTIONS +================== + +Generated executables accept the same options as those generated by +:ref:`futhark-multicore(1)`. + +BUGS +==== + +Currently works only on Unix-like systems because of a dependency on +pthreads. Adding support for Windows would likely not be difficult. + +SEE ALSO +======== + +:ref:`futhark-multicore(1)`, :ref:`futhark-test(1)` diff --git a/docs/man/futhark-literate.rst b/docs/man/futhark-literate.rst --- a/docs/man/futhark-literate.rst +++ b/docs/man/futhark-literate.rst @@ -239,6 +239,12 @@ running a program from an unknown source, you should always give it a quick read to see if anything looks fishy. +BUGS +==== + +FutharkScript expressions can only refer to names defined in the file +passed to ``futhark literate``, not any names in imported files. + SEE ALSO ======== diff --git a/docs/man/futhark.rst b/docs/man/futhark.rst --- a/docs/man/futhark.rst +++ b/docs/man/futhark.rst @@ -95,7 +95,12 @@ Expresses gratitude. +futhark tokens FILE +------------------- + +Print the tokens the given Futhark source file; one per line. + SEE ALSO ======== -: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)` +: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-ispc(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,6 +71,19 @@ The following commands are supported. +General Commands +~~~~~~~~~~~~~~~~ + +``types`` +......... + +Print the names of available types, one per line. + +``entry_points`` +................ + +Print the names of available entry points. + ``call`` *entry* *o1* ... *oN* *i1* ... *iM* ............................................ @@ -138,10 +151,36 @@ Corresponds to :c:func:`futhark_context_config_set_tuning_param`. +Record Commands +~~~~~~~~~~~~~~~ + +``fields`` *type* +................. + +If the given type is a record, print a line for each field of the +record. The line will contain the name of the field, followed by a +space, followed by the type of the field. Note that the type name can +contain spaces. The order of fields is significant, as it is the one +expected by the ``new_record`` command. + +``new`` *v0* *type* *v1* ... *vN* +................................. + +Create a new variable *v0* of type *type*, which must be a record type +with *N* fields, where *v1* to *vN* are variables with the +corresponding field types (the expected order is given by the +``fields`` command). + +``project`` *to* *from* *field* +............................... + +Create a new variable *to* whose value is the field *field* of the +record-typed variable *from*. + Environment Variables --------------------- ``FUTHARK_COMPILER_DEBUGGING`` -.............................. +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Turns on debugging output for the server when set to 1. 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.21.12 +version: 0.21.13 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to @@ -34,11 +34,44 @@ license-file: LICENSE build-type: Simple extra-source-files: - rts/c/*.h - rts/futhark-doc/*.css - rts/javascript/*.js - rts/python/*.py - prelude/*.fut +-- Cabal's recompilation tracking doesn't work when we use wildcards +-- here, so for now we spell out every single file. + rts/c/atomics.h + rts/c/lock.h + rts/c/timing.h + rts/c/errors.h + rts/c/free_list.h + rts/c/tuning.h + rts/c/values.h + rts/c/half.h + rts/c/opencl.h + rts/c/cuda.h + rts/c/cache.h + rts/c/ispc_util.h + rts/c/scalar.h + rts/c/scalar_f16.h + rts/c/scheduler.h + rts/c/uniform.h + rts/c/util.h + rts/c/server.h + rts/futhark-doc/style.css + rts/javascript/server.js + rts/javascript/values.js + rts/javascript/wrapperclasses.js + rts/python/tuning.py + rts/python/panic.py + rts/python/memory.py + rts/python/server.py + rts/python/values.py + rts/python/opencl.py + rts/python/scalar.py + prelude/functional.fut + prelude/math.fut + prelude/soacs.fut + prelude/zip.fut + prelude/ad.fut + prelude/array.fut + prelude/prelude.fut -- Just enough of the docs to build the manpages. docs/**/*.rst docs/Makefile @@ -51,7 +84,13 @@ type: git location: https://github.com/diku-dk/futhark +common common + ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -Wunused-packages + default-language: Haskell2010 + library + import: common + hs-source-dirs: src exposed-modules: Futhark Futhark.Actions @@ -101,6 +140,7 @@ Futhark.CLI.Main Futhark.CLI.Misc Futhark.CLI.Multicore + Futhark.CLI.MulticoreISPC Futhark.CLI.MulticoreWASM Futhark.CLI.OpenCL Futhark.CLI.Pkg @@ -124,6 +164,7 @@ Futhark.CodeGen.Backends.GenericPython.Options Futhark.CodeGen.Backends.GenericWASM Futhark.CodeGen.Backends.MulticoreC + Futhark.CodeGen.Backends.MulticoreISPC Futhark.CodeGen.Backends.MulticoreWASM Futhark.CodeGen.Backends.PyOpenCL Futhark.CodeGen.Backends.PyOpenCL.Boilerplate @@ -186,8 +227,6 @@ Futhark.IR.Mem.Simplify Futhark.IR.Parse Futhark.IR.Pretty - Futhark.IR.Primitive - Futhark.IR.Primitive.Parse Futhark.IR.Prop Futhark.IR.Prop.Aliases Futhark.IR.Prop.Constants @@ -215,8 +254,8 @@ Futhark.Internalise.Bindings Futhark.Internalise.Defunctionalise Futhark.Internalise.Defunctorise + Futhark.Internalise.Entry Futhark.Internalise.Exps - Futhark.Internalise.FreeVars Futhark.Internalise.Lambdas Futhark.Internalise.LiftLambdas Futhark.Internalise.Monad @@ -234,7 +273,8 @@ Futhark.Optimise.DoubleBuffer Futhark.Optimise.Fusion Futhark.Optimise.Fusion.Composing - Futhark.Optimise.Fusion.LoopKernel + Futhark.Optimise.Fusion.GraphRep + Futhark.Optimise.Fusion.TryFusion Futhark.Optimise.GenRedOpt Futhark.Optimise.HistAccs Futhark.Optimise.InPlaceLowering @@ -309,17 +349,21 @@ Language.Futhark Language.Futhark.Core Language.Futhark.Interpreter + Language.Futhark.FreeVars Language.Futhark.Parser Language.Futhark.Parser.Monad Language.Futhark.Parser.Lexer.Tokens Language.Futhark.Parser.Lexer.Wrapper Language.Futhark.Prelude Language.Futhark.Pretty + Language.Futhark.Primitive + Language.Futhark.Primitive.Parse Language.Futhark.Prop Language.Futhark.Query Language.Futhark.Semantic Language.Futhark.Syntax Language.Futhark.Traversals + Language.Futhark.Tuple Language.Futhark.TypeChecker Language.Futhark.TypeChecker.Match Language.Futhark.TypeChecker.Modules @@ -337,9 +381,6 @@ Paths_futhark autogen-modules: Paths_futhark - hs-source-dirs: - src - ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -Wunused-packages build-tool-depends: alex:alex , happy:happy @@ -354,25 +395,27 @@ , bytestring >=0.10.8 , bytestring-to-vector >=0.3.0.1 , bmp >=1.2.6.3 + , co-log-core , containers >=0.6.2.1 , cryptohash-md5 , Diff >=0.4.1 , directory >=1.3.0.0 , directory-tree >=0.12.1 , dlist >=0.6.0.1 + , fgl + , fgl-visualize , file-embed >=0.0.14.0 , filepath >=1.4.1.1 , free >=4.12.4 , futhark-data >= 1.1.0.0 - , futhark-server >= 1.2.0.0 - , futhark-manifest >= 1.0.0.0 + , futhark-server >= 1.2.1.0 + , futhark-manifest >= 1.1.0.0 , githash >=0.1.6.1 , half >= 0.3 , haskeline - , hslogger - , language-c-quote >=0.12 + , language-c-quote >= 0.12 , lens - , lsp >= 1.4 + , lsp == 1.5.* , mainland-pretty >=0.7.1 , cmark-gfm >=0.2.1 , megaparsec >=9.0.0 @@ -396,19 +439,18 @@ , zlib >=0.6.1.2 , statistics , mwc-random - default-language: Haskell2010 executable futhark + import: common main-is: src/main.hs - ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -Wunused-packages -threaded -rtsopts "-with-rtsopts=-N -qg1 -A16M" - build-depends: - base - , futhark - default-language: Haskell2010 + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -qg1 -A16M" + build-depends: base, futhark test-suite unit + import: common type: exitcode-stdio-1.0 main-is: futhark_tests.hs + hs-source-dirs: unittests other-modules: Futhark.AD.DerivativesTests Futhark.BenchTests @@ -421,26 +463,20 @@ Futhark.IR.Mem.IxFun.Alg Futhark.IR.Mem.IxFunTests Futhark.IR.Mem.IxFunWrapper - Futhark.IR.PrimitiveTests Language.Futhark.CoreTests + Language.Futhark.PrimitiveTests Language.Futhark.SyntaxTests Language.Futhark.TypeCheckerTests Language.Futhark.TypeChecker.TypesTests Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests Paths_futhark - hs-source-dirs: - unittests - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: QuickCheck >=2.8 , base , containers , futhark , megaparsec - , mtl - , parser-combinators , tasty , tasty-hunit , tasty-quickcheck , text - default-language: Haskell2010 diff --git a/prelude/soacs.fut b/prelude/soacs.fut --- a/prelude/soacs.fut +++ b/prelude/soacs.fut @@ -1,7 +1,7 @@ -- | Various Second-Order Array Combinators that are operationally -- parallel in a way that can be exploited by the compiler. -- --- The functions here are all recognised specially by the compiler (or +-- The functions here are recognised specially by the compiler (or -- built on those that are). The asymptotic [work and -- span](https://en.wikipedia.org/wiki/Analysis_of_parallel_algorithms) -- is provided for each function, but note that this easily hides very @@ -117,14 +117,26 @@ def reduce_comm [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a): a = intrinsics.reduce_comm (op, ne, as) --- | `reduce_by_index dest f ne is as` returns `dest`, but with each --- element given by the indices of `is` updated by applying `f` to the --- current value in `dest` and the corresponding value in `as`. The --- `ne` value must be a neutral element for `f`. If `is` has --- duplicates, `f` may be applied multiple times, and hence must be --- associative and commutative. Out-of-bounds indices in `is` are --- ignored. +-- | `h = hist op ne k is as` computes a generalised `k`-bin histogram +-- `h`, such that `h[i]` is the sum of those values `as[j]` for which +-- `is[j]==i`. The summation is done with `op`, which must be a +-- commutative and associative function with neutral element `ne`. If +-- a bin has no elements, its value will be `ne`. -- +-- **Work:** *O(k + n ✕ W(op))* +-- +-- **Span:** *O(n ✕ W(op))* in the worst case (all updates to same +-- position), but *O(W(op))* in the best case. +-- +-- In practice, the *O(n)* behaviour only occurs if *m* is also very +-- large. +def hist 'a [n] (op: a -> a -> a) (ne: a) (k: i64) (is: [n]i64) (as: [n]a) : *[k]a = + intrinsics.hist_1d (1, map (\_ -> ne) (0..1.. a -> a) (ne : a) (is : [n]i64) (as : [n]a) : *[m]a = +def reduce_by_index 'a [k] [n] (dest : *[k]a) (f : a -> a -> a) (ne : a) (is : [n]i64) (as : [n]a) : *[k]a = intrinsics.hist_1d (1, dest, f, ne, is, as) -- | As `reduce_by_index`, but with two-dimensional indexes. -def reduce_by_index_2d 'a [n] [m] [k] (dest : *[m][k]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64)) (as : [n]a) : *[m][k]a = +def reduce_by_index_2d 'a [k] [n] [m] (dest : *[k][m]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64)) (as : [n]a) : *[k][m]a = intrinsics.hist_2d (1, dest, f, ne, is, as) -- | As `reduce_by_index`, but with three-dimensional indexes. -def reduce_by_index_3d 'a [n] [m] [k] [l] (dest : *[m][k][l]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64,i64)) (as : [n]a) : *[m][k][l]a = +def reduce_by_index_3d 'a [k] [n] [m] [l] (dest : *[k][m][l]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64,i64)) (as : [n]a) : *[k][m][l]a = intrinsics.hist_3d (1, dest, f, ne, is, as) -- | Inclusive prefix scan. Has the same caveats with respect to @@ -249,35 +261,27 @@ def any [n] 'a (f: a -> bool) (as: [n]a): bool = reduce (||) false (map f as) --- | `scatter as is vs` calculates the equivalent of this imperative --- code: --- --- ``` --- for j in 0...length is-1: --- i = is[j] --- v = vs[j] --- if i >= 0 && i < length as: --- as[i] = v --- ``` +-- | `r = spread x k is vs` produces an array `r` such that `r[i] = +-- vs[j]` where `is[j] == i`, or `x` if no such `j` exists. +-- Intuitively, `is` is an array indicating where the corresponding +-- elements of `vs` should be located in the result. Out-of-bounds +-- elements of `is` are ignored. In-bounds duplicates in `is` result +-- in unspecified behaviour - see `hist`@term for a function that can +-- handle this. -- --- The `is` and `vs` arrays must have the same outer size. `scatter` --- acts in-place and consumes the `as` array, returning a new array --- that has the same type and elements as `as`, except for the indices --- in `is`. Notice that writing outside the index domain of the target --- array has no effect. If `is` contains duplicates for valid indexes --- into the target array (i.e., several writes are performed to the --- same location), the result is unspecified. It is not guaranteed --- that one of the duplicate writes will complete atomically - they --- may be interleaved. See `reduce_by_index`@term for a function that --- can handle this case deterministically. +-- **Work:** *O(k + n)* -- --- This is technically not a second-order operation, but it is defined --- here because it is closely related to the SOACs. +-- **Span:** *O(1)* +def spread 't [n] (k: i64) (x: t) (is: [n]i64) (vs: [n]t): *[k]t = + intrinsics.scatter (map (\_ -> x) (0..1.. SOA memcpy functions +#define memmove_sized(dim) \ +static inline void memmove_##dim(varying uint8 * uniform dst, uniform uint8 * varying src, uniform int64_t n) { \ + uniform uint##dim * varying srcp = (uniform uint##dim * varying) src; \ + varying uint##dim * uniform dstp = (varying uint##dim * uniform) dst; \ + for (uniform int64_t i = 0; i < n / (dim / 8); i++) { \ + dstp[i] = srcp[i]; \ + } \ +} \ +static inline void memmove_##dim(uniform uint8 * varying dst, varying uint8 * uniform src, uniform int64_t n) { \ + varying uint##dim * uniform srcp = (varying uint##dim * uniform) src; \ + uniform uint##dim * varying dstp = (uniform uint##dim * varying) dst; \ + for (uniform int64_t i = 0; i < n / (dim / 8); i++) { \ + dstp[i] = srcp[i]; \ + } \ +} \ +static inline void memmove_##dim(varying uint8 * uniform dst, varying uint8 * uniform src, uniform int64_t n) { \ + varying uint##dim * uniform srcp = (varying uint##dim * uniform) src; \ + varying uint##dim * uniform dstp = (varying uint##dim * uniform) dst; \ + for (uniform int64_t i = 0; i < n / (dim / 8); i++) { \ + dstp[i] = srcp[i]; \ + } \ +} \ +static inline void memmove_##dim(varying uint8 * varying dst, uniform uint8 * varying src, uniform int64_t n) { \ + foreach_unique (ptr in dst) { \ + memmove_##dim(ptr, src, n); \ + } \ +} \ +static inline void memmove_##dim(uniform uint8 * varying dst, varying uint8 * varying src, uniform int64_t n) { \ + foreach_unique (ptr in src) { \ + memmove_##dim(dst, ptr, n); \ + } \ +} \ +static inline void memmove_##dim(varying uint8 * varying dst, varying uint8 * uniform src, uniform int64_t n) { \ + foreach_unique (ptr in dst) { \ + memmove_##dim(ptr, src, n); \ + } \ +} \ +static inline void memmove_##dim(varying uint8 * varying dst, varying uint8 * varying src, uniform int64_t n) { \ + if (reduce_equal((varying int64_t)dst)) { \ + foreach_unique (ptr in src) { \ + memmove_##dim(dst, ptr, n); \ + } \ + } else { \ + foreach_unique (ptr in dst) { \ + memmove_##dim(ptr, src, n); \ + } \ + } \ +} +memmove_sized(8) +memmove_sized(16) +memmove_sized(32) +memmove_sized(64) + +// End of ispc_util.h. diff --git a/rts/c/scalar.h b/rts/c/scalar.h --- a/rts/c/scalar.h +++ b/rts/c/scalar.h @@ -65,1705 +65,2929 @@ 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; -} - -#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); -} - -static inline int8_t fptosi_f32_i8(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (int8_t) x; - } -} - -static inline int16_t fptosi_f32_i16(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (int16_t) x; - } -} - -static inline int32_t fptosi_f32_i32(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (int32_t) x; - } -} - -static inline int64_t fptosi_f32_i64(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (int64_t) x; - }; -} - -static inline uint8_t fptoui_f32_i8(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (uint8_t) (int8_t) x; - } -} - -static inline uint16_t fptoui_f32_i16(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (uint16_t) (int16_t) x; - } -} - -static inline uint32_t fptoui_f32_i32(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (uint32_t) (int32_t) x; - } -} - -static inline uint64_t fptoui_f32_i64(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (uint64_t) (int64_t) x; - } -} - -static inline bool ftob_f32_bool(float x) { - return x != 0; -} - -static inline float btof_bool_f32(bool x) { - return x ? 1 : 0; -} - -#ifdef __OPENCL_VERSION__ -static inline float futrts_log32(float x) { - return log(x); -} - -static inline float futrts_log2_32(float x) { - return log2(x); -} - -static inline float futrts_log10_32(float x) { - return log10(x); -} - -static inline float futrts_sqrt32(float x) { - return sqrt(x); -} - -static inline float futrts_cbrt32(float x) { - return cbrt(x); -} - -static inline float futrts_exp32(float x) { - return exp(x); -} - -static inline float futrts_cos32(float x) { - return cos(x); -} - -static inline float futrts_sin32(float x) { - return sin(x); -} - -static inline float futrts_tan32(float x) { - return tan(x); -} - -static inline float futrts_acos32(float x) { - return acos(x); -} - -static inline float futrts_asin32(float x) { - return asin(x); -} - -static inline float futrts_atan32(float x) { - return atan(x); -} - -static inline float futrts_cosh32(float x) { - return cosh(x); -} - -static inline float futrts_sinh32(float x) { - return sinh(x); -} - -static inline float futrts_tanh32(float x) { - return tanh(x); -} - -static inline float futrts_acosh32(float x) { - return acosh(x); -} - -static inline float futrts_asinh32(float x) { - return asinh(x); -} - -static inline float futrts_atanh32(float x) { - return atanh(x); -} - -static inline float futrts_atan2_32(float x, float y) { - return atan2(x, y); -} - -static inline float futrts_hypot32(float x, float y) { - return hypot(x, y); -} - -static inline float futrts_gamma32(float x) { - return tgamma(x); -} - -static inline float futrts_lgamma32(float x) { - return lgamma(x); -} - -static inline float futrts_erf32(float x) { - return erf(x); -} - -static inline float futrts_erfc32(float x) { - return erfc(x); -} - -static inline float fmod32(float x, float y) { - return fmod(x, y); -} - -static inline float futrts_round32(float x) { - return rint(x); -} - -static inline float futrts_floor32(float x) { - return floor(x); -} - -static inline float futrts_ceil32(float x) { - return ceil(x); -} - -static inline float futrts_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_cbrt32(float x) { - return cbrtf(x); -} - -static inline float futrts_exp32(float x) { - return expf(x); -} - -static inline float futrts_cos32(float x) { - return cosf(x); -} - -static inline float futrts_sin32(float x) { - return sinf(x); -} - -static inline float futrts_tan32(float x) { - return tanf(x); -} - -static inline float futrts_acos32(float x) { - return acosf(x); -} - -static inline float futrts_asin32(float x) { - return asinf(x); -} - -static inline float futrts_atan32(float x) { - return atanf(x); -} - -static inline float futrts_cosh32(float x) { - return coshf(x); -} - -static inline float futrts_sinh32(float x) { - return sinhf(x); -} - -static inline float futrts_tanh32(float x) { - return tanhf(x); -} - -static inline float futrts_acosh32(float x) { - return acoshf(x); -} - -static inline float futrts_asinh32(float x) { - return asinhf(x); -} - -static inline float futrts_atanh32(float x) { - return atanhf(x); -} - -static inline float futrts_atan2_32(float x, float y) { - return atan2f(x, y); -} - -static inline float futrts_hypot32(float x, float y) { - return hypotf(x, y); -} - -static inline float futrts_gamma32(float x) { - return tgammaf(x); -} - -static inline float futrts_lgamma32(float x) { - return lgammaf(x); -} - -static inline float futrts_erf32(float x) { - return erff(x); -} - -static inline float futrts_erfc32(float x) { - return erfcf(x); -} - -static inline float fmod32(float x, float y) { - return fmodf(x, y); -} - -static inline float futrts_round32(float x) { - return rintf(x); -} - -static inline float futrts_floor32(float x) { - return floorf(x); -} - -static inline float futrts_ceil32(float x) { - return ceilf(x); -} - -static inline float futrts_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 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_cbrt64(double x) { - return cbrt(x); -} - -static inline double futrts_exp64(double x) { - return exp(x); -} - -static inline double futrts_cos64(double x) { - return cos(x); -} - -static inline double futrts_sin64(double x) { - return sin(x); -} - -static inline double futrts_tan64(double x) { - return tan(x); -} - -static inline double futrts_acos64(double x) { - return acos(x); -} - -static inline double futrts_asin64(double x) { - return asin(x); -} - -static inline double futrts_atan64(double x) { - return atan(x); -} - -static inline double futrts_cosh64(double x) { - return cosh(x); -} - -static inline double futrts_sinh64(double x) { - return sinh(x); -} - -static inline double futrts_tanh64(double x) { - return tanh(x); -} - -static inline double futrts_acosh64(double x) { - return acosh(x); -} - -static inline double futrts_asinh64(double x) { - return asinh(x); -} - -static inline double futrts_atanh64(double x) { - return atanh(x); -} - -static inline double futrts_atan2_64(double x, double y) { - return atan2(x, y); -} - -static inline double futrts_hypot64(double x, double y) { - return hypot(x, y); -} - -static inline double futrts_gamma64(double x) { - return tgamma(x); -} - -static inline double futrts_lgamma64(double x) { - return lgamma(x); -} - -static inline double futrts_erf64(double x) { - return erf(x); -} - -static inline double futrts_erfc64(double x) { - return erfc(x); -} - -static inline double futrts_fma64(double a, double b, double c) { - return fma(a, b, c); -} - -static inline double futrts_round64(double x) { - return rint(x); -} - -static inline double futrts_ceil64(double x) { - return ceil(x); -} - -static inline double futrts_floor64(double x) { - return floor(x); -} - -static inline bool futrts_isnan64(double x) { - return isnan(x); -} - -static inline bool futrts_isinf64(double x) { - return isinf(x); -} - -static inline int8_t fptosi_f64_i8(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int8_t) x; - } -} - -static inline int16_t fptosi_f64_i16(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int16_t) x; - } -} - -static inline int32_t fptosi_f64_i32(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int32_t) x; - } -} - -static inline int64_t fptosi_f64_i64(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int64_t) x; - } -} - -static inline uint8_t fptoui_f64_i8(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint8_t) (int8_t) x; - } -} - -static inline uint16_t fptoui_f64_i16(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint16_t) (int16_t) x; - } -} - -static inline uint32_t fptoui_f64_i32(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint32_t) (int32_t) x; - } -} - -static inline uint64_t fptoui_f64_i64(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint64_t) (int64_t) x; - } -} - -static inline bool ftob_f64_bool(double x) { - return x != 0; -} - -static inline double btof_bool_f64(bool x) { - return x ? 1 : 0; -} - -static inline int64_t futrts_to_bits64(double x) { - union { - double f; - int64_t t; - } p; - - p.f = x; - return p.t; -} - -static inline double futrts_from_bits64(int64_t x) { - union { - int64_t f; - double t; - } p; - - p.f = x; - return p.t; -} - -static inline double fmod64(double x, double y) { - return fmod(x, y); -} - -static inline double fsignum64(double x) { - return futrts_isnan64(x) ? x : (x > 0) - (x < 0); -} - -static inline double futrts_lerp64(double v0, double v1, double t) { -#ifdef __OPENCL_VERSION__ - return mix(v0, v1, t); -#else - return v0 + (v1 - v0) * t; -#endif -} - -static inline double futrts_mad64(double a, double b, double c) { -#ifdef __OPENCL_VERSION__ - return mad(a, b, c); -#else - return a * b + c; -#endif -} - -static inline float fpconv_f32_f32(float x) { - return (float) x; -} - -static inline double fpconv_f32_f64(float x) { - return (double) x; -} - -static inline float fpconv_f64_f32(double x) { - return (float) x; -} - -static inline double fpconv_f64_f64(double x) { - return (double) x; -} +#if ISPC + +static inline uint8_t udiv8(uint8_t x, uint8_t y) { + // This strange pattern is used to prevent the ISPC compiler from + // causing SIGFPEs and bogus results on divisions where inactive lanes + // have 0-valued divisors. It ensures that any inactive lane instead + // has a divisor of 1. https://github.com/ispc/ispc/issues/2292 + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +static inline uint16_t udiv16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +static inline uint32_t udiv32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + + return x / ys; +} + +static inline uint64_t udiv64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + + return x / ys; +} + +static inline uint8_t udiv_up8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + + return (x + y - 1) / ys; +} + +static inline uint16_t udiv_up16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return (x + y - 1) / ys; +} + +static inline uint32_t udiv_up32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return (x + y - 1) / ys; +} + +static inline uint64_t udiv_up64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return (x + y - 1) / ys; +} + +static inline uint8_t umod8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +static inline uint16_t umod16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + + return x % ys; +} + +static inline uint32_t umod32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +static inline uint64_t umod64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +static inline uint8_t udiv_safe8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +static inline uint16_t udiv_safe16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +static inline uint32_t udiv_safe32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +static inline uint64_t udiv_safe64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +static inline uint8_t udiv_up_safe8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : (x + y - 1) / ys; +} + +static inline uint16_t udiv_up_safe16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : (x + y - 1) / ys; +} + +static inline uint32_t udiv_up_safe32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : (x + y - 1) / ys; +} + +static inline uint64_t udiv_up_safe64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : (x + y - 1) / ys; +} + +static inline uint8_t umod_safe8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +static inline uint16_t umod_safe16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +static inline uint32_t umod_safe32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +static inline uint64_t umod_safe64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +static inline int8_t sdiv8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + int8_t q = x / ys; + int8_t r = x % ys; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline int16_t sdiv16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + int16_t q = x / ys; + int16_t r = x % ys; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline int32_t sdiv32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + int32_t q = x / ys; + int32_t r = x % ys; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline int64_t sdiv64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + int64_t q = x / ys; + int64_t r = x % ys; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline int8_t sdiv_up8(int8_t x, int8_t y) { + return sdiv8(x + y - 1, y); +} + +static inline int16_t sdiv_up16(int16_t x, int16_t y) { + return sdiv16(x + y - 1, y); +} + +static inline int32_t sdiv_up32(int32_t x, int32_t y) { + return sdiv32(x + y - 1, y); +} + +static inline int64_t sdiv_up64(int64_t x, int64_t y) { + return sdiv64(x + y - 1, y); +} + +static inline int8_t smod8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + int8_t r = x % ys; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline int16_t smod16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + int16_t r = x % ys; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline int32_t smod32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + int32_t r = x % ys; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline int64_t smod64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + int64_t r = x % ys; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline int8_t sdiv_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : sdiv8(x, y); +} + +static inline int16_t sdiv_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : sdiv16(x, y); +} + +static inline int32_t sdiv_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : sdiv32(x, y); +} + +static inline int64_t sdiv_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : sdiv64(x, y); +} + +static inline int8_t sdiv_up_safe8(int8_t x, int8_t y) { + return sdiv_safe8(x + y - 1, y); +} + +static inline int16_t sdiv_up_safe16(int16_t x, int16_t y) { + return sdiv_safe16(x + y - 1, y); +} + +static inline int32_t sdiv_up_safe32(int32_t x, int32_t y) { + return sdiv_safe32(x + y - 1, y); +} + +static inline int64_t sdiv_up_safe64(int64_t x, int64_t y) { + return sdiv_safe64(x + y - 1, y); +} + +static inline int8_t smod_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : smod8(x, y); +} + +static inline int16_t smod_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : smod16(x, y); +} + +static inline int32_t smod_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : smod32(x, y); +} + +static inline int64_t smod_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : smod64(x, y); +} + +static inline int8_t squot8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +static inline int16_t squot16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +static inline int32_t squot32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +static inline int64_t squot64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +static inline int8_t srem8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +static inline int16_t srem16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +static inline int32_t srem32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +static inline int64_t srem64(int64_t x, int64_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +static inline int8_t squot_safe8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +static inline int16_t squot_safe16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +static inline int32_t squot_safe32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +static inline int64_t squot_safe64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +static inline int8_t srem_safe8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +static inline int16_t srem_safe16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +static inline int32_t srem_safe32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +static inline int64_t srem_safe64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +#else + +static inline uint8_t udiv8(uint8_t x, uint8_t y) { + return x / y; +} + +static inline uint16_t udiv16(uint16_t x, uint16_t y) { + return x / y; +} + +static inline uint32_t udiv32(uint32_t x, uint32_t y) { + return x / y; +} + +static inline uint64_t udiv64(uint64_t x, uint64_t y) { + return x / y; +} + +static inline uint8_t udiv_up8(uint8_t x, uint8_t y) { + return (x + y - 1) / y; +} + +static inline uint16_t udiv_up16(uint16_t x, uint16_t y) { + return (x + y - 1) / y; +} + +static inline uint32_t udiv_up32(uint32_t x, uint32_t y) { + return (x + y - 1) / y; +} + +static inline uint64_t udiv_up64(uint64_t x, uint64_t y) { + return (x + y - 1) / y; +} + +static inline uint8_t umod8(uint8_t x, uint8_t y) { + return x % y; +} + +static inline uint16_t umod16(uint16_t x, uint16_t y) { + return x % y; +} + +static inline uint32_t umod32(uint32_t x, uint32_t y) { + return x % y; +} + +static inline uint64_t umod64(uint64_t x, uint64_t y) { + return x % y; +} + +static inline uint8_t udiv_safe8(uint8_t x, uint8_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uint16_t udiv_safe16(uint16_t x, uint16_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uint32_t udiv_safe32(uint32_t x, uint32_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uint64_t udiv_safe64(uint64_t x, uint64_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uint8_t udiv_up_safe8(uint8_t x, uint8_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +static inline uint16_t udiv_up_safe16(uint16_t x, uint16_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +static inline uint32_t udiv_up_safe32(uint32_t x, uint32_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +static inline uint64_t udiv_up_safe64(uint64_t x, uint64_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +static inline uint8_t umod_safe8(uint8_t x, uint8_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uint16_t umod_safe16(uint16_t x, uint16_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uint32_t umod_safe32(uint32_t x, uint32_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uint64_t umod_safe64(uint64_t x, uint64_t y) { + return y == 0 ? 0 : x % y; +} + +static inline int8_t sdiv8(int8_t x, int8_t y) { + int8_t q = x / y; + int8_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline int16_t sdiv16(int16_t x, int16_t y) { + int16_t q = x / y; + int16_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline int32_t sdiv32(int32_t x, int32_t y) { + int32_t q = x / y; + int32_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline int64_t sdiv64(int64_t x, int64_t y) { + int64_t q = x / y; + int64_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline int8_t sdiv_up8(int8_t x, int8_t y) { + return sdiv8(x + y - 1, y); +} + +static inline int16_t sdiv_up16(int16_t x, int16_t y) { + return sdiv16(x + y - 1, y); +} + +static inline int32_t sdiv_up32(int32_t x, int32_t y) { + return sdiv32(x + y - 1, y); +} + +static inline int64_t sdiv_up64(int64_t x, int64_t y) { + return sdiv64(x + y - 1, y); +} + +static inline int8_t smod8(int8_t x, int8_t y) { + int8_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline int16_t smod16(int16_t x, int16_t y) { + int16_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline int32_t smod32(int32_t x, int32_t y) { + int32_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline int64_t smod64(int64_t x, int64_t y) { + int64_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline int8_t sdiv_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : sdiv8(x, y); +} + +static inline int16_t sdiv_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : sdiv16(x, y); +} + +static inline int32_t sdiv_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : sdiv32(x, y); +} + +static inline int64_t sdiv_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : sdiv64(x, y); +} + +static inline int8_t sdiv_up_safe8(int8_t x, int8_t y) { + return sdiv_safe8(x + y - 1, y); +} + +static inline int16_t sdiv_up_safe16(int16_t x, int16_t y) { + return sdiv_safe16(x + y - 1, y); +} + +static inline int32_t sdiv_up_safe32(int32_t x, int32_t y) { + return sdiv_safe32(x + y - 1, y); +} + +static inline int64_t sdiv_up_safe64(int64_t x, int64_t y) { + return sdiv_safe64(x + y - 1, y); +} + +static inline int8_t smod_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : smod8(x, y); +} + +static inline int16_t smod_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : smod16(x, y); +} + +static inline int32_t smod_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : smod32(x, y); +} + +static inline int64_t smod_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : smod64(x, y); +} + +static inline int8_t squot8(int8_t x, int8_t y) { + return x / y; +} + +static inline int16_t squot16(int16_t x, int16_t y) { + return x / y; +} + +static inline int32_t squot32(int32_t x, int32_t y) { + return x / y; +} + +static inline int64_t squot64(int64_t x, int64_t y) { + return x / y; +} + +static inline int8_t srem8(int8_t x, int8_t y) { + return x % y; +} + +static inline int16_t srem16(int16_t x, int16_t y) { + return x % y; +} + +static inline int32_t srem32(int32_t x, int32_t y) { + return x % y; +} + +static inline int64_t srem64(int64_t x, int64_t y) { + return x % y; +} + +static inline int8_t squot_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : x / y; +} + +static inline int16_t squot_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : x / y; +} + +static inline int32_t squot_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : x / y; +} + +static inline int64_t squot_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : x / y; +} + +static inline int8_t srem_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : x % y; +} + +static inline int16_t srem_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : x % y; +} + +static inline int32_t srem_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : x % y; +} + +static inline int64_t srem_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : x % y; +} + +#endif + +static inline int8_t smin8(int8_t x, int8_t y) { + return x < y ? x : y; +} + +static inline int16_t smin16(int16_t x, int16_t y) { + return x < y ? x : y; +} + +static inline int32_t smin32(int32_t x, int32_t y) { + return x < y ? x : y; +} + +static inline int64_t smin64(int64_t x, int64_t y) { + return x < y ? x : y; +} + +static inline uint8_t umin8(uint8_t x, uint8_t y) { + return x < y ? x : y; +} + +static inline uint16_t umin16(uint16_t x, uint16_t y) { + return x < y ? x : y; +} + +static inline uint32_t umin32(uint32_t x, uint32_t y) { + return x < y ? x : y; +} + +static inline uint64_t umin64(uint64_t x, uint64_t y) { + return x < y ? x : y; +} + +static inline int8_t smax8(int8_t x, int8_t y) { + return x < y ? y : x; +} + +static inline int16_t smax16(int16_t x, int16_t y) { + return x < y ? y : x; +} + +static inline int32_t smax32(int32_t x, int32_t y) { + return x < y ? y : x; +} + +static inline int64_t smax64(int64_t x, int64_t y) { + return x < y ? y : x; +} + +static inline uint8_t umax8(uint8_t x, uint8_t y) { + return x < y ? y : x; +} + +static inline uint16_t umax16(uint16_t x, uint16_t y) { + return x < y ? y : x; +} + +static inline uint32_t umax32(uint32_t x, uint32_t y) { + return x < y ? y : x; +} + +static inline uint64_t umax64(uint64_t x, uint64_t y) { + return x < y ? y : x; +} + +static inline uint8_t shl8(uint8_t x, uint8_t y) { + return (uint8_t)(x << y); +} + +static inline uint16_t shl16(uint16_t x, uint16_t y) { + return (uint16_t)(x << y); +} + +static inline uint32_t shl32(uint32_t x, uint32_t y) { + return x << y; +} + +static inline uint64_t shl64(uint64_t x, uint64_t y) { + return x << y; +} + +static inline uint8_t lshr8(uint8_t x, uint8_t y) { + return x >> y; +} + +static inline uint16_t lshr16(uint16_t x, uint16_t y) { + return x >> y; +} + +static inline uint32_t lshr32(uint32_t x, uint32_t y) { + return x >> y; +} + +static inline uint64_t lshr64(uint64_t x, uint64_t y) { + return x >> y; +} + +static inline int8_t ashr8(int8_t x, int8_t y) { + return x >> y; +} + +static inline int16_t ashr16(int16_t x, int16_t y) { + return x >> y; +} + +static inline int32_t ashr32(int32_t x, int32_t y) { + return x >> y; +} + +static inline int64_t ashr64(int64_t x, int64_t y) { + return x >> y; +} + +static inline uint8_t and8(uint8_t x, uint8_t y) { + return x & y; +} + +static inline uint16_t and16(uint16_t x, uint16_t y) { + return x & y; +} + +static inline uint32_t and32(uint32_t x, uint32_t y) { + return x & y; +} + +static inline uint64_t and64(uint64_t x, uint64_t y) { + return x & y; +} + +static inline uint8_t or8(uint8_t x, uint8_t y) { + return x | y; +} + +static inline uint16_t or16(uint16_t x, uint16_t y) { + return x | y; +} + +static inline uint32_t or32(uint32_t x, uint32_t y) { + return x | y; +} + +static inline uint64_t or64(uint64_t x, uint64_t y) { + return x | y; +} + +static inline uint8_t xor8(uint8_t x, uint8_t y) { + return x ^ y; +} + +static inline uint16_t xor16(uint16_t x, uint16_t y) { + return x ^ y; +} + +static inline uint32_t xor32(uint32_t x, uint32_t y) { + return x ^ y; +} + +static inline uint64_t xor64(uint64_t x, uint64_t y) { + return x ^ y; +} + +static inline bool ult8(uint8_t x, uint8_t y) { + return x < y; +} + +static inline bool ult16(uint16_t x, uint16_t y) { + return x < y; +} + +static inline bool ult32(uint32_t x, uint32_t y) { + return x < y; +} + +static inline bool ult64(uint64_t x, uint64_t y) { + return x < y; +} + +static inline bool ule8(uint8_t x, uint8_t y) { + return x <= y; +} + +static inline bool ule16(uint16_t x, uint16_t y) { + return x <= y; +} + +static inline bool ule32(uint32_t x, uint32_t y) { + return x <= y; +} + +static inline bool ule64(uint64_t x, uint64_t y) { + return x <= y; +} + +static inline bool slt8(int8_t x, int8_t y) { + return x < y; +} + +static inline bool slt16(int16_t x, int16_t y) { + return x < y; +} + +static inline bool slt32(int32_t x, int32_t y) { + return x < y; +} + +static inline bool slt64(int64_t x, int64_t y) { + return x < y; +} + +static inline bool sle8(int8_t x, int8_t y) { + return x <= y; +} + +static inline bool sle16(int16_t x, int16_t y) { + return x <= y; +} + +static inline bool sle32(int32_t x, int32_t y) { + return x <= y; +} + +static inline bool sle64(int64_t x, int64_t y) { + return x <= y; +} + +static inline uint8_t pow8(uint8_t x, uint8_t y) { + uint8_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +static inline uint16_t pow16(uint16_t x, uint16_t y) { + uint16_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +static inline uint32_t pow32(uint32_t x, uint32_t y) { + uint32_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +static inline uint64_t pow64(uint64_t x, uint64_t y) { + uint64_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +static inline bool itob_i8_bool(int8_t x) { + return x != 0; +} + +static inline bool itob_i16_bool(int16_t x) { + return x != 0; +} + +static inline bool itob_i32_bool(int32_t x) { + return x != 0; +} + +static inline bool itob_i64_bool(int64_t x) { + return x != 0; +} + +static inline int8_t btoi_bool_i8(bool x) { + return x; +} + +static inline int16_t btoi_bool_i16(bool x) { + return x; +} + +static inline int32_t btoi_bool_i32(bool x) { + return x; +} + +static inline int64_t btoi_bool_i64(bool x) { + return x; +} + +#define sext_i8_i8(x) ((int8_t) (int8_t) (x)) +#define sext_i8_i16(x) ((int16_t) (int8_t) (x)) +#define sext_i8_i32(x) ((int32_t) (int8_t) (x)) +#define sext_i8_i64(x) ((int64_t) (int8_t) (x)) +#define sext_i16_i8(x) ((int8_t) (int16_t) (x)) +#define sext_i16_i16(x) ((int16_t) (int16_t) (x)) +#define sext_i16_i32(x) ((int32_t) (int16_t) (x)) +#define sext_i16_i64(x) ((int64_t) (int16_t) (x)) +#define sext_i32_i8(x) ((int8_t) (int32_t) (x)) +#define sext_i32_i16(x) ((int16_t) (int32_t) (x)) +#define sext_i32_i32(x) ((int32_t) (int32_t) (x)) +#define sext_i32_i64(x) ((int64_t) (int32_t) (x)) +#define sext_i64_i8(x) ((int8_t) (int64_t) (x)) +#define sext_i64_i16(x) ((int16_t) (int64_t) (x)) +#define sext_i64_i32(x) ((int32_t) (int64_t) (x)) +#define sext_i64_i64(x) ((int64_t) (int64_t) (x)) +#define zext_i8_i8(x) ((int8_t) (uint8_t) (x)) +#define zext_i8_i16(x) ((int16_t) (uint8_t) (x)) +#define zext_i8_i32(x) ((int32_t) (uint8_t) (x)) +#define zext_i8_i64(x) ((int64_t) (uint8_t) (x)) +#define zext_i16_i8(x) ((int8_t) (uint16_t) (x)) +#define zext_i16_i16(x) ((int16_t) (uint16_t) (x)) +#define zext_i16_i32(x) ((int32_t) (uint16_t) (x)) +#define zext_i16_i64(x) ((int64_t) (uint16_t) (x)) +#define zext_i32_i8(x) ((int8_t) (uint32_t) (x)) +#define zext_i32_i16(x) ((int16_t) (uint32_t) (x)) +#define zext_i32_i32(x) ((int32_t) (uint32_t) (x)) +#define zext_i32_i64(x) ((int64_t) (uint32_t) (x)) +#define zext_i64_i8(x) ((int8_t) (uint64_t) (x)) +#define zext_i64_i16(x) ((int16_t) (uint64_t) (x)) +#define zext_i64_i32(x) ((int32_t) (uint64_t) (x)) +#define zext_i64_i64(x) ((int64_t) (uint64_t) (x)) + +static int8_t abs8(int8_t x) { + return (int8_t)abs(x); +} + +static int16_t abs16(int16_t x) { + return (int16_t)abs(x); +} + +static int32_t abs32(int32_t x) { + return abs(x); +} + +static int64_t abs64(int64_t x) { +#if defined(__OPENCL_VERSION__) || defined(ISPC) + return abs(x); +#else + return llabs(x); +#endif +} + +#if defined(__OPENCL_VERSION__) +static int32_t futrts_popc8(int8_t x) { + return popcount(x); +} + +static int32_t futrts_popc16(int16_t x) { + return popcount(x); +} + +static int32_t futrts_popc32(int32_t x) { + return popcount(x); +} + +static int32_t futrts_popc64(int64_t x) { + return popcount(x); +} +#elif defined(__CUDA_ARCH__) + +static int32_t futrts_popc8(int8_t x) { + return __popc(zext_i8_i32(x)); +} + +static int32_t futrts_popc16(int16_t x) { + return __popc(zext_i16_i32(x)); +} + +static int32_t futrts_popc32(int32_t x) { + return __popc(x); +} + +static int32_t futrts_popc64(int64_t x) { + return __popcll(x); +} + +#else // Not OpenCL or CUDA, but plain C. + +static int32_t futrts_popc8(uint8_t x) { + int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +static int32_t futrts_popc16(uint16_t x) { + int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +static int32_t futrts_popc32(uint32_t x) { + int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +static int32_t futrts_popc64(uint64_t x) { + int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} +#endif + +#if defined(__OPENCL_VERSION__) +static uint8_t futrts_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); +} + +#elif ISPC + +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) { + uint64_t ah = a >> 32; + uint64_t al = a & 0xffffffff; + uint64_t bh = b >> 32; + uint64_t bl = b & 0xffffffff; + + uint64_t p1 = al * bl; + uint64_t p2 = al * bh; + uint64_t p3 = ah * bl; + uint64_t p4 = ah * bh; + + uint64_t p1h = p1 >> 32; + uint64_t p2h = p2 >> 32; + uint64_t p3h = p3 >> 32; + uint64_t p2l = p2 & 0xffffffff; + uint64_t p3l = p3 & 0xffffffff; + + uint64_t l = p1h + p2l + p3l; + uint64_t m = (p2 >> 32) + (p3 >> 32); + uint64_t h = (l >> 32) + m + p4; + + return h; +} + +#else // Not OpenCL, ISPC, 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); +} + +#elif ISPC + +static int32_t futrts_clzz8(int8_t x) { + return count_leading_zeros((int32_t)(uint8_t)x)-24; +} + +static int32_t futrts_clzz16(int16_t x) { + return count_leading_zeros((int32_t)(uint16_t)x)-16; +} + +static int32_t futrts_clzz32(int32_t x) { + return count_leading_zeros(x); +} + +static int32_t futrts_clzz64(int64_t x) { + return count_leading_zeros(x); +} + +#else // Not OpenCL, ISPC or CUDA, but plain C. + +static int32_t futrts_clzz8(int8_t x) { + return x == 0 ? 8 : __builtin_clz((uint32_t)zext_i8_i32(x)) - 24; +} + +static int32_t futrts_clzz16(int16_t x) { + return x == 0 ? 16 : __builtin_clz((uint32_t)zext_i16_i32(x)) - 16; +} + +static int32_t futrts_clzz32(int32_t x) { + return x == 0 ? 32 : __builtin_clz((uint32_t)x); +} + +static int32_t futrts_clzz64(int64_t x) { + return x == 0 ? 64 : __builtin_clzll((uint64_t)x); +} +#endif + +#if defined(__OPENCL_VERSION__) +static int32_t futrts_ctzz8(int8_t x) { + int i = 0; + for (; i < 8 && (x & 1) == 0; i++, x >>= 1) + ; + return i; +} + +static int32_t futrts_ctzz16(int16_t x) { + int i = 0; + for (; i < 16 && (x & 1) == 0; i++, x >>= 1) + ; + return i; +} + +static int32_t futrts_ctzz32(int32_t x) { + int i = 0; + for (; i < 32 && (x & 1) == 0; i++, x >>= 1) + ; + return i; +} + +static int32_t futrts_ctzz64(int64_t x) { + int i = 0; + for (; i < 64 && (x & 1) == 0; i++, x >>= 1) + ; + return i; +} + +#elif defined(__CUDA_ARCH__) + +static int32_t futrts_ctzz8(int8_t x) { + int y = __ffs(x); + return y == 0 ? 8 : y - 1; +} + +static int32_t futrts_ctzz16(int16_t x) { + int y = __ffs(x); + return y == 0 ? 16 : y - 1; +} + +static int32_t futrts_ctzz32(int32_t x) { + int y = __ffs(x); + return y == 0 ? 32 : y - 1; +} + +static int32_t futrts_ctzz64(int64_t x) { + int y = __ffsll(x); + return y == 0 ? 64 : y - 1; +} + +#elif ISPC + +static int32_t futrts_ctzz8(int8_t x) { + return x == 0 ? 8 : count_trailing_zeros((int32_t)x); +} + +static int32_t futrts_ctzz16(int16_t x) { + return x == 0 ? 16 : count_trailing_zeros((int32_t)x); +} + +static int32_t futrts_ctzz32(int32_t x) { + return count_trailing_zeros(x); +} + +static int32_t futrts_ctzz64(int64_t x) { + return count_trailing_zeros(x); +} + +#else // Not OpenCL or CUDA, but plain C. + +static int32_t futrts_ctzz8(int8_t x) { + return x == 0 ? 8 : __builtin_ctz((uint32_t)x); +} + +static int32_t futrts_ctzz16(int16_t x) { + return x == 0 ? 16 : __builtin_ctz((uint32_t)x); +} + +static int32_t futrts_ctzz32(int32_t x) { + return x == 0 ? 32 : __builtin_ctz((uint32_t)x); +} + +static int32_t futrts_ctzz64(int64_t x) { + return x == 0 ? 64 : __builtin_ctzll((uint64_t)x); +} +#endif + +static inline float fdiv32(float x, float y) { + return x / y; +} + +static inline float fadd32(float x, float y) { + return x + y; +} + +static inline float fsub32(float x, float y) { + return x - y; +} + +static inline float fmul32(float x, float y) { + return x * y; +} + +static inline bool cmplt32(float x, float y) { + return x < y; +} + +static inline bool cmple32(float x, float y) { + return x <= y; +} + +static inline float sitofp_i8_f32(int8_t x) { + return (float) x; +} + +static inline float sitofp_i16_f32(int16_t x) { + return (float) x; +} + +static inline float sitofp_i32_f32(int32_t x) { + return (float) x; +} + +static inline float sitofp_i64_f32(int64_t x) { + return (float) x; +} + +static inline float uitofp_i8_f32(uint8_t x) { + return (float) x; +} + +static inline float uitofp_i16_f32(uint16_t x) { + return (float) x; +} + +static inline float uitofp_i32_f32(uint32_t x) { + return (float) x; +} + +static inline float uitofp_i64_f32(uint64_t x) { + return (float) x; +} + +#ifdef __OPENCL_VERSION__ +static inline float fabs32(float x) { + return fabs(x); +} + +static inline float fmax32(float x, float y) { + return fmax(x, y); +} + +static inline float fmin32(float x, float y) { + return fmin(x, y); +} + +static inline float fpow32(float x, float y) { + return pow(x, y); +} + +#elif ISPC + +static inline float fabs32(float x) { + return abs(x); +} + +static inline float fmax32(float x, float y) { + return isnan(x) ? y : isnan(y) ? x : max(x, y); +} + +static inline float fmin32(float x, float y) { + return isnan(x) ? y : isnan(y) ? x : min(x, y); +} + +static inline float fpow32(float a, float b) { + float ret; + foreach_active (i) { + uniform float r = __stdlib_powf(extract(a, i), extract(b, i)); + ret = insert(ret, i, r); + } + return ret; +} + +#else // Not OpenCL, but CUDA or plain C. + +static inline float fabs32(float x) { + return fabsf(x); +} + +static inline float fmax32(float x, float y) { + return fmaxf(x, y); +} + +static inline float fmin32(float x, float y) { + return fminf(x, y); +} + +static inline float fpow32(float x, float y) { + return powf(x, y); +} +#endif + +static inline bool futrts_isnan32(float x) { + return isnan(x); +} + +#if ISPC + +static inline bool futrts_isinf32(float x) { + return !isnan(x) && isnan(x - x); +} + +static inline bool futrts_isfinite32(float x) { + return !isnan(x) && !futrts_isinf32(x); +} + +#else + +static inline bool futrts_isinf32(float x) { + return isinf(x); +} + +#endif + +static inline int8_t fptosi_f32_i8(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (int8_t) x; + } +} + +static inline int16_t fptosi_f32_i16(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (int16_t) x; + } +} + +static inline int32_t fptosi_f32_i32(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (int32_t) x; + } +} + +static inline int64_t fptosi_f32_i64(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (int64_t) x; + }; +} + +static inline uint8_t fptoui_f32_i8(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uint8_t) (int8_t) x; + } +} + +static inline uint16_t fptoui_f32_i16(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uint16_t) (int16_t) x; + } +} + +static inline uint32_t fptoui_f32_i32(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uint32_t) (int32_t) x; + } +} + +static inline uint64_t fptoui_f32_i64(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uint64_t) (int64_t) x; + } +} + +static inline bool ftob_f32_bool(float x) { + return x != 0; +} + +static inline float btof_bool_f32(bool x) { + return x ? 1 : 0; +} + +#ifdef __OPENCL_VERSION__ +static inline float futrts_log32(float x) { + return log(x); +} + +static inline float futrts_log2_32(float x) { + return log2(x); +} + +static inline float futrts_log10_32(float x) { + return log10(x); +} + +static inline float futrts_sqrt32(float x) { + return sqrt(x); +} + +static inline float futrts_cbrt32(float x) { + return cbrt(x); +} + +static inline float futrts_exp32(float x) { + return exp(x); +} + +static inline float futrts_cos32(float x) { + return cos(x); +} + +static inline float futrts_sin32(float x) { + return sin(x); +} + +static inline float futrts_tan32(float x) { + return tan(x); +} + +static inline float futrts_acos32(float x) { + return acos(x); +} + +static inline float futrts_asin32(float x) { + return asin(x); +} + +static inline float futrts_atan32(float x) { + return atan(x); +} + +static inline float futrts_cosh32(float x) { + return cosh(x); +} + +static inline float futrts_sinh32(float x) { + return sinh(x); +} + +static inline float futrts_tanh32(float x) { + return tanh(x); +} + +static inline float futrts_acosh32(float x) { + return acosh(x); +} + +static inline float futrts_asinh32(float x) { + return asinh(x); +} + +static inline float futrts_atanh32(float x) { + return atanh(x); +} + +static inline float futrts_atan2_32(float x, float y) { + return atan2(x, y); +} + +static inline float futrts_hypot32(float x, float y) { + return hypot(x, y); +} + +static inline float futrts_gamma32(float x) { + return tgamma(x); +} + +static inline float futrts_lgamma32(float x) { + return lgamma(x); +} + +static inline float futrts_erf32(float x) { + return erf(x); +} + +static inline float futrts_erfc32(float x) { + return erfc(x); +} + +static inline float fmod32(float x, float y) { + return fmod(x, y); +} + +static inline float futrts_round32(float x) { + return rint(x); +} + +static inline float futrts_floor32(float x) { + return floor(x); +} + +static inline float futrts_ceil32(float x) { + return ceil(x); +} + +static inline float futrts_lerp32(float v0, float v1, float t) { + return mix(v0, v1, t); +} + +static inline float futrts_mad32(float a, float b, float c) { + return mad(a, b, c); +} + +static inline float futrts_fma32(float a, float b, float c) { + return fma(a, b, c); +} + +#elif ISPC + +static inline float futrts_log32(float x) { + return futrts_isfinite32(x) || (futrts_isinf32(x) && x < 0)? log(x) : x; +} + +static inline float futrts_log2_32(float x) { + return futrts_log32(x) / log(2.0f); +} + +static inline float futrts_log10_32(float x) { + return futrts_log32(x) / log(10.0f); +} + +static inline float futrts_sqrt32(float x) { + return sqrt(x); +} + +extern "C" unmasked uniform float cbrtf(uniform float); +static inline float futrts_cbrt32(float x) { + float res; + foreach_active (i) { + uniform float r = cbrtf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +static inline float futrts_exp32(float x) { + return exp(x); +} + +static inline float futrts_cos32(float x) { + return cos(x); +} + +static inline float futrts_sin32(float x) { + return sin(x); +} + +static inline float futrts_tan32(float x) { + return tan(x); +} + +static inline float futrts_acos32(float x) { + return acos(x); +} + +static inline float futrts_asin32(float x) { + return asin(x); +} + +static inline float futrts_atan32(float x) { + return atan(x); +} + +static inline float futrts_cosh32(float x) { + return (exp(x)+exp(-x)) / 2.0f; +} + +static inline float futrts_sinh32(float x) { + return (exp(x)-exp(-x)) / 2.0f; +} + +static inline float futrts_tanh32(float x) { + return futrts_sinh32(x)/futrts_cosh32(x); +} + +static inline float futrts_acosh32(float x) { + float f = x+sqrt(x*x-1); + if(futrts_isfinite32(f)) return log(f); + return f; +} + +static inline float futrts_asinh32(float x) { + float f = x+sqrt(x*x+1); + if(futrts_isfinite32(f)) return log(f); + return f; + +} + +static inline float futrts_atanh32(float x) { + float f = (1+x)/(1-x); + if(futrts_isfinite32(f)) return log(f)/2.0f; + return f; + +} + +static inline float futrts_atan2_32(float x, float y) { + return (x == 0.0f && y == 0.0f) ? 0.0f : atan2(x, y); +} + +static inline float futrts_hypot32(float x, float y) { + if (futrts_isfinite32(x) && futrts_isfinite32(y)) { + x = abs(x); + y = abs(y); + float a; + float b; + if (x >= y){ + a = x; + b = y; + } else { + a = y; + b = x; + } + if(b == 0){ + return a; + } + + int e; + float an; + float bn; + an = frexp (a, &e); + bn = ldexp (b, - e); + float cn; + cn = sqrt (an * an + bn * bn); + return ldexp (cn, e); + } else { + if (futrts_isinf32(x) || futrts_isinf32(y)) return INFINITY; + else return x + y; + } + +} + +extern "C" unmasked uniform float tgammaf(uniform float x); +static inline float futrts_gamma32(float x) { + float res; + foreach_active (i) { + uniform float r = tgammaf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform float lgammaf(uniform float x); +static inline float futrts_lgamma32(float x) { + float res; + foreach_active (i) { + uniform float r = lgammaf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform float erff(uniform float x); +static inline float futrts_erf32(float x) { + float res; + foreach_active (i) { + uniform float r = erff(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform float erfcf(uniform float x); +static inline float futrts_erfc32(float x) { + float res; + foreach_active (i) { + uniform float r = erfcf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +static inline float fmod32(float x, float y) { + return x - y * trunc(x/y); +} + +static inline float futrts_round32(float x) { + return round(x); +} + +static inline float futrts_floor32(float x) { + return floor(x); +} + +static inline float futrts_ceil32(float x) { + return ceil(x); +} + +static inline float futrts_lerp32(float v0, float v1, float t) { + return v0 + (v1 - v0) * t; +} + +static inline float futrts_mad32(float a, float b, float c) { + return a * b + c; +} + +static inline float futrts_fma32(float a, float b, float c) { + return a * b + c; +} + +#else // Not OpenCL or ISPC, but CUDA or plain C. + +static inline float futrts_log32(float x) { + return logf(x); +} + +static inline float futrts_log2_32(float x) { + return log2f(x); +} + +static inline float futrts_log10_32(float x) { + return log10f(x); +} + +static inline float futrts_sqrt32(float x) { + return sqrtf(x); +} + +static inline float futrts_cbrt32(float x) { + return cbrtf(x); +} + +static inline float futrts_exp32(float x) { + return expf(x); +} + +static inline float futrts_cos32(float x) { + return cosf(x); +} + +static inline float futrts_sin32(float x) { + return sinf(x); +} + +static inline float futrts_tan32(float x) { + return tanf(x); +} + +static inline float futrts_acos32(float x) { + return acosf(x); +} + +static inline float futrts_asin32(float x) { + return asinf(x); +} + +static inline float futrts_atan32(float x) { + return atanf(x); +} + +static inline float futrts_cosh32(float x) { + return coshf(x); +} + +static inline float futrts_sinh32(float x) { + return sinhf(x); +} + +static inline float futrts_tanh32(float x) { + return tanhf(x); +} + +static inline float futrts_acosh32(float x) { + return acoshf(x); +} + +static inline float futrts_asinh32(float x) { + return asinhf(x); +} + +static inline float futrts_atanh32(float x) { + return atanhf(x); +} + +static inline float futrts_atan2_32(float x, float y) { + return atan2f(x, y); +} + +static inline float futrts_hypot32(float x, float y) { + return hypotf(x, y); +} + +static inline float futrts_gamma32(float x) { + return tgammaf(x); +} + +static inline float futrts_lgamma32(float x) { + return lgammaf(x); +} + +static inline float futrts_erf32(float x) { + return erff(x); +} + +static inline float futrts_erfc32(float x) { + return erfcf(x); +} + +static inline float fmod32(float x, float y) { + return fmodf(x, y); +} + +static inline float futrts_round32(float x) { + return rintf(x); +} + +static inline float futrts_floor32(float x) { + return floorf(x); +} + +static inline float futrts_ceil32(float x) { + return ceilf(x); +} + +static inline float futrts_lerp32(float v0, float v1, float t) { + return v0 + (v1 - v0) * t; +} + +static inline float futrts_mad32(float a, float b, float c) { + return a * b + c; +} + +static inline float futrts_fma32(float a, float b, float c) { + return fmaf(a, b, c); +} +#endif + +#if ISPC +static inline int32_t futrts_to_bits32(float x) { + return intbits(x); +} + +static inline float futrts_from_bits32(int32_t x) { + return floatbits(x); +} +#else +static inline int32_t futrts_to_bits32(float x) { + union { + float f; + int32_t t; + } p; + + p.f = x; + return p.t; +} + +static inline float futrts_from_bits32(int32_t x) { + union { + int32_t f; + float t; + } p; + + p.f = x; + return p.t; +} +#endif + +static inline float fsignum32(float x) { + return futrts_isnan32(x) ? x : (x > 0 ? 1 : 0) - (x < 0 ? 1 : 0); +} + +#ifdef FUTHARK_F64_ENABLED + +#if ISPC +static inline bool futrts_isinf64(float x) { + return !isnan(x) && isnan(x - x); +} + +static inline bool futrts_isfinite64(float x) { + return !isnan(x) && !futrts_isinf64(x); +} + +static inline double fdiv64(double x, double y) { + return x / y; +} + +static inline double fadd64(double x, double y) { + return x + y; +} + +static inline double fsub64(double x, double y) { + return x - y; +} + +static inline double fmul64(double x, double y) { + return x * y; +} + +static inline bool cmplt64(double x, double y) { + return x < y; +} + +static inline bool cmple64(double x, double y) { + return x <= y; +} + +static inline double sitofp_i8_f64(int8_t x) { + return (double) x; +} + +static inline double sitofp_i16_f64(int16_t x) { + return (double) x; +} + +static inline double sitofp_i32_f64(int32_t x) { + return (double) x; +} + +static inline double sitofp_i64_f64(int64_t x) { + return (double) x; +} + +static inline double uitofp_i8_f64(uint8_t x) { + return (double) x; +} + +static inline double uitofp_i16_f64(uint16_t x) { + return (double) x; +} + +static inline double uitofp_i32_f64(uint32_t x) { + return (double) x; +} + +static inline double uitofp_i64_f64(uint64_t x) { + return (double) x; +} + +static inline double fabs64(double x) { + return abs(x); +} + +static inline double fmax64(double x, double y) { + return isnan(x) ? y : isnan(y) ? x : max(x, y); +} + +static inline double fmin64(double x, double y) { + return isnan(x) ? y : isnan(y) ? x : min(x, y); +} + +static inline double fpow64(double a, double b) { + float ret; + foreach_active (i) { + uniform float r = __stdlib_powf(extract(a, i), extract(b, i)); + ret = insert(ret, i, r); + } + return ret; +} + +static inline double futrts_log64(double x) { + return futrts_isfinite64(x) || (futrts_isinf64(x) && x < 0)? log(x) : x; +} + +static inline double futrts_log2_64(double x) { + return futrts_log64(x)/log(2.0d); +} + +static inline double futrts_log10_64(double x) { + return futrts_log64(x)/log(10.0d); +} + +static inline double futrts_sqrt64(double x) { + return sqrt(x); +} + +extern "C" unmasked uniform double cbrt(uniform double); +static inline double futrts_cbrt64(double x) { + double res; + foreach_active (i) { + uniform double r = cbrtf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +static inline double futrts_exp64(double x) { + return exp(x); +} + +static inline double futrts_cos64(double x) { + return cos(x); +} + +static inline double futrts_sin64(double x) { + return sin(x); +} + +static inline double futrts_tan64(double x) { + return tan(x); +} + +static inline double futrts_acos64(double x) { + return acos(x); +} + +static inline double futrts_asin64(double x) { + return asin(x); +} + +static inline double futrts_atan64(double x) { + return atan(x); +} + +static inline double futrts_cosh64(double x) { + return (exp(x)+exp(-x)) / 2.0d; +} + +static inline double futrts_sinh64(double x) { + return (exp(x)-exp(-x)) / 2.0d; +} + +static inline double futrts_tanh64(double x) { + return futrts_sinh64(x)/futrts_cosh64(x); +} + +static inline double futrts_acosh64(double x) { + double f = x+sqrt(x*x-1.0d); + if(futrts_isfinite64(f)) return log(f); + return f; +} + +static inline double futrts_asinh64(double x) { + double f = x+sqrt(x*x+1.0d); + if(futrts_isfinite64(f)) return log(f); + return f; +} + +static inline double futrts_atanh64(double x) { + double f = (1.0d+x)/(1.0d-x); + if(futrts_isfinite64(f)) return log(f)/2.0d; + return f; + +} + +static inline double futrts_atan2_64(double x, double y) { + return atan2(x, y); +} + +extern "C" unmasked uniform double hypot(uniform double x, uniform double y); +static inline double futrts_hypot64(double x, double y) { + double res; + foreach_active (i) { + uniform double r = hypot(extract(x, i), extract(y, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform double tgamma(uniform double x); +static inline double futrts_gamma64(double x) { + double res; + foreach_active (i) { + uniform double r = tgamma(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform double lgamma(uniform double x); +static inline double futrts_lgamma64(double x) { + double res; + foreach_active (i) { + uniform double r = lgamma(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform double erf(uniform double x); +static inline double futrts_erf64(double x) { + double res; + foreach_active (i) { + uniform double r = erf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform double erfc(uniform double x); +static inline double futrts_erfc64(double x) { + double res; + foreach_active (i) { + uniform double r = erfc(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +static inline double futrts_fma64(double a, double b, double c) { + return a * b + c; +} + +static inline double futrts_round64(double x) { + return round(x); +} + +static inline double futrts_ceil64(double x) { + return ceil(x); +} + +static inline double futrts_floor64(double x) { + return floor(x); +} + +static inline bool futrts_isnan64(double x) { + return isnan(x); +} + +static inline int8_t fptosi_f64_i8(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int8_t) x; + } +} + +static inline int16_t fptosi_f64_i16(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int16_t) x; + } +} + +static inline int32_t fptosi_f64_i32(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int32_t) x; + } +} + +static inline int64_t fptosi_f64_i64(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int64_t) x; + } +} + +static inline uint8_t fptoui_f64_i8(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint8_t) (int8_t) x; + } +} + +static inline uint16_t fptoui_f64_i16(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint16_t) (int16_t) x; + } +} + +static inline uint32_t fptoui_f64_i32(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint32_t) (int32_t) x; + } +} + +static inline uint64_t fptoui_f64_i64(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint64_t) (int64_t) x; + } +} + +static inline bool ftob_f64_bool(double x) { + return x != 0.0; +} + +static inline double btof_bool_f64(bool x) { + return x ? 1.0 : 0.0; +} + +static inline int64_t futrts_to_bits64(double x) { + int64_t res; + foreach_active (i) { + uniform double tmp = extract(x, i); + uniform int64_t r = *((uniform int64_t* uniform)&tmp); + res = insert(res, i, r); + } + return res; +} + +static inline double futrts_from_bits64(int64_t x) { + double res; + foreach_active (i) { + uniform int64_t tmp = extract(x, i); + uniform double r = *((uniform double* uniform)&tmp); + res = insert(res, i, r); + } + return res; +} + +static inline double fmod64(double x, double y) { + return x - y * trunc(x/y); +} + +static inline double fsignum64(double x) { + return futrts_isnan64(x) ? x : (x > 0 ? 1.0d : 0.0d) - (x < 0 ? 1.0d : 0.0d); +} + +static inline double futrts_lerp64(double v0, double v1, double t) { + return v0 + (v1 - v0) * t; +} + +static inline double futrts_mad64(double a, double b, double c) { + return a * b + c; +} + +static inline float fpconv_f32_f32(float x) { + return (float) x; +} + +static inline double fpconv_f32_f64(float x) { + return (double) x; +} + +static inline float fpconv_f64_f32(double x) { + return (float) x; +} + +static inline double fpconv_f64_f64(double x) { + return (double) x; +} + +#else + +static inline double fdiv64(double x, double y) { + return x / y; +} + +static inline double fadd64(double x, double y) { + return x + y; +} + +static inline double fsub64(double x, double y) { + return x - y; +} + +static inline double fmul64(double x, double y) { + return x * y; +} + +static inline bool cmplt64(double x, double y) { + return x < y; +} + +static inline bool cmple64(double x, double y) { + return x <= y; +} + +static inline double sitofp_i8_f64(int8_t x) { + return (double) x; +} + +static inline double sitofp_i16_f64(int16_t x) { + return (double) x; +} + +static inline double sitofp_i32_f64(int32_t x) { + return (double) x; +} + +static inline double sitofp_i64_f64(int64_t x) { + return (double) x; +} + +static inline double uitofp_i8_f64(uint8_t x) { + return (double) x; +} + +static inline double uitofp_i16_f64(uint16_t x) { + return (double) x; +} + +static inline double uitofp_i32_f64(uint32_t x) { + return (double) x; +} + +static inline double uitofp_i64_f64(uint64_t x) { + return (double) x; +} + +static inline double fabs64(double x) { + return fabs(x); +} + +static inline double fmax64(double x, double y) { + return fmax(x, y); +} + +static inline double fmin64(double x, double y) { + return fmin(x, y); +} + +static inline double fpow64(double x, double y) { + return pow(x, y); +} + +static inline double futrts_log64(double x) { + return log(x); +} + +static inline double futrts_log2_64(double x) { + return log2(x); +} + +static inline double futrts_log10_64(double x) { + return log10(x); +} + +static inline double futrts_sqrt64(double x) { + return sqrt(x); +} + +static inline double futrts_cbrt64(double x) { + return cbrt(x); +} + +static inline double futrts_exp64(double x) { + return exp(x); +} + +static inline double futrts_cos64(double x) { + return cos(x); +} + +static inline double futrts_sin64(double x) { + return sin(x); +} + +static inline double futrts_tan64(double x) { + return tan(x); +} + +static inline double futrts_acos64(double x) { + return acos(x); +} + +static inline double futrts_asin64(double x) { + return asin(x); +} + +static inline double futrts_atan64(double x) { + return atan(x); +} + +static inline double futrts_cosh64(double x) { + return cosh(x); +} + +static inline double futrts_sinh64(double x) { + return sinh(x); +} + +static inline double futrts_tanh64(double x) { + return tanh(x); +} + +static inline double futrts_acosh64(double x) { + return acosh(x); +} + +static inline double futrts_asinh64(double x) { + return asinh(x); +} + +static inline double futrts_atanh64(double x) { + return atanh(x); +} + +static inline double futrts_atan2_64(double x, double y) { + return atan2(x, y); +} + +static inline double futrts_hypot64(double x, double y) { + return hypot(x, y); +} + +static inline double futrts_gamma64(double x) { + return tgamma(x); +} + +static inline double futrts_lgamma64(double x) { + return lgamma(x); +} + +static inline double futrts_erf64(double x) { + return erf(x); +} + +static inline double futrts_erfc64(double x) { + return erfc(x); +} + +static inline double futrts_fma64(double a, double b, double c) { + return fma(a, b, c); +} + +static inline double futrts_round64(double x) { + return rint(x); +} + +static inline double futrts_ceil64(double x) { + return ceil(x); +} + +static inline double futrts_floor64(double x) { + return floor(x); +} + +static inline bool futrts_isnan64(double x) { + return isnan(x); +} + +static inline bool futrts_isinf64(double x) { + return isinf(x); +} + +static inline int8_t fptosi_f64_i8(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int8_t) x; + } +} + +static inline int16_t fptosi_f64_i16(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int16_t) x; + } +} + +static inline int32_t fptosi_f64_i32(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int32_t) x; + } +} + +static inline int64_t fptosi_f64_i64(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int64_t) x; + } +} + +static inline uint8_t fptoui_f64_i8(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint8_t) (int8_t) x; + } +} + +static inline uint16_t fptoui_f64_i16(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint16_t) (int16_t) x; + } +} + +static inline uint32_t fptoui_f64_i32(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint32_t) (int32_t) x; + } +} + +static inline uint64_t fptoui_f64_i64(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint64_t) (int64_t) x; + } +} + +static inline bool ftob_f64_bool(double x) { + return x != 0; +} + +static inline double btof_bool_f64(bool x) { + return x ? 1 : 0; +} + +static inline int64_t futrts_to_bits64(double x) { + union { + double f; + int64_t t; + } p; + + p.f = x; + return p.t; +} + +static inline double futrts_from_bits64(int64_t x) { + union { + int64_t f; + double t; + } p; + + p.f = x; + return p.t; +} + +static inline double fmod64(double x, double y) { + return fmod(x, y); +} + +static inline double fsignum64(double x) { + return futrts_isnan64(x) ? x : (x > 0) - (x < 0); +} + +static inline double futrts_lerp64(double v0, double v1, double t) { +#ifdef __OPENCL_VERSION__ + return mix(v0, v1, t); +#else + return v0 + (v1 - v0) * t; +#endif +} + +static inline double futrts_mad64(double a, double b, double c) { +#ifdef __OPENCL_VERSION__ + return mad(a, b, c); +#else + return a * b + c; +#endif +} + +static inline float fpconv_f32_f32(float x) { + return (float) x; +} + +static inline double fpconv_f32_f64(float x) { + return (double) x; +} + +static inline float fpconv_f64_f32(double x) { + return (float) x; +} + +static inline double fpconv_f64_f64(double x) { + return (double) x; +} + +#endif #endif diff --git a/rts/c/scalar_f16.h b/rts/c/scalar_f16.h --- a/rts/c/scalar_f16.h +++ b/rts/c/scalar_f16.h @@ -9,7 +9,7 @@ // 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) +#if !defined(cl_khr_fp16) && !(defined(__CUDA_ARCH__) && __CUDA_ARCH__ >= 600) && !(defined(ISPC)) #define EMULATE_F16 #endif @@ -23,6 +23,9 @@ // compiler will have to be real careful! typedef float f16; +#elif ISPC +typedef float16 f16; + #else #ifdef __CUDA_ARCH__ @@ -129,8 +132,12 @@ } #ifndef EMULATE_F16 +static inline bool futrts_isnan16(f16 x) { + return isnan((float)x); +} #ifdef __OPENCL_VERSION__ + static inline f16 fabs16(f16 x) { return fabs(x); } @@ -147,6 +154,22 @@ return pow(x, y); } +#elif ISPC +static inline f16 fabs16(f16 x) { + return abs(x); +} + +static inline f16 fmax16(f16 x, f16 y) { + return futrts_isnan16(x) ? y : futrts_isnan16(y) ? x : max(x, y); +} + +static inline f16 fmin16(f16 x, f16 y) { + return futrts_isnan16(x) ? y : futrts_isnan16(y) ? x : min(x, y); +} + +static inline f16 fpow16(f16 x, f16 y) { + return pow(x, y); +} #else // Assuming CUDA. static inline f16 fabs16(f16 x) { @@ -166,13 +189,20 @@ } #endif -static inline bool futrts_isnan16(f16 x) { - return isnan((float)x); +#if ISPC +static inline bool futrts_isinf16(float x) { + return !futrts_isnan16(x) && futrts_isnan16(x - x); } +static inline bool futrts_isfinite16(float x) { + return !futrts_isnan16(x) && !futrts_isinf16(x); +} +#else + static inline bool futrts_isinf16(f16 x) { return isinf((float)x); } +#endif #ifdef __OPENCL_VERSION__ static inline f16 futrts_log16(f16 x) { @@ -298,7 +328,153 @@ static inline f16 futrts_fma16(f16 a, f16 b, f16 c) { return fma(a, b, c); } +#elif ISPC +static inline f16 futrts_log16(f16 x) { + return futrts_isfinite16(x) || (futrts_isinf16(x) && x < 0) ? log(x) : x; +} + +static inline f16 futrts_log2_16(f16 x) { + return futrts_log16(x) / log(2.0f16); +} + +static inline f16 futrts_log10_16(f16 x) { + return futrts_log16(x) / log(10.0f16); +} + +static inline f16 futrts_sqrt16(f16 x) { + return (float16)sqrt((float)x); +} + +static inline f16 futrts_exp16(f16 x) { + return exp(x); +} + +static inline f16 futrts_cos16(f16 x) { + return (float16)cos((float)x); +} + +static inline f16 futrts_sin16(f16 x) { + return (float16)sin((float)x); +} + +static inline f16 futrts_tan16(f16 x) { + return (float16)tan((float)x); +} + +static inline f16 futrts_acos16(f16 x) { + return (float16)acos((float)x); +} + +static inline f16 futrts_asin16(f16 x) { + return (float16)asin((float)x); +} + +static inline f16 futrts_atan16(f16 x) { + return (float16)atan((float)x); +} + +static inline f16 futrts_cosh16(f16 x) { + return (exp(x)+exp(-x)) / 2.0f16; +} + +static inline f16 futrts_sinh16(f16 x) { + return (exp(x)-exp(-x)) / 2.0f16; +} + +static inline f16 futrts_tanh16(f16 x) { + return futrts_sinh16(x)/futrts_cosh16(x); +} + +static inline f16 futrts_acosh16(f16 x) { + float16 f = x+(float16)sqrt((float)(x*x-1)); + if(futrts_isfinite16(f)) return log(f); + return f; +} + +static inline f16 futrts_asinh16(f16 x) { + float16 f = x+(float16)sqrt((float)(x*x+1)); + if(futrts_isfinite16(f)) return log(f); + return f; +} + +static inline f16 futrts_atanh16(f16 x) { + float16 f = (1+x)/(1-x); + if(futrts_isfinite16(f)) return log(f)/2.0f16; + return f; +} + +static inline f16 futrts_atan2_16(f16 x, f16 y) { + return (float16)atan2((float)x, (float)y); +} + +static inline f16 futrts_hypot16(f16 x, f16 y) { + return (float16)futrts_hypot32((float)x, (float)y); +} + +extern "C" unmasked uniform float tgammaf(uniform float x); +static inline f16 futrts_gamma16(f16 x) { + f16 res; + foreach_active (i) { + uniform f16 r = (f16)tgammaf(extract((float)x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform float lgammaf(uniform float x); +static inline f16 futrts_lgamma16(f16 x) { + f16 res; + foreach_active (i) { + uniform f16 r = (f16)lgammaf(extract((float)x, i)); + res = insert(res, i, r); + } + return res; +} + +static inline f16 futrts_cbrt16(f16 x) { + f16 res = (f16)futrts_cbrt32((float)x); + return res; +} + +static inline f16 futrts_erf16(f16 x) { + f16 res = (f16)futrts_erf32((float)x); + return res; +} + +static inline f16 futrts_erfc16(f16 x) { + f16 res = (f16)futrts_erfc32((float)x); + return res; +} + +static inline f16 fmod16(f16 x, f16 y) { + return x - y * (float16)trunc((float) (x/y)); +} + +static inline f16 futrts_round16(f16 x) { + return (float16)round((float)x); +} + +static inline f16 futrts_floor16(f16 x) { + return (float16)floor((float)x); +} + +static inline f16 futrts_ceil16(f16 x) { + return (float16)ceil((float)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 a * b + c; +} + #else // Assume CUDA. static inline f16 futrts_log16(f16 x) { @@ -436,6 +612,17 @@ static inline f16 futrts_from_bits16(int16_t x) { return __ushort_as_half(x); } +#elif ISPC + +static inline int16_t futrts_to_bits16(f16 x) { + varying int16_t y = *((varying int16_t * uniform)&x); + return y; +} + +static inline f16 futrts_from_bits16(int16_t x) { + varying f16 y = *((varying f16 * uniform)&x); + return y; +} #else static inline int16_t futrts_to_bits16(f16 x) { union { @@ -636,7 +823,7 @@ } static inline f16 fsignum16(f16 x) { - return futrts_isnan16(x) ? x : (x > 0) - (x < 0); + return futrts_isnan16(x) ? x : (x > 0 ? 1 : 0) - (x < 0 ? 1 : 0); } #endif @@ -652,7 +839,7 @@ } static inline f16 fpconv_f32_f16(float x) { - return x; + return (f16) x; } #ifdef FUTHARK_F64_ENABLED @@ -661,10 +848,15 @@ return (double) x; } +#if ISPC static inline f16 fpconv_f64_f16(double x) { + return (f16) ((float)x); +} +#else +static inline f16 fpconv_f64_f16(double x) { return (f16) x; } - +#endif #endif diff --git a/rts/c/scheduler.h b/rts/c/scheduler.h --- a/rts/c/scheduler.h +++ b/rts/c/scheduler.h @@ -495,7 +495,9 @@ struct scheduler { struct worker *workers; int num_threads; + int minimum_chunk_size; + // If there is work to steal => active_work > 0 volatile int active_work; @@ -534,12 +536,11 @@ return i; } - -static inline int64_t compute_chunk_size(double kappa, struct subtask* subtask) +static inline int64_t compute_chunk_size(int64_t minimum_chunk_size, double kappa, struct subtask* subtask) { double C = (double)*subtask->task_time / (double)*subtask->task_iter; if (C == 0.0F) C += DBL_EPSILON; - return smax64((int64_t)(kappa / C), 1); + return smax64((int64_t)(kappa / C), minimum_chunk_size); } /* Takes a chunk from subtask and enqueues the remaining iterations onto the worker's queue */ @@ -549,7 +550,9 @@ if (subtask->chunkable) { // Do we have information from previous runs avaliable if (*subtask->task_iter > 0) { - subtask->chunk_size = compute_chunk_size(worker->scheduler->kappa, subtask); + subtask->chunk_size = compute_chunk_size(worker->scheduler->minimum_chunk_size, + worker->scheduler->kappa, + subtask); assert(subtask->chunk_size > 0); } int64_t remaining_iter = subtask->end - subtask->start; @@ -790,7 +793,7 @@ enum scheduling sched = info.sched; /* If each subtasks should be processed in chunks */ int chunkable = sched == STATIC ? 0 : 1; - int64_t chunk_size = 1; // The initial chunk size when no info is avaliable + int64_t chunk_size = scheduler->minimum_chunk_size; // The initial chunk size when no info is avaliable if (info.wake_up_threads || sched == DYNAMIC) @@ -1076,6 +1079,13 @@ static int scheduler_init(struct scheduler *scheduler, int num_workers, double kappa) { +#ifdef FUTHARK_BACKEND_ispc + int64_t get_gang_size(); + scheduler->minimum_chunk_size = get_gang_size(); +#else + scheduler->minimum_chunk_size = 1; +#endif + assert(num_workers > 0); scheduler->kappa = kappa; diff --git a/rts/c/server.h b/rts/c/server.h --- a/rts/c/server.h +++ b/rts/c/server.h @@ -14,13 +14,28 @@ typedef int (*restore_fn)(const void*, FILE *, struct futhark_context*, void*); typedef void (*store_fn)(const void*, FILE *, struct futhark_context*, void*); typedef int (*free_fn)(const void*, struct futhark_context*, void*); +typedef int (*project_fn)(struct futhark_context*, void*, const void*); +typedef int (*new_fn)(struct futhark_context*, void**, const void*[]); +struct field { + const char *name; + const struct type *type; + project_fn project; +}; + +struct record { + int num_fields; + const struct field* fields; + new_fn new; +}; + struct type { const char *name; restore_fn restore; store_fn store; free_fn free; const void *aux; + const struct record *record; }; int free_scalar(const void *aux, struct futhark_context *ctx, void *p) { @@ -31,27 +46,27 @@ return 0; } -#define DEF_SCALAR_TYPE(T) \ - int restore_##T(const void *aux, FILE *f, \ - struct futhark_context *ctx, void *p) { \ - (void)aux; \ - (void)ctx; \ - return read_scalar(f, &T##_info, p); \ - } \ - \ - void store_##T(const void *aux, FILE *f, \ - struct futhark_context *ctx, void *p) { \ - (void)aux; \ - (void)ctx; \ - write_scalar(f, 1, &T##_info, p); \ - } \ - \ - struct type type_##T = \ - { .name = #T, \ - .restore = restore_##T, \ - .store = store_##T, \ - .free = free_scalar \ - } \ +#define DEF_SCALAR_TYPE(T) \ + int restore_##T(const void *aux, FILE *f, \ + struct futhark_context *ctx, void *p) { \ + (void)aux; \ + (void)ctx; \ + return read_scalar(f, &T##_info, p); \ + } \ + \ + void store_##T(const void *aux, FILE *f, \ + struct futhark_context *ctx, void *p) { \ + (void)aux; \ + (void)ctx; \ + write_scalar(f, 1, &T##_info, p); \ + } \ + \ + struct type type_##T = \ + { .name = #T, \ + .restore = restore_##T, \ + .store = store_##T, \ + .free = free_scalar \ + } \ DEF_SCALAR_TYPE(i8); DEF_SCALAR_TYPE(i16); @@ -67,7 +82,7 @@ DEF_SCALAR_TYPE(bool); struct value { - struct type *type; + const struct type *type; union { void *v_ptr; int8_t v_i8; @@ -139,9 +154,9 @@ struct entry_point { const char *name; entry_point_fn f; - struct type **out_types; + const struct type **out_types; bool *out_unique; - struct type **in_types; + const struct type **in_types; bool *in_unique; }; @@ -165,7 +180,7 @@ // Last entry point identified by NULL name. struct entry_point *entry_points; // Last type identified by NULL name. - struct type **types; + const struct type **types; }; struct server_state { @@ -190,7 +205,7 @@ struct variable* create_variable(struct server_state *s, const char *name, - struct type *type) { + const struct type *type) { int found = -1; for (int i = 0; i < s->variables_capacity; i++) { if (found == -1 && s->variables[i].name == NULL) { @@ -240,7 +255,7 @@ return args[i]; } -struct type* get_type(struct server_state *s, const char *name) { +const struct type* get_type(struct server_state *s, const char *name) { for (int i = 0; s->prog.types[i]; i++) { if (strcmp(s->prog.types[i]->name, name) == 0) { return s->prog.types[i]; @@ -364,7 +379,7 @@ const char *vname = get_arg(args, i); const char *type = get_arg(args, i+1); - struct type *t = get_type(s, type); + const struct type *t = get_type(s, type); struct variable *v = create_variable(s, vname, t); if (v == NULL) { @@ -414,7 +429,7 @@ return; } - struct type *t = v->value.type; + const struct type *t = v->value.type; t->store(t->aux, f, s->ctx, value_ptr(&v->value)); } fclose(f); @@ -432,7 +447,7 @@ return; } - struct type *t = v->value.type; + const struct type *t = v->value.type; int err = t->free(t->aux, s->ctx, value_ptr(&v->value)); error_check(s, err); @@ -544,6 +559,138 @@ } } +void cmd_fields(struct server_state *s, const char *args[]) { + const char *type = get_arg(args, 0); + const struct type *t = get_type(s, type); + const struct record *r = t->record; + + if (r == NULL) { + failure(); + printf("Not a record type\n"); + return; + } + + for (int i = 0; i < r->num_fields; i++) { + const struct field f = r->fields[i]; + printf("%s %s\n", f.name, f.type->name); + } +} + +void cmd_project(struct server_state *s, const char *args[]) { + const char *to_name = get_arg(args, 0); + const char *from_name = get_arg(args, 1); + const char *field_name = get_arg(args, 2); + + struct variable *from = get_variable(s, from_name); + + if (from == NULL) { + failure(); + printf("Unknown variable: %s\n", from_name); + return; + } + + const struct type *from_type = from->value.type; + const struct record *r = from_type->record; + + if (r == NULL) { + failure(); + printf("Not a record type\n"); + return; + } + + const struct field *field = NULL; + for (int i = 0; i < r->num_fields; i++) { + if (strcmp(r->fields[i].name, field_name) == 0) { + field = &r->fields[i]; + break; + } + } + + if (field == NULL) { + failure(); + printf("No such field\n"); + } + + struct variable *to = create_variable(s, to_name, field->type); + + if (to == NULL) { + failure(); + printf("Variable already exists: %s\n", to_name); + return; + } + + field->project(s->ctx, value_ptr(&to->value), from->value.value.v_ptr); +} + +void cmd_new(struct server_state *s, const char *args[]) { + const char *to_name = get_arg(args, 0); + const char *type_name = get_arg(args, 1); + const struct type *type = get_type(s, type_name); + struct variable *to = create_variable(s, to_name, type); + + if (to == NULL) { + failure(); + printf("Variable already exists: %s\n", to_name); + return; + } + + const struct record* r = type->record; + + if (r == NULL) { + failure(); + printf("Not a record type\n"); + return; + } + + int num_args = 0; + for (int i = 2; arg_exists(args, i); i++) { + num_args++; + } + + if (num_args != r->num_fields) { + failure(); + printf("%d fields expected byt %d values provided.\n", num_args, r->num_fields); + return; + } + + const void** value_ptrs = alloca(num_args * sizeof(void*)); + + for (int i = 0; i < num_args; i++) { + struct variable* v = get_variable(s, args[2+i]); + + if (v == NULL) { + failure(); + printf("Unknown variable: %s\n", args[2+i]); + return; + } + + if (strcmp(v->value.type->name, r->fields[i].type->name) != 0) { + failure(); + printf("Field %s mismatch: expected type %s, got %s\n", + r->fields[i].name, r->fields[i].type->name, v->value.type->name); + return; + } + + value_ptrs[i] = value_ptr(&v->value); + } + + r->new(s->ctx, value_ptr(&to->value), value_ptrs); +} + +void cmd_entry_points(struct server_state *s, const char *args[]) { + (void)args; + for (int i = 0; s->prog.entry_points[i].name; i++) { + puts(s->prog.entry_points[i].name); + } +} + +void cmd_types(struct server_state *s, const char *args[]) { + (void)args; + for (int i = 0; s->prog.types[i] != NULL; i++) { + puts(s->prog.types[i]->name); + } +} + char *next_word(char **line) { char *p = *line; @@ -630,6 +777,16 @@ cmd_report(s, tokens+1); } else if (strcmp(command, "set_tuning_param") == 0) { cmd_set_tuning_param(s, tokens+1); + } else if (strcmp(command, "fields") == 0) { + cmd_fields(s, tokens+1); + } else if (strcmp(command, "new") == 0) { + cmd_new(s, tokens+1); + } else if (strcmp(command, "project") == 0) { + cmd_project(s, tokens+1); + } else if (strcmp(command, "entry_points") == 0) { + cmd_entry_points(s, tokens+1); + } else if (strcmp(command, "types") == 0) { + cmd_types(s, tokens+1); } else { futhark_panic(1, "Unknown command: %s\n", command); } @@ -695,6 +852,7 @@ if (arr == NULL) { return 1; } + assert(futhark_context_sync(ctx) == 0); *(void**)p = arr; free(data); @@ -717,7 +875,7 @@ } int free_array(const struct array_aux *aux, - struct futhark_context *ctx, void *p) { + struct futhark_context *ctx, void *p) { void *arr = *(void**)p; return aux->free(ctx, arr); } @@ -769,7 +927,7 @@ } int free_opaque(const struct opaque_aux *aux, - struct futhark_context *ctx, void *p) { + struct futhark_context *ctx, void *p) { void *obj = *(void**)p; return aux->free(ctx, obj); } diff --git a/rts/c/uniform.h b/rts/c/uniform.h new file mode 100644 --- /dev/null +++ b/rts/c/uniform.h @@ -0,0 +1,1708 @@ + +// Start of uniform.h + +// Uniform versions of all library functions as to +// improve performance in ISPC when in an uniform context. + +#if ISPC + +static inline uniform uint8_t add8(uniform uint8_t x, uniform uint8_t y) { + return x + y; +} + +static inline uniform uint16_t add16(uniform uint16_t x, uniform uint16_t y) { + return x + y; +} + +static inline uniform uint32_t add32(uniform uint32_t x, uniform uint32_t y) { + return x + y; +} + +static inline uniform uint64_t add64(uniform uint64_t x, uniform uint64_t y) { + return x + y; +} + +static inline uniform uint8_t sub8(uniform uint8_t x, uniform uint8_t y) { + return x - y; +} + +static inline uniform uint16_t sub16(uniform uint16_t x, uniform uint16_t y) { + return x - y; +} + +static inline uniform uint32_t sub32(uniform uint32_t x, uniform uint32_t y) { + return x - y; +} + +static inline uniform uint64_t sub64(uniform uint64_t x, uniform uint64_t y) { + return x - y; +} + +static inline uniform uint8_t mul8(uniform uint8_t x, uniform uint8_t y) { + return x * y; +} + +static inline uniform uint16_t mul16(uniform uint16_t x, uniform uint16_t y) { + return x * y; +} + +static inline uniform uint32_t mul32(uniform uint32_t x, uniform uint32_t y) { + return x * y; +} + +static inline uniform uint64_t mul64(uniform uint64_t x, uniform uint64_t y) { + return x * y; +} + +static inline uniform uint8_t udiv8(uniform uint8_t x, uniform uint8_t y) { + return x / y; +} + +static inline uniform uint16_t udiv16(uniform uint16_t x, uniform uint16_t y) { + return x / y; +} + +static inline uniform uint32_t udiv32(uniform uint32_t x, uniform uint32_t y) { + return x / y; +} + +static inline uniform uint64_t udiv64(uniform uint64_t x, uniform uint64_t y) { + return x / y; +} + +static inline uniform uint8_t udiv_up8(uniform uint8_t x, uniform uint8_t y) { + return (x + y - 1) / y; +} + +static inline uniform uint16_t udiv_up16(uniform uint16_t x, uniform uint16_t y) { + return (x + y - 1) / y; +} + +static inline uniform uint32_t udiv_up32(uniform uint32_t x, uniform uint32_t y) { + return (x + y - 1) / y; +} + +static inline uniform uint64_t udiv_up64(uniform uint64_t x, uniform uint64_t y) { + return (x + y - 1) / y; +} + +static inline uniform uint8_t umod8(uniform uint8_t x, uniform uint8_t y) { + return x % y; +} + +static inline uniform uint16_t umod16(uniform uint16_t x, uniform uint16_t y) { + return x % y; +} + +static inline uniform uint32_t umod32(uniform uint32_t x, uniform uint32_t y) { + return x % y; +} + +static inline uniform uint64_t umod64(uniform uint64_t x, uniform uint64_t y) { + return x % y; +} + +static inline uniform uint8_t udiv_safe8(uniform uint8_t x, uniform uint8_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uniform uint16_t udiv_safe16(uniform uint16_t x, uniform uint16_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uniform uint32_t udiv_safe32(uniform uint32_t x, uniform uint32_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uniform uint64_t udiv_safe64(uniform uint64_t x, uniform uint64_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uniform uint8_t udiv_up_safe8(uniform uint8_t x, uniform uint8_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +static inline uniform uint16_t udiv_up_safe16(uniform uint16_t x, uniform uint16_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +static inline uniform uint32_t udiv_up_safe32(uniform uint32_t x, uniform uint32_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +static inline uniform uint64_t udiv_up_safe64(uniform uint64_t x, uniform uint64_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +static inline uniform uint8_t umod_safe8(uniform uint8_t x, uniform uint8_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uniform uint16_t umod_safe16(uniform uint16_t x, uniform uint16_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uniform uint32_t umod_safe32(uniform uint32_t x, uniform uint32_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uniform uint64_t umod_safe64(uniform uint64_t x, uniform uint64_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uniform int8_t sdiv8(uniform int8_t x, uniform int8_t y) { + uniform int8_t q = x / y; + uniform int8_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline uniform int16_t sdiv16(uniform int16_t x, uniform int16_t y) { + uniform int16_t q = x / y; + uniform int16_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline uniform int32_t sdiv32(uniform int32_t x, uniform int32_t y) { + uniform int32_t q = x / y; + uniform int32_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline uniform int64_t sdiv64(uniform int64_t x, uniform int64_t y) { + uniform int64_t q = x / y; + uniform int64_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +static inline uniform int8_t sdiv_up8(uniform int8_t x, uniform int8_t y) { + return sdiv8(x + y - 1, y); +} + +static inline uniform int16_t sdiv_up16(uniform int16_t x, uniform int16_t y) { + return sdiv16(x + y - 1, y); +} + +static inline uniform int32_t sdiv_up32(uniform int32_t x, uniform int32_t y) { + return sdiv32(x + y - 1, y); +} + +static inline uniform int64_t sdiv_up64(uniform int64_t x, uniform int64_t y) { + return sdiv64(x + y - 1, y); +} + +static inline uniform int8_t smod8(uniform int8_t x, uniform int8_t y) { + uniform int8_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline uniform int16_t smod16(uniform int16_t x, uniform int16_t y) { + uniform int16_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline uniform int32_t smod32(uniform int32_t x, uniform int32_t y) { + uniform int32_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline uniform int64_t smod64(uniform int64_t x, uniform int64_t y) { + uniform int64_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +static inline uniform int8_t sdiv_safe8(uniform int8_t x, uniform int8_t y) { + return y == 0 ? 0 : sdiv8(x, y); +} + +static inline uniform int16_t sdiv_safe16(uniform int16_t x, uniform int16_t y) { + return y == 0 ? 0 : sdiv16(x, y); +} + +static inline uniform int32_t sdiv_safe32(uniform int32_t x, uniform int32_t y) { + return y == 0 ? 0 : sdiv32(x, y); +} + +static inline uniform int64_t sdiv_safe64(uniform int64_t x, uniform int64_t y) { + return y == 0 ? 0 : sdiv64(x, y); +} + +static inline uniform int8_t sdiv_up_safe8(uniform int8_t x, uniform int8_t y) { + return sdiv_safe8(x + y - 1, y); +} + +static inline uniform int16_t sdiv_up_safe16(uniform int16_t x, uniform int16_t y) { + return sdiv_safe16(x + y - 1, y); +} + +static inline uniform int32_t sdiv_up_safe32(uniform int32_t x, uniform int32_t y) { + return sdiv_safe32(x + y - 1, y); +} + +static inline uniform int64_t sdiv_up_safe64(uniform int64_t x, uniform int64_t y) { + return sdiv_safe64(x + y - 1, y); +} + +static inline uniform int8_t smod_safe8(uniform int8_t x, uniform int8_t y) { + return y == 0 ? 0 : smod8(x, y); +} + +static inline uniform int16_t smod_safe16(uniform int16_t x, uniform int16_t y) { + return y == 0 ? 0 : smod16(x, y); +} + +static inline uniform int32_t smod_safe32(uniform int32_t x, uniform int32_t y) { + return y == 0 ? 0 : smod32(x, y); +} + +static inline uniform int64_t smod_safe64(uniform int64_t x, uniform int64_t y) { + return y == 0 ? 0 : smod64(x, y); +} + +static inline uniform int8_t squot8(uniform int8_t x, uniform int8_t y) { + return x / y; +} + +static inline uniform int16_t squot16(uniform int16_t x, uniform int16_t y) { + return x / y; +} + +static inline uniform int32_t squot32(uniform int32_t x, uniform int32_t y) { + return x / y; +} + +static inline uniform int64_t squot64(uniform int64_t x, uniform int64_t y) { + return x / y; +} + +static inline uniform int8_t srem8(uniform int8_t x, uniform int8_t y) { + return x % y; +} + +static inline uniform int16_t srem16(uniform int16_t x, uniform int16_t y) { + return x % y; +} + +static inline uniform int32_t srem32(uniform int32_t x, uniform int32_t y) { + return x % y; +} + +static inline uniform int64_t srem64(uniform int64_t x, uniform int64_t y) { + return x % y; +} + +static inline uniform int8_t squot_safe8(uniform int8_t x, uniform int8_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uniform int16_t squot_safe16(uniform int16_t x, uniform int16_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uniform int32_t squot_safe32(uniform int32_t x, uniform int32_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uniform int64_t squot_safe64(uniform int64_t x, uniform int64_t y) { + return y == 0 ? 0 : x / y; +} + +static inline uniform int8_t srem_safe8(uniform int8_t x, uniform int8_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uniform int16_t srem_safe16(uniform int16_t x, uniform int16_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uniform int32_t srem_safe32(uniform int32_t x, uniform int32_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uniform int64_t srem_safe64(uniform int64_t x, uniform int64_t y) { + return y == 0 ? 0 : x % y; +} + +static inline uniform int8_t smin8(uniform int8_t x, uniform int8_t y) { + return x < y ? x : y; +} + +static inline uniform int16_t smin16(uniform int16_t x, uniform int16_t y) { + return x < y ? x : y; +} + +static inline uniform int32_t smin32(uniform int32_t x, uniform int32_t y) { + return x < y ? x : y; +} + +static inline uniform int64_t smin64(uniform int64_t x, uniform int64_t y) { + return x < y ? x : y; +} + +static inline uniform uint8_t umin8(uniform uint8_t x, uniform uint8_t y) { + return x < y ? x : y; +} + +static inline uniform uint16_t umin16(uniform uint16_t x, uniform uint16_t y) { + return x < y ? x : y; +} + +static inline uniform uint32_t umin32(uniform uint32_t x, uniform uint32_t y) { + return x < y ? x : y; +} + +static inline uniform uint64_t umin64(uniform uint64_t x, uniform uint64_t y) { + return x < y ? x : y; +} + +static inline uniform int8_t smax8(uniform int8_t x, uniform int8_t y) { + return x < y ? y : x; +} + +static inline uniform int16_t smax16(uniform int16_t x, uniform int16_t y) { + return x < y ? y : x; +} + +static inline uniform int32_t smax32(uniform int32_t x, uniform int32_t y) { + return x < y ? y : x; +} + +static inline uniform int64_t smax64(uniform int64_t x, uniform int64_t y) { + return x < y ? y : x; +} + +static inline uniform uint8_t umax8(uniform uint8_t x, uniform uint8_t y) { + return x < y ? y : x; +} + +static inline uniform uint16_t umax16(uniform uint16_t x, uniform uint16_t y) { + return x < y ? y : x; +} + +static inline uniform uint32_t umax32(uniform uint32_t x, uniform uint32_t y) { + return x < y ? y : x; +} + +static inline uniform uint64_t umax64(uniform uint64_t x, uniform uint64_t y) { + return x < y ? y : x; +} + +static inline uniform uint8_t shl8(uniform uint8_t x, uniform uint8_t y) { + return (uniform uint8_t)(x << y); +} + +static inline uniform uint16_t shl16(uniform uint16_t x, uniform uint16_t y) { + return (uniform uint16_t)(x << y); +} + +static inline uniform uint32_t shl32(uniform uint32_t x, uniform uint32_t y) { + return x << y; +} + +static inline uniform uint64_t shl64(uniform uint64_t x, uniform uint64_t y) { + return x << y; +} + +static inline uniform uint8_t lshr8(uniform uint8_t x, uniform uint8_t y) { + return x >> y; +} + +static inline uniform uint16_t lshr16(uniform uint16_t x, uniform uint16_t y) { + return x >> y; +} + +static inline uniform uint32_t lshr32(uniform uint32_t x, uniform uint32_t y) { + return x >> y; +} + +static inline uniform uint64_t lshr64(uniform uint64_t x, uniform uint64_t y) { + return x >> y; +} + +static inline uniform int8_t ashr8(uniform int8_t x, uniform int8_t y) { + return x >> y; +} + +static inline uniform int16_t ashr16(uniform int16_t x, uniform int16_t y) { + return x >> y; +} + +static inline uniform int32_t ashr32(uniform int32_t x, uniform int32_t y) { + return x >> y; +} + +static inline uniform int64_t ashr64(uniform int64_t x, uniform int64_t y) { + return x >> y; +} + +static inline uniform uint8_t and8(uniform uint8_t x, uniform uint8_t y) { + return x & y; +} + +static inline uniform uint16_t and16(uniform uint16_t x, uniform uint16_t y) { + return x & y; +} + +static inline uniform uint32_t and32(uniform uint32_t x, uniform uint32_t y) { + return x & y; +} + +static inline uniform uint64_t and64(uniform uint64_t x, uniform uint64_t y) { + return x & y; +} + +static inline uniform uint8_t or8(uniform uint8_t x, uniform uint8_t y) { + return x | y; +} + +static inline uniform uint16_t or16(uniform uint16_t x, uniform uint16_t y) { + return x | y; +} + +static inline uniform uint32_t or32(uniform uint32_t x, uniform uint32_t y) { + return x | y; +} + +static inline uniform uint64_t or64(uniform uint64_t x, uniform uint64_t y) { + return x | y; +} + +static inline uniform uint8_t xor8(uniform uint8_t x, uniform uint8_t y) { + return x ^ y; +} + +static inline uniform uint16_t xor16(uniform uint16_t x, uniform uint16_t y) { + return x ^ y; +} + +static inline uniform uint32_t xor32(uniform uint32_t x, uniform uint32_t y) { + return x ^ y; +} + +static inline uniform uint64_t xor64(uniform uint64_t x, uniform uint64_t y) { + return x ^ y; +} + +static inline uniform bool ult8(uniform uint8_t x, uniform uint8_t y) { + return x < y; +} + +static inline uniform bool ult16(uniform uint16_t x, uniform uint16_t y) { + return x < y; +} + +static inline uniform bool ult32(uniform uint32_t x, uniform uint32_t y) { + return x < y; +} + +static inline uniform bool ult64(uniform uint64_t x, uniform uint64_t y) { + return x < y; +} + +static inline uniform bool ule8(uniform uint8_t x, uniform uint8_t y) { + return x <= y; +} + +static inline uniform bool ule16(uniform uint16_t x, uniform uint16_t y) { + return x <= y; +} + +static inline uniform bool ule32(uniform uint32_t x, uniform uint32_t y) { + return x <= y; +} + +static inline uniform bool ule64(uniform uint64_t x, uniform uint64_t y) { + return x <= y; +} + +static inline uniform bool slt8(uniform int8_t x, uniform int8_t y) { + return x < y; +} + +static inline uniform bool slt16(uniform int16_t x, uniform int16_t y) { + return x < y; +} + +static inline uniform bool slt32(uniform int32_t x, uniform int32_t y) { + return x < y; +} + +static inline uniform bool slt64(uniform int64_t x, uniform int64_t y) { + return x < y; +} + +static inline uniform bool sle8(uniform int8_t x, uniform int8_t y) { + return x <= y; +} + +static inline uniform bool sle16(uniform int16_t x, uniform int16_t y) { + return x <= y; +} + +static inline uniform bool sle32(uniform int32_t x, uniform int32_t y) { + return x <= y; +} + +static inline uniform bool sle64(uniform int64_t x, uniform int64_t y) { + return x <= y; +} + +static inline uniform uint8_t pow8(uniform uint8_t x, uniform uint8_t y) { + uniform uint8_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +static inline uniform uint16_t pow16(uniform uint16_t x, uniform uint16_t y) { + uniform uint16_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +static inline uniform uint32_t pow32(uniform uint32_t x, uniform uint32_t y) { + uniform uint32_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +static inline uniform uint64_t pow64(uniform uint64_t x, uniform uint64_t y) { + uniform uint64_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +static inline uniform bool itob_i8_bool(uniform int8_t x) { + return x != 0; +} + +static inline uniform bool itob_i16_bool(uniform int16_t x) { + return x != 0; +} + +static inline uniform bool itob_i32_bool(uniform int32_t x) { + return x != 0; +} + +static inline uniform bool itob_i64_bool(uniform int64_t x) { + return x != 0; +} + +static inline uniform int8_t btoi_bool_i8(uniform bool x) { + return x; +} + +static inline uniform int16_t btoi_bool_i16(uniform bool x) { + return x; +} + +static inline uniform int32_t btoi_bool_i32(uniform bool x) { + return x; +} + +static inline uniform int64_t btoi_bool_i64(uniform bool x) { + return x; +} + + +static uniform int8_t abs8(uniform int8_t x) { + return (uniform int8_t)abs(x); +} + +static uniform int16_t abs16(uniform int16_t x) { + return (uniform int16_t)abs(x); +} + +static uniform int32_t abs32(uniform int32_t x) { + return abs(x); +} + +static uniform int64_t abs64(uniform int64_t x) { + return abs(x); +} + +static uniform int32_t futrts_popc8(uniform uint8_t x) { + uniform int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +static uniform int32_t futrts_popc16(uniform uint16_t x) { + uniform int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +static uniform int32_t futrts_popc32(uniform uint32_t x) { + uniform int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +static uniform int32_t futrts_popc64(uniform uint64_t x) { + uniform int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +static uniform uint8_t futrts_mul_hi8(uniform uint8_t a, uniform uint8_t b) { + uniform uint16_t aa = a; + uniform uint16_t bb = b; + + return aa * bb >> 8; +} + +static uniform uint16_t futrts_mul_hi16(uniform uint16_t a, uniform uint16_t b) { + uniform uint32_t aa = a; + uniform uint32_t bb = b; + + return aa * bb >> 16; +} + +static uniform uint32_t futrts_mul_hi32(uniform uint32_t a, uniform uint32_t b) { + uniform uint64_t aa = a; + uniform uint64_t bb = b; + + return aa * bb >> 32; +} + +static uniform uint64_t futrts_mul_hi64(uniform uint64_t a, uniform uint64_t b) { + uniform uint64_t ah = a >> 32; + uniform uint64_t al = a & 0xffffffff; + uniform uint64_t bh = b >> 32; + uniform uint64_t bl = b & 0xffffffff; + + uniform uint64_t p1 = al * bl; + uniform uint64_t p2 = al * bh; + uniform uint64_t p3 = ah * bl; + uniform uint64_t p4 = ah * bh; + + uniform uint64_t p1h = p1 >> 32; + uniform uint64_t p2h = p2 >> 32; + uniform uint64_t p3h = p3 >> 32; + uniform uint64_t p2l = p2 & 0xffffffff; + uniform uint64_t p3l = p3 & 0xffffffff; + + uniform uint64_t l = p1h + p2l + p3l; + uniform uint64_t m = (p2 >> 32) + (p3 >> 32); + uniform uint64_t h = (l >> 32) + m + p4; + + return h; +} + +static uniform uint8_t futrts_mad_hi8(uniform uint8_t a, uniform uint8_t b, uniform uint8_t c) { + return futrts_mul_hi8(a, b) + c; +} + +static uniform uint16_t futrts_mad_hi16(uniform uint16_t a, uniform uint16_t b, uniform uint16_t c) { + return futrts_mul_hi16(a, b) + c; +} + +static uniform uint32_t futrts_mad_hi32(uniform uint32_t a, uniform uint32_t b, uniform uint32_t c) { + return futrts_mul_hi32(a, b) + c; +} + +static uniform uint64_t futrts_mad_hi64(uniform uint64_t a, uniform uint64_t b, uniform uint64_t c) { + return futrts_mul_hi64(a, b) + c; +} + +static uniform int32_t futrts_clzz8(uniform int8_t x) { + return count_leading_zeros((uniform int32_t)(uniform uint8_t)x)-24; +} + +static uniform int32_t futrts_clzz16(uniform int16_t x) { + return count_leading_zeros((uniform int32_t)(uniform uint16_t)x)-16; +} + +static uniform int32_t futrts_clzz32(uniform int32_t x) { + return count_leading_zeros(x); +} + +static uniform int32_t futrts_clzz64(uniform int64_t x) { + return count_leading_zeros(x); +} + +static uniform int32_t futrts_ctzz8(uniform int8_t x) { + return x == 0 ? 8 : count_trailing_zeros((uniform int32_t)x); +} + +static uniform int32_t futrts_ctzz16(uniform int16_t x) { + return x == 0 ? 16 : count_trailing_zeros((uniform int32_t)x); +} + +static uniform int32_t futrts_ctzz32(uniform int32_t x) { + return count_trailing_zeros(x); +} + +static uniform int32_t futrts_ctzz64(uniform int64_t x) { + return count_trailing_zeros(x); +} + + +static inline uniform float fdiv32(uniform float x, uniform float y) { + return x / y; +} + +static inline uniform float fadd32(uniform float x, uniform float y) { + return x + y; +} + +static inline uniform float fsub32(uniform float x, uniform float y) { + return x - y; +} + +static inline uniform float fmul32(uniform float x, uniform float y) { + return x * y; +} + +static inline uniform bool cmplt32(uniform float x, uniform float y) { + return x < y; +} + +static inline uniform bool cmple32(uniform float x, uniform float y) { + return x <= y; +} + +static inline uniform float sitofp_i8_f32(uniform int8_t x) { + return (uniform float) x; +} + +static inline uniform float sitofp_i16_f32(uniform int16_t x) { + return (uniform float) x; +} + +static inline uniform float sitofp_i32_f32(uniform int32_t x) { + return (uniform float) x; +} + +static inline uniform float sitofp_i64_f32(uniform int64_t x) { + return (uniform float) x; +} + +static inline uniform float uitofp_i8_f32(uniform uint8_t x) { + return (uniform float) x; +} + +static inline uniform float uitofp_i16_f32(uniform uint16_t x) { + return (uniform float) x; +} + +static inline uniform float uitofp_i32_f32(uniform uint32_t x) { + return (uniform float) x; +} + +static inline uniform float uitofp_i64_f32(uniform uint64_t x) { + return (uniform float) x; +} + + +static inline uniform float fabs32(uniform float x) { + return abs(x); +} + +static inline uniform float fmax32(uniform float x, uniform float y) { + return isnan(x) ? y : isnan(y) ? x : max(x, y); +} + +static inline uniform float fmin32(uniform float x, uniform float y) { + return isnan(x) ? y : isnan(y) ? x : min(x, y); +} + +static inline uniform float fpow32(uniform float x, uniform float y) { + return __stdlib_powf(x, y); +} + +static inline uniform bool futrts_isnan32(uniform float x) { + return isnan(x); +} + +static inline uniform bool futrts_isinf32(uniform float x) { + return !isnan(x) && isnan(x - x); +} +static inline uniform bool futrts_isfinite32(uniform float x) { + return !isnan(x) && !futrts_isinf32(x); +} + + +static inline uniform int8_t fptosi_f32_i8(uniform float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uniform int8_t) x; + } +} + +static inline uniform int16_t fptosi_f32_i16(uniform float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uniform int16_t) x; + } +} + +static inline uniform int32_t fptosi_f32_i32(uniform float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uniform int32_t) x; + } +} + +static inline uniform int64_t fptosi_f32_i64(uniform float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uniform int64_t) x; + }; +} + +static inline uniform uint8_t fptoui_f32_i8(uniform float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uniform uint8_t) (uniform int8_t) x; + } +} + +static inline uniform uint16_t fptoui_f32_i16(uniform float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uniform uint16_t) (uniform int16_t) x; + } +} + +static inline uniform uint32_t fptoui_f32_i32(uniform float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uniform uint32_t) (uniform int32_t) x; + } +} + +static inline uniform uint64_t fptoui_f32_i64(uniform float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uniform uint64_t) (uniform int64_t) x; + } +} + + +static inline uniform float futrts_log32(uniform float x) { + return futrts_isfinite32(x) || (futrts_isinf32(x) && x < 0)? log(x) : x; +} + +static inline uniform float futrts_log2_32(uniform float x) { + return futrts_log32(x) / log(2.0f); +} + +static inline uniform float futrts_log10_32(uniform float x) { + return futrts_log32(x) / log(10.0f); +} + +static inline uniform float futrts_sqrt32(uniform float x) { + return sqrt(x); +} + +extern "C" unmasked uniform float cbrtf(uniform float); +static inline uniform float futrts_cbrt32(uniform float x) { + return cbrtf(x); +} + +static inline uniform float futrts_exp32(uniform float x) { + return exp(x); +} + +static inline uniform float futrts_cos32(uniform float x) { + return cos(x); +} + +static inline uniform float futrts_sin32(uniform float x) { + return sin(x); +} + +static inline uniform float futrts_tan32(uniform float x) { + return tan(x); +} + +static inline uniform float futrts_acos32(uniform float x) { + return acos(x); +} + +static inline uniform float futrts_asin32(uniform float x) { + return asin(x); +} + +static inline uniform float futrts_atan32(uniform float x) { + return atan(x); +} + +static inline uniform float futrts_cosh32(uniform float x) { + return (exp(x)+exp(-x)) / 2.0f; +} + +static inline uniform float futrts_sinh32(uniform float x) { + return (exp(x)-exp(-x)) / 2.0f; +} + +static inline uniform float futrts_tanh32(uniform float x) { + return futrts_sinh32(x)/futrts_cosh32(x); +} + +static inline uniform float futrts_acosh32(uniform float x) { + uniform float f = x+sqrt(x*x-1); + if(futrts_isfinite32(f)) return log(f); + return f; +} + +static inline uniform float futrts_asinh32(uniform float x) { + uniform float f = x+sqrt(x*x+1); + if(futrts_isfinite32(f)) return log(f); + return f; + +} + +static inline uniform float futrts_atanh32(uniform float x) { + uniform float f = (1+x)/(1-x); + if(futrts_isfinite32(f)) return log(f)/2.0f; + return f; + +} + +static inline uniform float futrts_atan2_32(uniform float x, uniform float y) { + return (x == 0.0f && y == 0.0f) ? 0.0f : atan2(x, y); +} + +static inline uniform float futrts_hypot32(uniform float x, uniform float y) { + if (futrts_isfinite32(x) && futrts_isfinite32(y)) { + x = abs(x); + y = abs(y); + uniform float a; + uniform float b; + if (x >= y){ + a = x; + b = y; + } else { + a = y; + b = x; + } + if(b == 0){ + return a; + } + + uniform int e; + uniform float an; + uniform float bn; + an = frexp (a, &e); + bn = ldexp (b, - e); + uniform float cn; + cn = sqrt (an * an + bn * bn); + return ldexp (cn, e); + } else { + if (futrts_isinf32(x) || futrts_isinf32(y)) return INFINITY; + else return x + y; + } + +} + +extern "C" unmasked uniform float tgammaf(uniform float x); +static inline uniform float futrts_gamma32(uniform float x) { + return tgammaf(x); +} + +extern "C" unmasked uniform float tgammaf(uniform float x); +static inline uniform float futrts_lgamma32(uniform float x) { + return lgammaf(x); +} + +extern "C" unmasked uniform float erff(uniform float); +static inline uniform float futrts_erf32(uniform float x) { + return erff(x); +} + +extern "C" unmasked uniform float erfcf(uniform float); +static inline uniform float futrts_erfc32(uniform float x) { + return erfcf(x); +} + +static inline uniform float fmod32(uniform float x, uniform float y) { + return x - y * trunc(x/y); +} + +static inline uniform float futrts_round32(uniform float x) { + return round(x); +} + +static inline uniform float futrts_floor32(uniform float x) { + return floor(x); +} + +static inline uniform float futrts_ceil32(uniform float x) { + return ceil(x); +} + +static inline uniform float futrts_lerp32(uniform float v0, uniform float v1, uniform float t) { + return v0 + (v1 - v0) * t; +} + +static inline uniform float futrts_mad32(uniform float a, uniform float b, uniform float c) { + return a * b + c; +} + +static inline uniform float futrts_fma32(uniform float a, uniform float b, uniform float c) { + return a * b + c; +} + +static inline uniform int32_t futrts_to_bits32(uniform float x) { + return intbits(x); +} + +static inline uniform float futrts_from_bits32(uniform int32_t x) { + return floatbits(x); +} + +static inline uniform float fsignum32(uniform float x) { + return futrts_isnan32(x) ? x : (x > 0 ? 1 : 0) - (x < 0 ? 1 : 0); +} + +#ifdef FUTHARK_F64_ENABLED + +static inline uniform bool futrts_isinf64(uniform float x) { + return !isnan(x) && isnan(x - x); +} +static inline uniform bool futrts_isfinite64(uniform float x) { + return !isnan(x) && !futrts_isinf64(x); +} + +static inline uniform double fdiv64(uniform double x, uniform double y) { + return x / y; +} + +static inline uniform double fadd64(uniform double x, uniform double y) { + return x + y; +} + +static inline uniform double fsub64(uniform double x, uniform double y) { + return x - y; +} + +static inline uniform double fmul64(uniform double x, uniform double y) { + return x * y; +} + +static inline uniform bool cmplt64(uniform double x, uniform double y) { + return x < y; +} + +static inline uniform bool cmple64(uniform double x, uniform double y) { + return x <= y; +} + +static inline uniform double sitofp_i8_f64(uniform int8_t x) { + return (uniform double) x; +} + +static inline uniform double sitofp_i16_f64(uniform int16_t x) { + return (uniform double) x; +} + +static inline uniform double sitofp_i32_f64(uniform int32_t x) { + return (uniform double) x; +} + +static inline uniform double sitofp_i64_f64(uniform int64_t x) { + return (uniform double) x; +} + +static inline uniform double uitofp_i8_f64(uniform uint8_t x) { + return (uniform double) x; +} + +static inline uniform double uitofp_i16_f64(uniform uint16_t x) { + return (uniform double) x; +} + +static inline uniform double uitofp_i32_f64(uniform uint32_t x) { + return (uniform double) x; +} + +static inline uniform double uitofp_i64_f64(uniform uint64_t x) { + return (uniform double) x; +} + +static inline uniform double fabs64(uniform double x) { + return abs(x); +} + +static inline uniform double fmax64(uniform double x, uniform double y) { + return isnan(x) ? y : isnan(y) ? x : max(x, y); +} + +static inline uniform double fmin64(uniform double x, uniform double y) { + return isnan(x) ? y : isnan(y) ? x : min(x, y); +} + +static inline uniform double fpow64(uniform double x, uniform double y) { + return __stdlib_powf(x, y); +} + +static inline uniform double futrts_log64(uniform double x) { + return futrts_isfinite64(x) || (futrts_isinf64(x) && x < 0)? log(x) : x; +} + +static inline uniform double futrts_log2_64(uniform double x) { + return futrts_log64(x)/log(2.0d); +} + +static inline uniform double futrts_log10_64(uniform double x) { + return futrts_log64(x)/log(10.0d); +} + +static inline uniform double futrts_sqrt64(uniform double x) { + return sqrt(x); +} + +extern "C" unmasked uniform double cbrt(uniform double); +static inline uniform double futrts_cbrt64(uniform double x) { + return cbrt(x); +} + +static inline uniform double futrts_exp64(uniform double x) { + return exp(x); +} + +static inline uniform double futrts_cos64(uniform double x) { + return cos(x); +} + +static inline uniform double futrts_sin64(uniform double x) { + return sin(x); +} + +static inline uniform double futrts_tan64(uniform double x) { + return tan(x); +} + +static inline uniform double futrts_acos64(uniform double x) { + return acos(x); +} + +static inline uniform double futrts_asin64(uniform double x) { + return asin(x); +} + +static inline uniform double futrts_atan64(uniform double x) { + return atan(x); +} + +static inline uniform double futrts_cosh64(uniform double x) { + return (exp(x)+exp(-x)) / 2.0d; +} + +static inline uniform double futrts_sinh64(uniform double x) { + return (exp(x)-exp(-x)) / 2.0d; +} + +static inline uniform double futrts_tanh64(uniform double x) { + return futrts_sinh64(x)/futrts_cosh64(x); +} + +static inline uniform double futrts_acosh64(uniform double x) { + uniform double f = x+sqrt(x*x-1.0d); + if(futrts_isfinite64(f)) return log(f); + return f; +} + +static inline uniform double futrts_asinh64(uniform double x) { + uniform double f = x+sqrt(x*x+1.0d); + if(futrts_isfinite64(f)) return log(f); + return f; +} + +static inline uniform double futrts_atanh64(uniform double x) { + uniform double f = (1.0d+x)/(1.0d-x); + if(futrts_isfinite64(f)) return log(f)/2.0d; + return f; + +} + +static inline uniform double futrts_atan2_64(uniform double x, uniform double y) { + return atan2(x, y); +} + +extern "C" unmasked uniform double hypot(uniform double x, uniform double y); +static inline uniform double futrts_hypot64(uniform double x, uniform double y) { + return hypot(x, y); +} + +extern "C" unmasked uniform double tgamma(uniform double x); +static inline uniform double futrts_gamma64(uniform double x) { + return tgamma(x); +} + +extern "C" unmasked uniform double lgamma(uniform double x); +static inline uniform double futrts_lgamma64(uniform double x) { + return lgamma(x); +} + +extern "C" unmasked uniform double erf(uniform double); +static inline uniform double futrts_erf64(uniform double x) { + return erf(x); +} + +extern "C" unmasked uniform double erfc(uniform double); +static inline uniform double futrts_erfc64(uniform double x) { + return erfc(x); +} + +static inline uniform double futrts_fma64(uniform double a, uniform double b, uniform double c) { + return a * b + c; +} + +static inline uniform double futrts_round64(uniform double x) { + return round(x); +} + +static inline uniform double futrts_ceil64(uniform double x) { + return ceil(x); +} + +static inline uniform double futrts_floor64(uniform double x) { + return floor(x); +} + +static inline uniform bool futrts_isnan64(uniform double x) { + return isnan(x); +} + +static inline uniform int8_t fptosi_f64_i8(uniform double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uniform int8_t) x; + } +} + +static inline uniform int16_t fptosi_f64_i16(uniform double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uniform int16_t) x; + } +} + +static inline uniform int32_t fptosi_f64_i32(uniform double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uniform int32_t) x; + } +} + +static inline uniform int64_t fptosi_f64_i64(uniform double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uniform int64_t) x; + } +} + +static inline uniform uint8_t fptoui_f64_i8(uniform double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uniform uint8_t) (uniform int8_t) x; + } +} + +static inline uniform uint16_t fptoui_f64_i16(uniform double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uniform uint16_t) (uniform int16_t) x; + } +} + +static inline uniform uint32_t fptoui_f64_i32(uniform double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uniform uint32_t) (uniform int32_t) x; + } +} + +static inline uniform uint64_t fptoui_f64_i64(uniform double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uniform uint64_t) (uniform int64_t) x; + } +} + +static inline uniform bool ftob_f64_bool(uniform double x) { + return x != 0.0; +} + +static inline uniform double btof_bool_f64(uniform bool x) { + return x ? 1.0 : 0.0; +} + +static inline uniform bool ftob_f32_bool(uniform float x) { + return x != 0; +} + +static inline uniform float btof_bool_f32(uniform bool x) { + return x ? 1 : 0; +} + +static inline uniform int64_t futrts_to_bits64(uniform double x) { + return *((uniform int64_t* uniform)&x); +} + +static inline uniform double futrts_from_bits64(uniform int64_t x) { + return *((uniform double* uniform)&x); +} + +static inline uniform double fmod64(uniform double x, uniform double y) { + return x - y * trunc(x/y); +} + +static inline uniform double fsignum64(uniform double x) { + return futrts_isnan64(x) ? x : (x > 0 ? 1.0d : 0.0d) - (x < 0 ? 1.0d : 0.0d); +} + +static inline uniform double futrts_lerp64(uniform double v0, uniform double v1, uniform double t) { + return v0 + (v1 - v0) * t; +} + +static inline uniform double futrts_mad64(uniform double a, uniform double b, uniform double c) { + return a * b + c; +} + +static inline uniform float fpconv_f32_f32(uniform float x) { + return (uniform float) x; +} + +static inline uniform double fpconv_f32_f64(uniform float x) { + return (uniform double) x; +} + +static inline uniform float fpconv_f64_f32(uniform double x) { + return (uniform float) x; +} + +static inline uniform double fpconv_f64_f64(uniform double x) { + return (uniform double) x; +} + +static inline uniform double fpconv_f16_f64(uniform f16 x) { + return (uniform double) x; +} + +static inline uniform f16 fpconv_f64_f16(uniform double x) { + return (uniform f16) ((uniform float)x); +} + +#endif + + +static inline uniform f16 fadd16(uniform f16 x, uniform f16 y) { + return x + y; +} + +static inline uniform f16 fsub16(uniform f16 x, uniform f16 y) { + return x - y; +} + +static inline uniform f16 fmul16(uniform f16 x, uniform f16 y) { + return x * y; +} + +static inline uniform bool cmplt16(uniform f16 x, uniform f16 y) { + return x < y; +} + +static inline uniform bool cmple16(uniform f16 x, uniform f16 y) { + return x <= y; +} + +static inline uniform f16 sitofp_i8_f16(uniform int8_t x) { + return (uniform f16) x; +} + +static inline uniform f16 sitofp_i16_f16(uniform int16_t x) { + return (uniform f16) x; +} + +static inline uniform f16 sitofp_i32_f16(uniform int32_t x) { + return (uniform f16) x; +} + +static inline uniform f16 sitofp_i64_f16(uniform int64_t x) { + return (uniform f16) x; +} + +static inline uniform f16 uitofp_i8_f16(uniform uint8_t x) { + return (uniform f16) x; +} + +static inline uniform f16 uitofp_i16_f16(uniform uint16_t x) { + return (uniform f16) x; +} + +static inline uniform f16 uitofp_i32_f16(uniform uint32_t x) { + return (uniform f16) x; +} + +static inline uniform f16 uitofp_i64_f16(uniform uint64_t x) { + return (uniform f16) x; +} + +static inline uniform int8_t fptosi_f16_i8(uniform f16 x) { + return (uniform int8_t) (uniform float) x; +} + +static inline uniform int16_t fptosi_f16_i16(uniform f16 x) { + return (uniform int16_t) x; +} + +static inline uniform int32_t fptosi_f16_i32(uniform f16 x) { + return (uniform int32_t) x; +} + +static inline uniform int64_t fptosi_f16_i64(uniform f16 x) { + return (uniform int64_t) x; +} + +static inline uniform uint8_t fptoui_f16_i8(uniform f16 x) { + return (uniform uint8_t) (uniform float) x; +} + +static inline uniform uint16_t fptoui_f16_i16(uniform f16 x) { + return (uniform uint16_t) x; +} + +static inline uniform uint32_t fptoui_f16_i32(uniform f16 x) { + return (uniform uint32_t) x; +} + +static inline uniform uint64_t fptoui_f16_i64(uniform f16 x) { + return (uniform uint64_t) x; +} + +static inline uniform f16 fabs16(uniform f16 x) { + return abs(x); +} + +static inline uniform bool futrts_isnan16(uniform f16 x) { + return isnan((uniform float)x); +} + +static inline uniform f16 fmax16(uniform f16 x, uniform f16 y) { + return futrts_isnan16(x) ? y : futrts_isnan16(y) ? x : max(x, y); +} + +static inline uniform f16 fmin16(uniform f16 x, uniform f16 y) { + return min(x, y); +} + +static inline uniform f16 fpow16(uniform f16 x, uniform f16 y) { + return pow(x, y); +} + +static inline uniform bool futrts_isinf16(uniform float x) { + return !futrts_isnan16(x) && futrts_isnan16(x - x); +} +static inline uniform bool futrts_isfinite16(uniform float x) { + return !futrts_isnan16(x) && !futrts_isinf16(x); +} + + +static inline uniform f16 futrts_log16(uniform f16 x) { + return futrts_isfinite16(x) || (futrts_isinf16(x) && x < 0)? log(x) : x; +} + +static inline uniform f16 futrts_log2_16(uniform f16 x) { + return futrts_log16(x) / log(2.0f16); +} + +static inline uniform f16 futrts_log10_16(uniform f16 x) { + return futrts_log16(x) / log(10.0f16); +} + +static inline uniform f16 futrts_sqrt16(uniform f16 x) { + return (uniform f16)sqrt((uniform float)x); +} + +extern "C" unmasked uniform float cbrtf(uniform float); +static inline uniform f16 futrts_cbrt16(uniform f16 x) { + return (uniform f16)cbrtf((uniform float)x); +} + +static inline uniform f16 futrts_exp16(uniform f16 x) { + return exp(x); +} + +static inline uniform f16 futrts_cos16(uniform f16 x) { + return (uniform f16)cos((uniform float)x); +} + +static inline uniform f16 futrts_sin16(uniform f16 x) { + return (uniform f16)sin((uniform float)x); +} + +static inline uniform f16 futrts_tan16(uniform f16 x) { + return (uniform f16)tan((uniform float)x); +} + +static inline uniform f16 futrts_acos16(uniform f16 x) { + return (uniform f16)acos((uniform float)x); +} + +static inline uniform f16 futrts_asin16(uniform f16 x) { + return (uniform f16)asin((uniform float)x); +} + +static inline uniform f16 futrts_atan16(uniform f16 x) { + return (uniform f16)atan((uniform float)x); +} + +static inline uniform f16 futrts_cosh16(uniform f16 x) { + return (exp(x)+exp(-x)) / 2.0f16; +} + +static inline uniform f16 futrts_sinh16(uniform f16 x) { + return (exp(x)-exp(-x)) / 2.0f16; +} + +static inline uniform f16 futrts_tanh16(uniform f16 x) { + return futrts_sinh16(x)/futrts_cosh16(x); +} + +static inline uniform f16 futrts_acosh16(uniform f16 x) { + uniform f16 f = x+(uniform f16)sqrt((uniform float)(x*x-1)); + if(futrts_isfinite16(f)) return log(f); + return f; +} + +static inline uniform f16 futrts_asinh16(uniform f16 x) { + uniform f16 f = x+(uniform f16)sqrt((uniform float)(x*x+1)); + if(futrts_isfinite16(f)) return log(f); + return f; +} + +static inline uniform f16 futrts_atanh16(uniform f16 x) { + uniform f16 f = (1+x)/(1-x); + if(futrts_isfinite16(f)) return log(f)/2.0f16; + return f; +} + +static inline uniform f16 futrts_atan2_16(uniform f16 x, uniform f16 y) { + return (uniform f16)atan2((uniform float)x, (uniform float)y); +} + +static inline uniform f16 futrts_hypot16(uniform f16 x, uniform f16 y) { + return (uniform f16)futrts_hypot32((uniform float)x, (uniform float)y); +} + +extern "C" unmasked uniform float tgammaf(uniform float x); +static inline uniform f16 futrts_gamma16(uniform f16 x) { + return (uniform f16)tgammaf((uniform float)x); +} + +extern "C" unmasked uniform float lgammaf(uniform float x); +static inline uniform f16 futrts_lgamma16(uniform f16 x) { + return (uniform f16)lgammaf((uniform float)x); +} + +extern "C" unmasked uniform float erff(uniform float); +static inline uniform f16 futrts_erf32(uniform f16 x) { + return (uniform f16)erff((uniform float)x); +} + +extern "C" unmasked uniform float erfcf(uniform float); +static inline uniform f16 futrts_erfc32(uniform f16 x) { + return (uniform f16)erfcf((uniform float)x); +} + +static inline uniform f16 fmod16(uniform f16 x, uniform f16 y) { + return x - y * (uniform f16)trunc((uniform float) (x/y)); +} + +static inline uniform f16 futrts_round16(uniform f16 x) { + return (uniform f16)round((uniform float)x); +} + +static inline uniform f16 futrts_floor16(uniform f16 x) { + return (uniform f16)floor((uniform float)x); +} + +static inline uniform f16 futrts_ceil16(uniform f16 x) { + return (uniform f16)ceil((uniform float)x); +} + +static inline uniform f16 futrts_lerp16(uniform f16 v0, uniform f16 v1, uniform f16 t) { + return v0 + (v1 - v0) * t; +} + +static inline uniform f16 futrts_mad16(uniform f16 a, uniform f16 b, uniform f16 c) { + return a * b + c; +} + +static inline uniform f16 futrts_fma16(uniform f16 a, uniform f16 b, uniform f16 c) { + return a * b + c; +} + +static inline uniform int16_t futrts_to_bits16(uniform f16 x) { + return *((uniform int16_t *)&x); +} + +static inline uniform f16 futrts_from_bits16(uniform int16_t x) { + return *((uniform f16 *)&x); +} + +static inline uniform float fpconv_f16_f16(uniform f16 x) { + return x; +} + +static inline uniform float fpconv_f16_f32(uniform f16 x) { + return x; +} + +static inline uniform f16 fpconv_f32_f16(uniform float x) { + return (uniform f16) x; +} +#endif + +// End of uniform.h. diff --git a/rts/c/util.h b/rts/c/util.h --- a/rts/c/util.h +++ b/rts/c/util.h @@ -135,6 +135,11 @@ b->used += needed; } +char * lexical_realloc_error(size_t new_size) { + return msgprintf("Failed to allocate memory.\nAttempted allocation: %12lld bytes\n", + (long long) new_size); +} + static int lexical_realloc(char **error, unsigned char **ptr, int64_t *old_size, int64_t new_size) { unsigned char *new = realloc(*ptr, (size_t)new_size); if (new == NULL) { diff --git a/rts/python/server.py b/rts/python/server.py --- a/rts/python/server.py +++ b/rts/python/server.py @@ -151,6 +151,14 @@ if reader.get_char() != b'': raise self.Failure('Expected EOF after reading values') + def _cmd_types(self, args): + for k in self._ctx.opaques.keys(): + print(k) + + def _cmd_entry_points(self, args): + for k in self._ctx.entry_points.keys(): + print(k) + _commands = { 'inputs': _cmd_inputs, 'outputs': _cmd_outputs, 'call': _cmd_call, @@ -161,7 +169,9 @@ 'clear': _cmd_dummy, 'pause_profiling': _cmd_dummy, 'unpause_profiling': _cmd_dummy, - 'report': _cmd_dummy + 'report': _cmd_dummy, + 'types': _cmd_types, + 'entry_points': _cmd_entry_points, } def _process_line(self, line): diff --git a/src/Futhark/AD/Derivatives.hs b/src/Futhark/AD/Derivatives.hs --- a/src/Futhark/AD/Derivatives.hs +++ b/src/Futhark/AD/Derivatives.hs @@ -10,7 +10,7 @@ import Data.Bifunctor (bimap) import Futhark.Analysis.PrimExp.Convert -import Futhark.IR.Syntax.Core +import Futhark.IR.Syntax.Core (Name, VName) import Futhark.Util.IntegralExp import Prelude hiding (quot) diff --git a/src/Futhark/AD/Fwd.hs b/src/Futhark/AD/Fwd.hs --- a/src/Futhark/AD/Fwd.hs +++ b/src/Futhark/AD/Fwd.hs @@ -277,8 +277,8 @@ zeroFromSubExp :: SubExp -> ADM VName zeroFromSubExp (Constant c) = - letExp "zero" $ - BasicOp $ SubExp $ Constant $ blankPrimValue $ primValueType c + letExp "zero" . BasicOp . SubExp . Constant $ + blankPrimValue (primValueType c) zeroFromSubExp (Var v) = do t <- lookupType v letExp "zero" $ zeroExp t @@ -432,16 +432,16 @@ val_pats' <- bundleNew val_pats pat' <- bundleNew pat body' <- - localScope (scopeOfFParams (map fst val_pats) <> scopeOf loop) $ - slocal' $ fwdBody body + localScope (scopeOfFParams (map fst val_pats) <> scopeOf loop) . slocal' $ + fwdBody body addStm $ Let pat' aux $ DoLoop val_pats' (WhileLoop v) body' fwdStm (Let pat aux (DoLoop val_pats loop@(ForLoop i it bound loop_vars) body)) = do pat' <- bundleNew pat val_pats' <- bundleNew val_pats loop_vars' <- bundleNew loop_vars body' <- - localScope (scopeOfFParams (map fst val_pats) <> scopeOf loop) $ - slocal' $ fwdBody body + localScope (scopeOfFParams (map fst val_pats) <> scopeOf loop) . slocal' $ + fwdBody body addStm $ Let pat' aux $ DoLoop val_pats' (ForLoop i it bound loop_vars') body' fwdStm (Let pat aux (WithAcc inputs lam)) = do inputs' <- forM inputs $ \(shape, arrs, op) -> do diff --git a/src/Futhark/AD/Rev.hs b/src/Futhark/AD/Rev.hs --- a/src/Futhark/AD/Rev.hs +++ b/src/Futhark/AD/Rev.hs @@ -135,15 +135,15 @@ returnSweepCode $ do arr_dims <- arrayDims <$> lookupType arr void $ - updateAdj arr <=< letExp "adj_reshape" $ - BasicOp $ Reshape (map DimNew arr_dims) pat_adj + updateAdj arr <=< letExp "adj_reshape" . BasicOp $ + Reshape (map DimNew arr_dims) pat_adj -- Rearrange perm arr -> do (_pat_v, pat_adj) <- commonBasicOp pat aux e m returnSweepCode $ void $ - updateAdj arr <=< letExp "adj_rearrange" $ - BasicOp $ Rearrange (rearrangeInverse perm) pat_adj + updateAdj arr <=< letExp "adj_rearrange" . BasicOp $ + Rearrange (rearrangeInverse perm) pat_adj -- Rotate rots arr -> do (_pat_v, pat_adj) <- commonBasicOp pat aux e m @@ -151,8 +151,8 @@ let neg = BasicOp . BinOp (Sub Int64 OverflowWrap) (intConst Int64 0) rots' <- mapM (letSubExp "rot_neg" . neg) rots void $ - updateAdj arr <=< letExp "adj_rotate" $ - BasicOp $ Rotate rots' pat_adj + updateAdj arr <=< letExp "adj_rotate" . BasicOp $ + Rotate rots' pat_adj -- Replicate (Shape ns) x -> do (_pat_v, pat_adj) <- commonBasicOp pat aux e m @@ -162,8 +162,8 @@ ne <- letSubExp "zero" $ zeroExp x_t n <- letSubExp "rep_size" =<< foldBinOp (Mul Int64 OverflowUndef) (intConst Int64 1) ns pat_adj_flat <- - letExp (baseString pat_adj <> "_flat") $ - BasicOp $ Reshape (map DimNew $ n : arrayDims x_t) pat_adj + letExp (baseString pat_adj <> "_flat") . BasicOp $ + Reshape (map DimNew $ n : arrayDims x_t) pat_adj reduce <- reduceSOAC [Reduce Commutative lam [ne]] updateSubExpAdj x =<< letExp "rep_contrib" (Op $ Screma n [pat_adj_flat] reduce) @@ -178,7 +178,8 @@ slice = DimSlice start w (intConst Int64 1) pat_adj_slice <- letExp (baseString pat_adj <> "_slice") $ - BasicOp $ Index pat_adj (sliceAt v_t d [slice]) + BasicOp $ + Index pat_adj (sliceAt v_t d [slice]) start' <- letSubExp "start" $ BasicOp $ BinOp (Add Int64 OverflowUndef) start w slices <- sliceAdj start' vs pure $ pat_adj_slice : slices diff --git a/src/Futhark/AD/Rev/Loop.hs b/src/Futhark/AD/Rev/Loop.hs --- a/src/Futhark/AD/Rev/Loop.hs +++ b/src/Futhark/AD/Rev/Loop.hs @@ -71,8 +71,8 @@ let indexify (x_param, xs) = do xs_t <- lookupType xs x' <- - letExp (baseString $ paramName x_param) $ - BasicOp $ Index xs $ fullSlice xs_t [DimFix (Var i)] + letExp (baseString $ paramName x_param) . BasicOp . Index xs $ + fullSlice xs_t [DimFix (Var i)] pure (paramName x_param, x') (substs_list, subst_stms) <- collectStms $ mapM indexify loop_vars let Body aux' stms' res' = substituteNames (M.fromList substs_list) body @@ -136,25 +136,24 @@ loop_inits' = map (Var . paramName) loop_params val_pats'' = zip loop_params' loop_inits' outer_body <- - buildBody_ $ - do - offset' <- - letSubExp "offset" $ - BasicOp $ BinOp (Mul it OverflowUndef) offset (Var i) + buildBody_ $ do + offset' <- + letSubExp "offset" . BasicOp $ + BinOp (Mul it OverflowUndef) offset (Var i) - inner_body <- insertStmsM $ do - i_inner <- - letExp "i_inner" $ - BasicOp $ BinOp (Add it OverflowUndef) offset' (Var i') - pure $ substituteNames (M.singleton i' i_inner) body' + inner_body <- insertStmsM $ do + i_inner <- + letExp "i_inner" . BasicOp $ + BinOp (Add it OverflowUndef) offset' (Var i') + pure $ substituteNames (M.singleton i' i_inner) body' - inner_loop <- - letTupExp "inner_loop" - =<< nestifyLoop' - offset' - (n - 1) - (DoLoop val_pats'' (ForLoop i' it' bound_se loop_vars') inner_body) - pure $ varsRes inner_loop + inner_loop <- + letTupExp "inner_loop" + =<< nestifyLoop' + offset' + (n - 1) + (DoLoop val_pats'' (ForLoop i' it' bound_se loop_vars') inner_body) + pure $ varsRes inner_loop pure $ DoLoop val_pats (ForLoop i it bound_se loop_vars) outer_body | n == 1 = @@ -174,8 +173,8 @@ bound' <- letSubExp "bound" $ BasicOp $ BinOp (FPow Float64) bound_float n_root bound_int <- letSubExp "bound_int" $ BasicOp $ ConvOp (FPToUI Float64 it) bound' total_iters <- - letSubExp "total_iters" $ - BasicOp $ BinOp (Pow it) bound_int (Constant $ IntValue $ intValue it n) + letSubExp "total_iters" . BasicOp $ + BinOp (Pow it) bound_int (Constant $ IntValue $ intValue it n) remain_iters <- letSubExp "remain_iters" $ BasicOp $ BinOp (Sub it OverflowUndef) bound total_iters mined_loop <- nestifyLoop bound_int n loop @@ -183,8 +182,8 @@ renameForLoop loop $ \_loop' val_pats' _form' i' it' _bound' loop_vars' body' -> do remain_body <- insertStmsM $ do i_remain <- - letExp "i_remain" $ - BasicOp $ BinOp (Add it OverflowUndef) total_iters (Var i') + letExp "i_remain" . BasicOp $ + BinOp (Add it OverflowUndef) total_iters (Var i') pure $ substituteNames (M.singleton i' i_remain) body' let loop_params_rem = map fst val_pats' loop_inits_rem = map (Var . patElemName) $ patElems pat' @@ -246,12 +245,15 @@ let saved_param = Param mempty saved_param_v $ arrayOf t (Shape [bound64]) Unique saved_pat = PatElem saved_pat_v $ arrayOf t (Shape [bound64]) NoUniqueness saved_update <- - localScope (scopeOfFParams [saved_param]) $ - letInPlace + localScope (scopeOfFParams [saved_param]) + $ letInPlace (baseString v <> "_saved_update") saved_param_v (fullSlice (fromDecl $ paramDec saved_param) [DimFix i_i64]) - $ substituteNames copy_substs $ BasicOp $ SubExp $ Var v + $ substituteNames copy_substs + $ BasicOp + $ SubExp + $ Var v pure (saved_update, (saved_pat, saved_param)) pure (bodyResult body <> varsRes saved_updates, unzip saved_pats_params) @@ -286,18 +288,17 @@ forM (map snd loop_vars) $ \xs -> do xs_t <- lookupType xs xs_rev <- - letExp "reverse" $ - BasicOp $ - Index xs $ - fullSlice - xs_t - [DimSlice bound_minus_one bound (Constant (IntValue (Int64Value (-1))))] + letExp "reverse" . BasicOp . Index xs $ + fullSlice + xs_t + [DimSlice bound_minus_one bound (Constant (IntValue (Int64Value (-1))))] pure (xs, xs_rev) (i_rev, i_stms) <- collectStms $ inScopeOf form $ do letExp (baseString i <> "_rev") $ - BasicOp $ BinOp (Sub it OverflowWrap) bound_minus_one (Var i) + BasicOp $ + BinOp (Sub it OverflowWrap) bound_minus_one (Var i) pure (var_arrays_substs, M.singleton i i_rev, i_stms) diff --git a/src/Futhark/AD/Rev/Map.hs b/src/Futhark/AD/Rev/Map.hs --- a/src/Futhark/AD/Rev/Map.hs +++ b/src/Futhark/AD/Rev/Map.hs @@ -104,8 +104,8 @@ inBounds res_i adj_i adj_v = subAD . buildRenamedBody $ do forM_ (zip (lambdaParams map_lam) as) $ \(p, a) -> do a_t <- lookupType a - letBindNames [paramName p] $ - BasicOp $ Index a $ fullSlice a_t [DimFix adj_i] + letBindNames [paramName p] . BasicOp . Index a $ + fullSlice a_t [DimFix adj_i] adj_elems <- fmap (map resSubExp) . bodyBind . lambdaBody =<< vjpLambda ops (oneHot res_i (AdjVal adj_v)) adjs_for map_lam @@ -228,6 +228,6 @@ zero <- letSubExp "zero" $ zeroExp t reduce <- reduceSOAC [Reduce Commutative lam [zero]] contrib_sum <- - letExp (baseString v <> "_contrib_sum") $ - Op $ Screma w [contribs] reduce + letExp (baseString v <> "_contrib_sum") . Op $ + Screma w [contribs] reduce void $ updateAdj v contrib_sum diff --git a/src/Futhark/AD/Rev/Monad.hs b/src/Futhark/AD/Rev/Monad.hs --- a/src/Futhark/AD/Rev/Monad.hs +++ b/src/Futhark/AD/Rev/Monad.hs @@ -29,7 +29,6 @@ updateAdjIndex, setAdj, insAdj, - insSubExpAdj, adjsReps, -- copyConsumedArrsInStm, @@ -138,7 +137,8 @@ | otherwise = do zero <- letSubExp "zero" $ zeroExp t attributing (oneAttr "sequential") $ - letExp "zeroes_" $ BasicOp $ Replicate shape zero + letExp "zeroes_" . BasicOp $ + Replicate shape zero sparseArray :: (MonadBuilder m, Rep m ~ SOACS) => Sparse -> m VName sparseArray (Sparse shape t ivs) = do @@ -390,8 +390,8 @@ dims <- arrayDims <$> lookupType d ~[v_adj'] <- tabNest (length dims) [d, v_adj] $ \is [d', v_adj'] -> - letTupExp "acc" $ - BasicOp $ UpdateAcc v_adj' (map Var is) [Var d'] + letTupExp "acc" . BasicOp $ + UpdateAcc v_adj' (map Var is) [Var d'] insAdj v v_adj' _ -> do v_adj' <- letExp (baseString v <> "_adj") =<< addExp v_adj d @@ -411,7 +411,8 @@ tabNest (length dims) [d, v_adj] $ \is [d', v_adj'] -> do slice' <- traverse (toSubExp "index") $ - fixSlice (fmap pe64 slice) $ map le64 is + fixSlice (fmap pe64 slice) $ + map le64 is letTupExp (baseString v_adj') . BasicOp $ UpdateAcc v_adj' slice' [Var d'] pure v_adj' @@ -427,10 +428,6 @@ updateSubExpAdj Constant {} _ = pure () updateSubExpAdj (Var v) d = void $ updateAdj v d -insSubExpAdj :: SubExp -> VName -> ADM () -insSubExpAdj Constant {} _ = pure () -insSubExpAdj (Var v) d = void $ insAdj v d - -- The index may be negative, in which case the update has no effect. updateAdjIndex :: VName -> (InBounds, SubExp) -> SubExp -> ADM () updateAdjIndex v (check, i) se = do @@ -457,15 +454,18 @@ dims <- arrayDims <$> lookupType se_v ~[v_adj'] <- tabNest (length dims) [se_v, v_adj] $ \is [se_v', v_adj'] -> - letTupExp "acc" $ - BasicOp $ UpdateAcc v_adj' (i : map Var is) [Var se_v'] + letTupExp "acc" . BasicOp $ + UpdateAcc v_adj' (i : map Var is) [Var se_v'] pure v_adj' _ -> do let stms s = do - v_adj_i <- letExp (baseString v_adj <> "_i") $ BasicOp $ Index v_adj $ fullSlice v_adj_t [DimFix i] + v_adj_i <- + letExp (baseString v_adj <> "_i") . BasicOp $ + Index v_adj $ + fullSlice v_adj_t [DimFix i] se_update <- letSubExp "updated_adj_i" =<< addExp se_v v_adj_i - letExp (baseString v_adj) $ - BasicOp $ Update s v_adj (fullSlice v_adj_t [DimFix i]) se_update + letExp (baseString v_adj) . BasicOp $ + Update s v_adj (fullSlice v_adj_t [DimFix i]) se_update case check of CheckBounds _ -> stms Safe AssumeBounds -> stms Unsafe diff --git a/src/Futhark/AD/Rev/Reduce.hs b/src/Futhark/AD/Rev/Reduce.hs --- a/src/Futhark/AD/Rev/Reduce.hs +++ b/src/Futhark/AD/Rev/Reduce.hs @@ -23,8 +23,8 @@ arr_t <- lookupType arr let w = arraySize 0 arr_t start <- - letSubExp "rev_start" $ - BasicOp $ BinOp (Sub Int64 OverflowUndef) w (intConst Int64 1) + letSubExp "rev_start" . BasicOp $ + BinOp (Sub Int64 OverflowUndef) w (intConst Int64 1) let stride = intConst Int64 (-1) slice = fullSlice arr_t [DimSlice start w stride] letExp (baseString arr <> "_rev") $ BasicOp $ Index arr slice @@ -91,7 +91,9 @@ isAdd op = do adj_rep <- letExp (baseString adj <> "_rep") $ - BasicOp $ Replicate (Shape [w]) $ Var adj + BasicOp $ + Replicate (Shape [w]) $ + Var adj void $ updateAdj a adj_rep where isAdd FAdd {} = True @@ -190,7 +192,8 @@ red_iota <- letExp "red_iota" $ - BasicOp $ Iota w (intConst Int64 0) (intConst Int64 1) Int64 + BasicOp $ + Iota w (intConst Int64 0) (intConst Int64 1) Int64 form <- reduceSOAC [Reduce Commutative red_lam [ne, intConst Int64 (-1)]] x_ind <- newVName (baseString x <> "_ind") auxing aux $ letBindNames [x, x_ind] $ Op $ Screma w [as, red_iota] form diff --git a/src/Futhark/AD/Rev/Scan.hs b/src/Futhark/AD/Rev/Scan.hs --- a/src/Futhark/AD/Rev/Scan.hs +++ b/src/Futhark/AD/Rev/Scan.hs @@ -82,7 +82,9 @@ nm1 <- letSubExp "nm1" =<< toExp (pe64 w - 1) y_adj_last <- letExp (baseString y_adj ++ "_last") $ - BasicOp $ Index y_adj $ fullSlice arr_tp [DimFix nm1] + BasicOp $ + Index y_adj $ + fullSlice arr_tp [DimFix nm1] par_i <- newParam "i" $ Prim int64 lam <- mkLambda [par_i] $ do diff --git a/src/Futhark/AD/Rev/Scatter.hs b/src/Futhark/AD/Rev/Scatter.hs --- a/src/Futhark/AD/Rev/Scatter.hs +++ b/src/Futhark/AD/Rev/Scatter.hs @@ -113,7 +113,8 @@ -- creating xs_adj zeros <- replicateM (length val_as) . letExp "zeros" $ - zeroExp $ xs_t `setOuterSize` w + zeroExp $ + xs_t `setOuterSize` w let f_tps = replicate (rank * num_vals) (Prim int64) ++ replicate num_vals val_t f <- mkIdentityLambda f_tps xs_adj <- diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -19,6 +19,7 @@ compileOpenCLAction, compileCUDAAction, compileMulticoreAction, + compileMulticoreToISPCAction, compileMulticoreToWASMAction, compilePythonAction, compilePyOpenCLAction, @@ -40,6 +41,7 @@ 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.MulticoreISPC as MulticoreISPC import qualified Futhark.CodeGen.Backends.MulticoreWASM as MulticoreWASM import qualified Futhark.CodeGen.Backends.PyOpenCL as PyOpenCL import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC @@ -149,7 +151,7 @@ Action { actionName = "Compile to imperative multicore", actionDescription = "Translate program into imperative multicore IL and write it on standard output.", - actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenMulticore.compileProg ImpGenMulticore.AllowDynamicScheduling + actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenMulticore.compileProg } -- Lines that we prepend (in comments) to generated code. @@ -174,6 +176,9 @@ cmdCFLAGS :: [String] -> [String] cmdCFLAGS def = maybe def words $ lookup "CFLAGS" unixEnvironment +cmdISPCFLAGS :: [String] -> [String] +cmdISPCFLAGS def = maybe def words $ lookup "ISPCFLAGS" unixEnvironment + runCC :: String -> String -> [String] -> [String] -> FutharkM () runCC cpath outpath cflags_def ldflags = do ret <- @@ -192,13 +197,58 @@ externalErrorS $ "Failed to run " ++ cmdCC ++ ": " ++ show err Right (ExitFailure code, _, gccerr) -> externalErrorS $ - cmdCC ++ " failed with code " + cmdCC + ++ " failed with code " ++ show code ++ ":\n" ++ gccerr Right (ExitSuccess, _, _) -> pure () +runISPC :: String -> String -> String -> String -> [String] -> [String] -> [String] -> FutharkM () +runISPC ispcpath outpath cpath ispcextension ispc_flags cflags_def ldflags = do + ret_ispc <- + liftIO $ + runProgramWithExitCode + "ispc" + ( [ispcpath, "-o", ispcbase `addExtension` "o"] + ++ ["--addressing=64", "--pic"] + ++ cmdISPCFLAGS ispc_flags -- These flags are always needed + ) + mempty + ret <- + liftIO $ + runProgramWithExitCode + cmdCC + ( [ispcbase `addExtension` "o"] + ++ [cpath, "-o", outpath] + ++ cmdCFLAGS cflags_def + ++ + -- The default LDFLAGS are always added. + ldflags + ) + mempty + case ret_ispc of + Left err -> + externalErrorS $ "Failed to run " ++ cmdCC ++ ": " ++ show err + Right (ExitFailure code, _, gccerr) -> throwError code gccerr + Right (ExitSuccess, _, _) -> + case ret of + Left err -> + externalErrorS $ "Failed to run ispc: " ++ show err + Right (ExitFailure code, _, gccerr) -> throwError code gccerr + Right (ExitSuccess, _, _) -> + pure () + where + ispcbase = outpath <> ispcextension + throwError code gccerr = + externalErrorS $ + cmdCC + ++ " failed with code " + ++ show code + ++ ":\n" + ++ gccerr + -- | The @futhark c@ action. compileCAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem compileCAction fcfg mode outpath = @@ -321,6 +371,38 @@ ToServer -> do liftIO $ T.writeFile cpath $ cPrependHeader $ MulticoreC.asServer cprog runCC cpath outpath ["-O3", "-std=c99"] ["-lm", "-pthread"] + +-- | The @futhark ispc@ action. +compileMulticoreToISPCAction :: FutharkConfig -> CompilerMode -> FilePath -> Action MCMem +compileMulticoreToISPCAction fcfg mode outpath = + Action + { actionName = "Compile to multicore ISPC", + actionDescription = "Compile to multicore ISPC", + actionProcedure = helper + } + where + helper prog = do + let cpath = outpath `addExtension` "c" + hpath = outpath `addExtension` "h" + jsonpath = outpath `addExtension` "json" + ispcpath = outpath `addExtension` "kernels.ispc" + ispcextension = "_ispc" + (cprog, ispc) <- handleWarnings fcfg $ MulticoreISPC.compileProg (T.pack versionString) prog + case mode of + ToLibrary -> do + let (header, impl, manifest) = MulticoreC.asLibrary cprog + liftIO $ T.writeFile hpath $ cPrependHeader header + liftIO $ T.writeFile cpath $ cPrependHeader impl + liftIO $ T.writeFile ispcpath ispc + liftIO $ T.writeFile jsonpath manifest + ToExecutable -> do + liftIO $ T.writeFile cpath $ cPrependHeader $ MulticoreC.asExecutable cprog + liftIO $ T.writeFile ispcpath ispc + runISPC ispcpath outpath cpath ispcextension ["-O3", "--woff"] ["-O3", "-std=c99"] ["-lm", "-pthread"] + ToServer -> do + liftIO $ T.writeFile cpath $ cPrependHeader $ MulticoreC.asServer cprog + liftIO $ T.writeFile ispcpath ispc + runISPC ispcpath outpath cpath ispcextension ["-O3", "--woff"] ["-O3", "-std=c99"] ["-lm", "-pthread"] pythonCommon :: (CompilerMode -> String -> prog -> FutharkM (Warnings, T.Text)) -> 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 @@ -29,8 +29,11 @@ (ASTRep rep, CanBeAliased (Op rep)) => Prog rep -> Prog (Aliases rep) -aliasAnalysis (Prog consts funs) = - Prog (fst (analyseStms mempty consts)) (map analyseFun funs) +aliasAnalysis prog = + prog + { progConsts = fst (analyseStms mempty (progConsts prog)), + progFuns = map analyseFun (progFuns prog) + } -- | Perform alias analysis on function. analyseFun :: @@ -95,7 +98,8 @@ any (`nameIn` unAliases cons) $ v : namesToList (M.findWithDefault mempty v aliases) notConsumed = - AliasDec . namesFromList + AliasDec + . namesFromList . filter (not . isConsumed) . namesToList . unAliases 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 @@ -10,7 +10,6 @@ calledByConsts, allCalledBy, numOccurences, - findNoninlined, ) where @@ -141,39 +140,6 @@ pure body } --- | The set of all functions that are called noinline somewhere, or --- have a noinline attribute on their definition. -findNoninlined :: Prog SOACS -> S.Set Name -findNoninlined prog = - foldMap noinlineDef (progFuns prog) - <> foldMap onStm (foldMap (bodyStms . funDefBody) (progFuns prog) <> progConsts prog) - where - onStm :: Stm SOACS -> S.Set Name - onStm (Let _ aux (Apply fname _ _ _)) - | "noinline" `inAttrs` stmAuxAttrs aux = - S.singleton fname - onStm (Let _ _ e) = execWriter $ mapExpM folder e - where - folder = - identityMapper - { mapOnBody = \_ body -> do - tell $ foldMap onStm $ bodyStms body - pure body, - mapOnOp = - mapSOACM - identitySOACMapper - { mapOnSOACLambda = \lam -> do - tell $ foldMap onStm $ bodyStms $ lambdaBody lam - pure lam - } - } - - noinlineDef fd - | "noinline" `inAttrs` funDefAttrs fd = - S.singleton $ funDefName fd - | otherwise = - mempty - instance Pretty FunCalls where ppr = stack . map f . M.toList . fcMap where @@ -186,5 +152,6 @@ ppFunCalls ("called at top level", cg) : map ppFunCalls (M.toList fg) where ppFunCalls (f, fcalls) = - ppr f text (map (const '=') (nameToString f)) + ppr f + text (map (const '=') (nameToString f)) indent 2 (ppr fcalls) 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 @@ -153,7 +153,8 @@ let nparams = zipWith (Param mempty) npnames $ map SOAC.inputRowType inps body <- runBodyBuilder $ localScope (scopeOfLParams nparams) $ do - letBindNames nres =<< SOAC.toExp + letBindNames nres + =<< SOAC.toExp =<< toSOAC (MapNest nw lam ns $ map (SOAC.identInput . paramIdent) nparams) pure $ resultBody $ map Var nres let outerlam = 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 @@ -41,6 +41,7 @@ -- * SOAC inputs Input (..), varInput, + inputTransforms, identInput, isVarInput, isVarishInput, @@ -52,6 +53,7 @@ inputRowType, transformRows, transposeInput, + applyTransforms, -- ** Input transformations ArrayTransforms, @@ -286,38 +288,46 @@ addInitialTransforms :: ArrayTransforms -> Input -> Input addInitialTransforms ts (Input ots a t) = Input (ts <> ots) a t +applyTransform :: MonadBuilder m => ArrayTransform -> VName -> m VName +applyTransform (Replicate cs n) ia = + certifying cs . letExp "repeat" . BasicOp $ + Futhark.Replicate n (Futhark.Var ia) +applyTransform (Rearrange cs perm) ia = do + r <- arrayRank <$> lookupType ia + certifying cs . letExp "rearrange" . BasicOp $ + Futhark.Rearrange (perm ++ [length perm .. r - 1]) ia +applyTransform (Reshape cs shape) ia = + certifying cs . letExp "reshape" . BasicOp $ + Futhark.Reshape shape ia +applyTransform (ReshapeOuter cs shape) ia = do + shape' <- reshapeOuter shape 1 . arrayShape <$> lookupType ia + certifying cs . letExp "reshape_outer" . BasicOp $ + Futhark.Reshape shape' ia +applyTransform (ReshapeInner cs shape) ia = do + shape' <- reshapeInner shape 1 . arrayShape <$> lookupType ia + certifying cs . letExp "reshape_inner" . BasicOp $ + Futhark.Reshape shape' ia + +applyTransforms :: MonadBuilder m => ArrayTransforms -> VName -> m VName +applyTransforms (ArrayTransforms ts) a = foldlM (flip applyTransform) a ts + -- | Convert SOAC inputs to the corresponding expressions. inputsToSubExps :: (MonadBuilder m) => [Input] -> m [VName] -inputsToSubExps = mapM inputToExp' +inputsToSubExps = mapM f where - inputToExp' (Input (ArrayTransforms ts) a _) = - foldlM transform a ts - - transform ia (Replicate cs n) = - certifying cs $ - letExp "repeat" $ BasicOp $ Futhark.Replicate n (Futhark.Var ia) - transform ia (Rearrange cs perm) = - certifying cs $ - letExp "rearrange" $ BasicOp $ Futhark.Rearrange perm ia - transform ia (Reshape cs shape) = - certifying cs $ - letExp "reshape" $ BasicOp $ Futhark.Reshape shape ia - transform ia (ReshapeOuter cs shape) = do - shape' <- reshapeOuter shape 1 . arrayShape <$> lookupType ia - certifying cs $ - letExp "reshape_outer" $ BasicOp $ Futhark.Reshape shape' ia - transform ia (ReshapeInner cs shape) = do - shape' <- reshapeInner shape 1 . arrayShape <$> lookupType ia - certifying cs $ - letExp "reshape_inner" $ BasicOp $ Futhark.Reshape shape' ia + f (Input ts a _) = applyTransforms ts a -- | Return the array name of the input. inputArray :: Input -> VName inputArray (Input _ v _) = v +-- | The transformations applied to an input. +inputTransforms :: Input -> ArrayTransforms +inputTransforms (Input ts _ _) = ts + -- | Return the type of an input. inputType :: Input -> Type inputType (Input (ArrayTransforms ts) _ at) = @@ -398,7 +408,8 @@ instance PrettyRep rep => PP.Pretty (SOAC rep) where ppr (Screma w form arrs) = Futhark.ppScrema w arrs form ppr (Hist len ops bucket_fun imgs) = Futhark.ppHist len imgs ops bucket_fun - ppr soac = text $ show soac + ppr (Stream w form lam nes arrs) = Futhark.ppStream w arrs form nes lam + ppr (Scatter w lam arrs dests) = Futhark.ppScatter w arrs lam dests -- | Returns the inputs used in a SOAC. inputs :: SOAC rep -> [Input] @@ -606,14 +617,16 @@ lastel_tmp_ids scan0_ids lelstm = - mkLet lastel_ids $ - If + mkLet lastel_ids + $ If (Futhark.Var $ identName empty_arr) (mkBody mempty $ subExpsRes nes) ( mkBody (stmsFromList leltmpstms) $ - varsRes $ map identName lastel_tmp_ids + varsRes $ + map identName lastel_tmp_ids ) - $ ifCommon $ map identType 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 mapstm = 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 @@ -282,10 +282,11 @@ memSizesExp :: LocalScope GPUMem m => Exp GPUMem -> m (Map VName Int) memSizesExp (Op (Inner (SegOp segop))) = let body = segBody segop - in inScopeOf (kernelBodyStms body) $ - fmap mconcat + in inScopeOf (kernelBodyStms body) + $ fmap mconcat <$> mapM memSizesStm - $ stmsToList $ kernelBodyStms body + $ stmsToList + $ kernelBodyStms body memSizesExp (If _ then_body else_body _) = do then_res <- memSizes $ bodyStms then_body else_res <- memSizes $ bodyStms else_body @@ -333,7 +334,8 @@ pure (res1 <> res2) helper stm@Let {stmExp = DoLoop merge _ body} = fmap (analyseLoopParams merge) . inScopeOf stm $ - analyseGPU' lumap $ bodyStms body + analyseGPU' lumap $ + bodyStms body helper stm = inScopeOf stm $ pure mempty 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 @@ -5,7 +5,14 @@ {-# LANGUAGE TypeFamilies #-} -- | Provides last-use analysis for Futhark programs. -module Futhark.Analysis.LastUse (LastUseMap, Used, analyseGPUMem, analyseSeqMem) where +module Futhark.Analysis.LastUse + ( LastUseMap, + LastUse, + Used, + analyseGPUMem, + analyseSeqMem, + ) +where import Control.Monad.Reader import Data.Bifunctor (first) @@ -19,17 +26,17 @@ import Futhark.IR.GPUMem import Futhark.IR.SeqMem --- | `LastUseMap` tells which names were last used in a given statement. --- Statements are uniquely identified by the `VName` of the first value --- parameter in the statement pattern. `Names` is the set of names last used. +-- | 'LastUseMap' tells which names were last used in a given statement. +-- Statements are uniquely identified by the 'VName' of the first value +-- parameter in the statement pattern. 'Names' is the set of names last used. type LastUseMap = Map VName Names --- | `LastUse` is a mapping from a `VName` to the statement identifying it's --- last use. `LastUseMap` is the inverse of `LastUse`. +-- | 'LastUse' is a mapping from a 'VName' to the statement identifying it's +-- last use. 'LastUseMap' is the inverse of 'LastUse'. type LastUse = Map VName VName --- | `Used` is the set of `VName` that were used somewhere in a statement, body --- or otherwise. +-- | 'Used' is the set of 'VName' that were used somewhere in a +-- statement, body or otherwise. type Used = Names type LastUseOp rep = @@ -189,7 +196,10 @@ analyseHistOp (lumap, used) (HistOp width race dest neutral shp lambda) = do (lumap', used') <- analyseLambda (lumap, used) lambda let nms = - ( freeIn width <> freeIn race <> freeIn dest <> freeIn neutral + ( freeIn width + <> freeIn race + <> freeIn dest + <> freeIn neutral <> freeIn shp ) `namesSubtract` used' diff --git a/src/Futhark/Analysis/MemAlias.hs b/src/Futhark/Analysis/MemAlias.hs --- a/src/Futhark/Analysis/MemAlias.hs +++ b/src/Futhark/Analysis/MemAlias.hs @@ -1,10 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Futhark.Analysis.MemAlias ( analyzeSeqMem, analyzeGPUMem, - canBeSameMemory, aliasesOf, MemAliases, ) @@ -45,7 +45,9 @@ mempty = MemAliases mempty instance Pretty MemAliases where - ppr (MemAliases m) = ppr m + ppr (MemAliases m) = stack $ map f $ M.toList m + where + f (v, vs) = ppr v <+> "aliases:" indent 2 (oneLine $ ppr vs) addAlias :: VName -> VName -> MemAliases -> MemAliases addAlias v1 v2 m = @@ -54,15 +56,6 @@ singleton :: VName -> Names -> MemAliases singleton v ns = MemAliases $ M.singleton v ns -canBeSameMemory :: MemAliases -> VName -> VName -> Bool -canBeSameMemory (MemAliases m) v1 v2 = - case fmap (v2 `nameIn`) (M.lookup v1 m) of - Just True -> True - Just False -> case fmap (v1 `nameIn`) (M.lookup v2 m) of - Just b -> b - Nothing -> error $ "VName not found in MemAliases: " <> pretty v2 - Nothing -> error $ "VName not found in MemAliases: " <> pretty v1 - aliasesOf :: MemAliases -> VName -> Names aliasesOf (MemAliases m) v = fromMaybe mempty $ M.lookup v m @@ -82,7 +75,9 @@ analyzeStms (kernelBodyStms kbody) m analyzeHostOp m (SegOp (SegHist _ _ _ _ kbody)) = analyzeStms (kernelBodyStms kbody) m -analyzeHostOp _ _ = pure mempty +analyzeHostOp m SizeOp {} = pure m +analyzeHostOp m GPUBody {} = pure m +analyzeHostOp m (OtherOp ()) = pure m analyzeStm :: (Mem rep inner, LetDec rep ~ LetDecMem) => MemAliases -> Stm rep -> MemAliasesM inner MemAliases analyzeStm m (Let (Pat [PatElem vname _]) _ (Op (Alloc _ _))) = 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 @@ -27,7 +27,7 @@ constFoldPrimExp, -- * Construction - module Futhark.IR.Primitive, + module Language.Futhark.Primitive, NumExp (..), IntExp (..), FloatExp (..), @@ -75,10 +75,10 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Traversable -import Futhark.IR.Primitive import Futhark.IR.Prop.Names import Futhark.Util.IntegralExp import Futhark.Util.Pretty +import Language.Futhark.Primitive import Prelude hiding (id, (.)) -- | A primitive expression parametrised over the representation of 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 @@ -45,7 +45,9 @@ toExp (ValueExp v) = pure $ BasicOp $ SubExp $ Constant v toExp (FunExp h args t) = - Apply (nameFromString h) <$> args' <*> pure [primRetType t] + Apply (nameFromString h) + <$> args' + <*> pure [primRetType t] <*> pure (Safe, mempty, []) where args' = zip <$> mapM (toSubExp "apply_arg") args <*> pure (repeat Observe) 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 @@ -15,8 +15,8 @@ import qualified Data.Text as T import Data.Void import Futhark.Analysis.PrimExp -import Futhark.IR.Primitive.Parse import Futhark.Util.Pretty (prettyText) +import Language.Futhark.Primitive.Parse import Text.Megaparsec pBinOp :: Parsec Void T.Text BinOp 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 @@ -35,10 +35,10 @@ -- | Rephrase an entire program. rephraseProg :: Monad m => Rephraser m from to -> Prog from -> m (Prog to) -rephraseProg rephraser (Prog consts funs) = - Prog - <$> mapM (rephraseStm rephraser) consts - <*> mapM (rephraseFunDef rephraser) funs +rephraseProg rephraser prog = do + consts <- mapM (rephraseStm rephraser) (progConsts prog) + funs <- mapM (rephraseFunDef rephraser) (progFuns prog) + pure $ prog {progConsts = consts, progFuns = funs} -- | Rephrase a function definition. rephraseFunDef :: Monad m => Rephraser m from to -> FunDef from -> m (FunDef to) 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 @@ -422,7 +422,8 @@ in vtable { bindings = adjustSeveral isSize dims $ - M.insert name entry' $ bindings vtable + M.insert name entry' $ + bindings vtable } insertEntries :: 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 @@ -66,8 +66,10 @@ expand look (UsageTable m) = UsageTable $ foldl' grow m $ IM.toList m where grow m' (k, v) = - foldl' (grow'' $ v `withoutU` presentU) m' $ - namesIntMap $ look $ VName (nameFromString "") k + foldl' + (grow'' $ v `withoutU` presentU) + m' + (namesIntMap $ look $ VName (nameFromString "") k) grow'' v m'' k = IM.insertWith (<>) (baseTag k) v m'' is :: Usages -> VName -> UsageTable -> Bool @@ -171,9 +173,7 @@ usageInExp :: Aliased rep => Exp rep -> UsageTable usageInExp (Apply _ args _ _) = mconcat - [ mconcat $ - map consumedUsage $ - namesToList $ subExpAliases arg + [ mconcat $ map consumedUsage $ namesToList $ subExpAliases arg | (arg, d) <- args, d == Consume ] diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -373,7 +373,9 @@ Left err -> pure $ Left - ( "Reference output generation for " ++ program ++ " failed:\n" + ( "Reference output generation for " + ++ program + ++ " failed:\n" ++ unlines (map T.unpack err), Nothing ) diff --git a/src/Futhark/Builder.hs b/src/Futhark/Builder.hs --- a/src/Futhark/Builder.hs +++ b/src/Futhark/Builder.hs @@ -105,7 +105,13 @@ lookupType name = do t <- BuilderT $ gets $ M.lookup name . snd case t of - Nothing -> error $ "BuilderT.lookupType: unknown variable " ++ pretty name + Nothing -> do + known <- BuilderT $ gets $ M.keys . snd + error . unlines $ + [ "BuilderT.lookupType: unknown variable " ++ pretty name, + "Known variables: ", + unwords $ map pretty known + ] Just t' -> pure $ typeOf t' askScope = BuilderT $ gets snd diff --git a/src/Futhark/CLI/Autotune.hs b/src/Futhark/CLI/Autotune.hs --- a/src/Futhark/CLI/Autotune.hs +++ b/src/Futhark/CLI/Autotune.hs @@ -99,10 +99,10 @@ serverOptions :: AutotuneOptions -> [String] serverOptions opts = - "--default-threshold" : - show (optDefaultThreshold opts) : - "-L" : - optExtraOptions opts + "--default-threshold" + : show (optDefaultThreshold opts) + : "-L" + : optExtraOptions opts setTuningParam :: Server -> String -> Int -> IO () setTuningParam server name val = @@ -177,7 +177,7 @@ ropts = runOptions timeout opts when (optVerbose opts > 1) $ - putStrLn $ "Trying path: " ++ show path + putStrLn ("Trying path: " ++ show path) -- Setting the tuning parameters is a stateful action, so we -- must be careful to restore the defaults below. This is @@ -235,7 +235,8 @@ let root (v, _) = ((v, False), []) pure $ unfoldForest (unfold thresholds) $ - map root $ filter (null . snd) thresholds + map root $ + filter (null . snd) thresholds where getThresholds = mapMaybe findThreshold . lines regex = makeRegex ("(.*) \\(threshold\\(([^ ]+,)(.*)\\)\\)" :: String) @@ -245,14 +246,14 @@ [grp1, _, grp2] <- regexGroups regex l pure ( grp1, - filter (not . null . fst) $ - map + filter (not . null . fst) + $ map ( \x -> if "!" `isPrefixOf` x then (drop 1 x, False) else (x, True) ) - $ words grp2 + $ words grp2 ) unfold thresholds ((parent, parent_cmp), ancestors) = @@ -294,7 +295,8 @@ if not $ isPrefixOf (T.unpack entry_point ++ ".") v then do when (optVerbose opts > 0) $ - putStrLn $ unwords [v, "is irrelevant for", T.unpack entry_point] + putStrLn $ + unwords [v, "is irrelevant for", T.unpack entry_point] pure (thresholds, best_runtimes) else do putStrLn $ @@ -340,7 +342,8 @@ pure Nothing when (optVerbose opts > 1) $ - putStrLn $ unwords ("Got ePars: " : map show ePars) + putStrLn $ + unwords ("Got ePars: " : map show ePars) (best_t, newMax) <- binarySearch runner (t, tMax) ePars let newMinIdx = do @@ -417,7 +420,8 @@ pure (best_t, best_e_par) (_, _) -> do when (optVerbose opts > 0) $ - putStrLn $ unwords ["Trying e_pars", show xs] + putStrLn $ + unwords ["Trying e_pars", show xs] candidates <- catMaybes . zipWith (fmap . flip (,)) xs <$> mapM (runner $ timeout best_t) xs @@ -434,7 +438,10 @@ forest <- thresholdForest prog when (optVerbose opts > 0) $ - putStrLn $ ("Threshold forest:\n" ++) $ drawForest $ map (fmap show) forest + putStrLn $ + ("Threshold forest:\n" ++) $ + drawForest $ + map (fmap show) forest let progbin = "." dropExtension prog putStrLn $ "Running with options: " ++ unwords (serverOptions opts) 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 @@ -115,7 +115,8 @@ <> show (optMinTime opts) <> ")." when (optConvergencePhase opts) . putStrLn $ - "More runs automatically performed for up to " <> show (optConvergenceMaxTime opts) + "More runs automatically performed for up to " + <> show (optConvergenceMaxTime opts) <> " to ensure accurate measurement." futhark <- FutharkExe . compFuthark <$> compileOptions opts @@ -266,7 +267,8 @@ interimResult :: Int -> Int -> Double -> T.Text interimResult us_sum runs elapsed = - T.pack (printf "%10.0fμs " avg) <> progress elapsed + T.pack (printf "%10.0fμs " avg) + <> progress elapsed <> (" " <> prettyText runs <> " runs") where avg :: Double diff --git a/src/Futhark/CLI/Check.hs b/src/Futhark/CLI/Check.hs --- a/src/Futhark/CLI/Check.hs +++ b/src/Futhark/CLI/Check.hs @@ -30,5 +30,7 @@ [file] -> Just $ do (warnings, _, _) <- readProgramOrDie file when (checkWarn cfg && anyWarnings warnings) $ - liftIO $ hPutStrLn stderr $ pretty warnings + liftIO $ + hPutStrLn stderr $ + pretty warnings _ -> Nothing 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 @@ -200,8 +200,8 @@ V.ValueType ds t' <- toValueType t pure $ V.ValueType (d' : ds) t' where - constantDim (DimExpConst k _) = Right k - constantDim _ = Left "Array has non-constant dimension declaration." + constantDim (SizeExpConst k _) = Right k + constantDim _ = Left "Array has non-constant size." toValueType (TEVar (QualName [] v) _) | Just t <- lookup v m = Right $ V.ValueType [] t where 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 @@ -37,6 +37,7 @@ import Futhark.Optimise.InPlaceLowering import Futhark.Optimise.InliningDeadFun import qualified Futhark.Optimise.MemoryBlockMerging as MemoryBlockMerging +import Futhark.Optimise.ReduceDeviceSyncs (reduceDeviceSyncs) import Futhark.Optimise.Sink import Futhark.Optimise.TileLoops import Futhark.Optimise.Unstream @@ -198,7 +199,8 @@ pure prog kernelsMemProg name rep = externalErrorS $ - "Pass " ++ name + "Pass " + ++ name ++ " expects GPUMem representation, but got " ++ representation rep @@ -207,7 +209,8 @@ pure prog soacsProg name rep = externalErrorS $ - "Pass " ++ name + "Pass " + ++ name ++ " expects SOACS representation, but got " ++ representation rep @@ -348,7 +351,9 @@ repf <$> runPipeline pipeline config prog Nothing -> externalErrorS $ - "Expected " ++ repdesc ++ " representation, but got " + "Expected " + ++ repdesc + ++ " representation, but got " ++ representation rep soacsPipelineOption :: @@ -388,7 +393,9 @@ [] ["no-check"] ( NoArg $ - Right $ changeFutharkConfig $ \opts -> opts {futharkTypeCheck = False} + Right $ + changeFutharkConfig $ + \opts -> opts {futharkTypeCheck = False} ) "Disable type-checking.", Option @@ -411,6 +418,7 @@ "cuda" -> Right $ GPUMemAction compileCUDAAction "wasm" -> Right $ SeqMemAction compileCtoWASMAction "wasm-multicore" -> Right $ MCMemAction compileMulticoreToWASMAction + "ispc" -> Right $ MCMemAction compileMulticoreToISPCAction "python" -> Right $ SeqMemAction compilePythonAction "pyopencl" -> Right $ GPUMemAction compilePyOpenCLAction _ -> Left $ error $ "Invalid backend: " <> arg @@ -558,6 +566,7 @@ kernelsPassOption histAccsGPU [], kernelsPassOption unstreamGPU [], kernelsPassOption sinkGPU [], + kernelsPassOption reduceDeviceSyncs [], typedPassOption soacsProg GPU extractKernels [], typedPassOption soacsProg MC extractMulticore [], iplOption [], @@ -632,7 +641,9 @@ Just $ do res <- runFutharkM (m file config) $ - fst $ futharkVerbose $ futharkConfig config + fst $ + futharkVerbose $ + futharkConfig config case res of Left err -> do dumpError (futharkConfig config) err diff --git a/src/Futhark/CLI/Doc.hs b/src/Futhark/CLI/Doc.hs --- a/src/Futhark/CLI/Doc.hs +++ b/src/Futhark/CLI/Doc.hs @@ -72,7 +72,8 @@ write (name, content) = do let file = dir makeRelative "/" name when (docVerbose cfg) $ - hPutStrLn stderr $ "Writing " <> file + hPutStrLn stderr $ + "Writing " <> file createDirectoryIfMissing True $ takeDirectory file T.writeFile file content diff --git a/src/Futhark/CLI/LSP.hs b/src/Futhark/CLI/LSP.hs --- a/src/Futhark/CLI/LSP.hs +++ b/src/Futhark/CLI/LSP.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE OverloadedStrings #-} -- | @futhark lsp@ module Futhark.CLI.LSP (main) where @@ -9,7 +8,6 @@ import Data.IORef (newIORef) import Futhark.LSP.Handlers (handlers) import Futhark.LSP.State (emptyState) -import Futhark.Util (debug) import Language.LSP.Server import Language.LSP.Types ( SaveOptions (SaveOptions), @@ -17,14 +15,11 @@ TextDocumentSyncOptions (..), type (|?) (InR), ) -import System.Log.Logger (Priority (DEBUG)) -- | Run @futhark lsp@ main :: String -> [String] -> IO () main _prog _args = do state_mvar <- newIORef emptyState - debug "Init with emptyState" - setupLogger Nothing ["futhark"] DEBUG _ <- runServer $ ServerDefinition 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 @@ -114,7 +114,8 @@ pprDirective _ (DirectiveCovert f) = pprDirective False f pprDirective _ (DirectiveImg e params) = - "> :img " <> PP.align (PP.ppr e) + "> :img " + <> PP.align (PP.ppr e) <> if null params' then mempty else PP.stack $ ";" : params' where params' = @@ -133,14 +134,15 @@ "> :plot2d " <> PP.align (PP.ppr e) pprDirective True (DirectiveGnuplot e script) = PP.stack $ - "> :gnuplot " <> PP.align (PP.ppr e) <> ";" : - map PP.strictText (T.lines script) + "> :gnuplot " <> PP.align (PP.ppr e) <> ";" + : map PP.strictText (T.lines script) pprDirective False (DirectiveGnuplot e _) = "> :gnuplot " <> PP.align (PP.ppr e) pprDirective False (DirectiveVideo e _) = "> :video " <> PP.align (PP.ppr e) pprDirective True (DirectiveVideo e params) = - "> :video " <> PP.ppr e + "> :video " + <> PP.ppr e <> if null params' then mempty else PP.stack $ ";" : params' where params' = @@ -210,9 +212,13 @@ parsePlotParams :: Parser (Maybe (Int, Int)) parsePlotParams = optional $ - ";" *> hspace *> eol *> token "-- size:" + ";" + *> hspace + *> eol + *> token "-- size:" *> token "(" - *> ((,) <$> parseInt <* token "," <*> parseInt) <* token ")" + *> ((,) <$> parseInt <* token "," <*> parseInt) + <* token ")" withPredicate :: (a -> Bool) -> String -> Parser a -> Parser a withPredicate f msg p = do @@ -229,7 +235,8 @@ parseImgParams :: Parser ImgParams parseImgParams = fmap (fromMaybe defaultImgParams) $ - optional $ ";" *> hspace *> eol *> "-- " *> parseParams defaultImgParams + optional $ + ";" *> hspace *> eol *> "-- " *> parseParams defaultImgParams where parseParams params = choice @@ -246,7 +253,8 @@ parseVideoParams :: Parser VideoParams parseVideoParams = fmap (fromMaybe defaultVideoParams) $ - optional $ ";" *> hspace *> eol *> "-- " *> parseParams defaultVideoParams + optional $ + ";" *> hspace *> eol *> "-- " *> parseParams defaultVideoParams where parseParams params = choice @@ -293,22 +301,31 @@ parseDirective = choice [ DirectiveRes <$> parseExp postlexeme <* afterExp, - directiveName "covert" $> DirectiveCovert + directiveName "covert" + $> DirectiveCovert <*> parseDirective, - directiveName "brief" $> DirectiveBrief + directiveName "brief" + $> DirectiveBrief <*> parseDirective, - directiveName "img" $> DirectiveImg + directiveName "img" + $> DirectiveImg <*> parseExp postlexeme - <*> parseImgParams <* eol, - directiveName "plot2d" $> DirectivePlot + <*> parseImgParams + <* eol, + directiveName "plot2d" + $> DirectivePlot <*> parseExp postlexeme - <*> parsePlotParams <* eol, - directiveName "gnuplot" $> DirectiveGnuplot + <*> parsePlotParams + <* eol, + directiveName "gnuplot" + $> DirectiveGnuplot <*> parseExp postlexeme <*> (";" *> hspace *> eol *> parseBlockComment), - (directiveName "video" <|> directiveName "video") $> DirectiveVideo + (directiveName "video" <|> directiveName "video") + $> DirectiveVideo <*> parseExp postlexeme - <*> parseVideoParams <* eol + <*> parseVideoParams + <* eol ] directiveName s = try $ token (":" <> s) @@ -437,7 +454,8 @@ pure $ T.pack stdout_t Right (ExitFailure code', _, stderr_t) -> throwError $ - prog' <> " failed with exit code " + prog' + <> " failed with exit code " <> T.pack (show code') <> " and stderr:\n" <> T.pack stderr_t @@ -594,10 +612,14 @@ 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 + liftIO $ + T.hPutStrLn stderr $ + "Using existing file: " <> T.pack fname unless exists $ do when (scriptVerbose (envOpts env) > 0) $ - liftIO $ T.hPutStrLn stderr $ "Generating new file: " <> T.pack fname + liftIO $ + T.hPutStrLn stderr $ + "Generating new file: " <> T.pack fname m fname modify $ \s -> s {stateFiles = S.insert fname $ stateFiles s} pure (fname, fname_rel) @@ -718,7 +740,8 @@ -- processDirective env (DirectiveVideo e params) = do when (format `notElem` ["webm", "gif"]) $ - throwError $ "Unknown video format: " <> format + throwError $ + "Unknown video format: " <> format let file = (videoFile params, "video" <.> T.unpack format) fmap (videoBlock params) . newFile env file $ \videofile -> do @@ -737,7 +760,6 @@ onWebM videofile =<< bmpsToVideo dir ValueTuple [stepfun, initial, num_frames] | ValueAtom (SFun stepfun' _ [_, _] closure) <- stepfun, - ValueAtom (SValue _ _) <- initial, ValueAtom (SValue "i64" _) <- num_frames -> do Just (ValueAtom num_frames') <- mapM getValue <$> getExpValue (envServer env) num_frames @@ -878,7 +900,8 @@ | otherwise = throwError e toRemove f = do when (scriptVerbose (envOpts env) > 0) $ - T.hPutStrLn stderr $ "Deleting unused file: " <> T.pack f + T.hPutStrLn stderr $ + "Deleting unused file: " <> T.pack f removePathForcibly f processScript :: Env -> [Block] -> IO (Failure, T.Text) @@ -962,13 +985,16 @@ unless (scriptSkipCompilation opts) $ do let entryOpt v = "--entry-point=" ++ T.unpack v compile_options = - "--server" : - map entryOpt (S.toList (varsInScripts script)) + "--server" + : map entryOpt (S.toList (varsInScripts script)) ++ scriptCompilerOptions opts when (scriptVerbose opts > 0) $ - T.hPutStrLn stderr $ "Compiling " <> T.pack prog <> "..." + T.hPutStrLn stderr $ + "Compiling " <> T.pack prog <> "..." when (scriptVerbose opts > 1) $ - T.hPutStrLn stderr $ T.pack $ unwords compile_options + T.hPutStrLn stderr $ + T.pack $ + unwords compile_options let onError err = do mapM_ (T.hPutStrLn stderr) err diff --git a/src/Futhark/CLI/Main.hs b/src/Futhark/CLI/Main.hs --- a/src/Futhark/CLI/Main.hs +++ b/src/Futhark/CLI/Main.hs @@ -22,6 +22,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.MulticoreISPC as MulticoreISPC import qualified Futhark.CLI.MulticoreWASM as MulticoreWASM import qualified Futhark.CLI.OpenCL as OpenCL import qualified Futhark.CLI.Pkg as Pkg @@ -59,6 +60,7 @@ ("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")), + ("ispc", (MulticoreISPC.main, "Compile to multicore ISPC")), ("test", (Test.main, "Test Futhark programs.")), ("bench", (Bench.main, "Benchmark Futhark programs.")), ("dataset", (Dataset.main, "Generate random test data.")), @@ -75,7 +77,8 @@ ("query", (Query.main, "Query semantic information about program.")), ("literate", (Literate.main, "Process a literate Futhark program.")), ("lsp", (LSP.main, "Run LSP server.")), - ("thanks", (Misc.mainThanks, "Express gratitude.")) + ("thanks", (Misc.mainThanks, "Express gratitude.")), + ("tokens", (Misc.mainTokens, "Express gratitude.")) ] msg :: String @@ -131,6 +134,7 @@ exitWith $ ExitFailure 1 | otherwise = throw e +-- | The @futhark@ executable. main :: IO () main = reportingIOErrors $ do hSetEncoding stdout utf8 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 @@ -7,6 +7,7 @@ mainDataget, mainCheckSyntax, mainThanks, + mainTokens, ) where @@ -14,12 +15,14 @@ import qualified Data.ByteString.Lazy as BS import Data.Function (on) import Data.List (isInfixOf, nubBy) +import Data.Loc (L (..), startPos) import qualified Data.Text.IO as T import Futhark.Compiler import Futhark.Test -import Futhark.Util (hashText) +import Futhark.Util (hashText, interactWithFileSafely) import Futhark.Util.Options import Futhark.Util.Pretty (prettyTextOneLine) +import Language.Futhark.Parser.Lexer (scanTokens) import Language.Futhark.Prop (isBuiltin) import System.Environment (getExecutablePath) import System.Exit @@ -105,3 +108,26 @@ "Likewise!", "And thank you in return for trying the language!" ] + +-- | @futhark tokens@ +mainTokens :: String -> [String] -> IO () +mainTokens = mainWithOptions () [] "program" $ \args () -> + case args of + [file] -> Just $ do + res <- interactWithFileSafely (scanTokens (startPos file) <$> BS.readFile file) + case res of + Nothing -> do + hPutStrLn stderr $ file <> ": file not found." + exitWith $ ExitFailure 2 + Just (Left e) -> do + hPrint stderr e + exitWith $ ExitFailure 2 + Just (Right (Left e)) -> do + hPrint stderr e + exitWith $ ExitFailure 2 + Just (Right (Right (tokens, _))) -> + mapM_ printToken tokens + _ -> Nothing + where + printToken (L _ token) = + print token diff --git a/src/Futhark/CLI/MulticoreISPC.hs b/src/Futhark/CLI/MulticoreISPC.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/MulticoreISPC.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | @futhark multicore@ +module Futhark.CLI.MulticoreISPC (main) where + +import Futhark.Actions (compileMulticoreToISPCAction) +import Futhark.Compiler.CLI +import Futhark.Passes (multicorePipeline) + +-- | Run @futhark multicore@. +main :: String -> [String] -> IO () +main = compilerMain + () + [] + "Compile to multicore ISPC" + "Generate multicore ISPC code from optimised Futhark program." + multicorePipeline + $ \fcfg () mode outpath prog -> + actionProcedure (compileMulticoreToISPCAction fcfg mode outpath) prog diff --git a/src/Futhark/CLI/Pkg.hs b/src/Futhark/CLI/Pkg.hs --- a/src/Futhark/CLI/Pkg.hs +++ b/src/Futhark/CLI/Pkg.hs @@ -49,7 +49,9 @@ -- matter the host OS. when (".." `elem` Posix.splitPath (Zip.eRelativePath entry)) $ fail $ - "Zip archive for " <> pdir <> " contains suspicious path: " + "Zip archive for " + <> pdir + <> " contains suspicious path: " <> Zip.eRelativePath entry let f = pdir makeRelative from_dir (Zip.eRelativePath entry) createDirectoryIfMissing True $ takeDirectory f @@ -68,7 +70,9 @@ -- package files. let noPkgDir = fail $ - "futhark.pkg for " ++ T.unpack p ++ "-" + "futhark.pkg for " + ++ T.unpack p + ++ "-" ++ T.unpack (prettySemVer v) ++ " does not define a package path." from_dir <- maybe noPkgDir (pure . (pkgRevZipballDir info <>)) $ pkgDir m @@ -89,7 +93,8 @@ when (null written) $ fail $ - "Zip archive for package " ++ T.unpack p + "Zip archive for package " + ++ T.unpack p ++ " does not contain any files in " ++ from_dir @@ -311,7 +316,9 @@ | otherwise -> liftIO $ T.putStrLn $ - "Replaced " <> p <> " " + "Replaced " + <> p + <> " " <> prettySemVer (requiredPkgRev prev_r') <> " => " <> prettySemVer v @@ -385,7 +392,9 @@ when (v /= requiredPkgRev req) $ liftIO $ T.putStrLn $ - "Upgraded " <> requiredPkg req <> " " + "Upgraded " + <> requiredPkg req + <> " " <> prettySemVer (requiredPkgRev req) <> " => " <> prettySemVer v 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 @@ -409,7 +409,8 @@ typeCommand :: Command typeCommand = genTypeCommand parseExp T.checkExp $ \(ps, e) -> - pretty e <> concatMap ((" " <>) . pretty) ps + pretty e + <> concatMap ((" " <>) . pretty) ps <> " : " <> pretty (typeOf e) 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 @@ -122,7 +122,9 @@ pure (externalErrorS (show err)) ) when (interpreterPrintWarnings cfg) $ - liftIO $ hPutStr stderr $ pretty ws + liftIO $ + hPutStr stderr $ + pretty ws let imp = T.mkInitialImport "." ienv1 <- @@ -137,7 +139,9 @@ badOnLeft pretty $ snd $ T.checkDec imports src' tenv1 imp $ - mkOpen $ toPOSIX $ dropExtension file + mkOpen $ + toPOSIX $ + dropExtension file ienv2 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv1 d1) ienv3 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv2 d2) pure (tenv2, ienv3) 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 @@ -97,7 +97,9 @@ "Running " <> T.pack (unwords $ binpath : extra_options) context prog_ctx $ - pureTestResults $ liftIO $ withServer (futharkServerCfg to_run to_run_args) f + pureTestResults $ + liftIO $ + withServer (futharkServerCfg to_run to_run_args) f data TestMode = -- | Only type check. @@ -175,12 +177,18 @@ Nothing | expected_occurences > 0 -> throwError $ - name <> maybePipeline pipeline <> " should have occurred " <> T.pack (show expected_occurences) + name + <> maybePipeline pipeline + <> " should have occurred " + <> T.pack (show expected_occurences) <> " times, but did not occur at all in optimised program." Just actual_occurences | expected_occurences /= actual_occurences -> throwError $ - name <> maybePipeline pipeline <> " should have occurred " <> T.pack (show expected_occurences) + name + <> maybePipeline pipeline + <> " should have occurred " + <> T.pack (show expected_occurences) <> " times, but occurred " <> T.pack (show actual_occurences) <> " times." @@ -192,7 +200,8 @@ testWarning (ExpectedWarning regex_s regex) | not (match regex $ T.unpack $ T.decodeUtf8 futerr) = throwError $ - "Expected warning:\n " <> regex_s + "Expected warning:\n " + <> regex_s <> "\nGot warnings:\n " <> T.decodeUtf8 futerr | otherwise = pure () @@ -278,7 +287,8 @@ when (mode == Interpreted) $ context "Interpreting" $ - accErrors_ $ map (runInterpretedEntry (FutharkExe futhark) program) ios + accErrors_ $ + map (runInterpretedEntry (FutharkExe futhark) program) ios liftCommand :: (MonadError T.Text m, MonadIO m) => @@ -308,7 +318,9 @@ runCompiledCase input_types outs ins run = runExceptT $ do let TestRun _ input_spec _ index _ = run case_ctx = - "Entry point: " <> entry <> "; dataset: " + "Entry point: " + <> entry + <> "; dataset: " <> T.pack (runDescription run) context1 case_ctx $ do @@ -325,7 +337,7 @@ Right _ -> SuccessResult <$> readResults server outs - <* liftCommand (cmdFree server outs) + <* liftCommand (cmdFree server outs) compareResult entry index program expected res @@ -333,7 +345,8 @@ checkError (ThisError regex_s regex) err | not (match regex $ T.unpack err) = E.throwError $ - "Expected error:\n " <> regex_s + "Expected error:\n " + <> regex_s <> "\nGot error:\n" <> T.unlines (map (" " <>) (T.lines err)) checkError _ _ = @@ -487,7 +500,9 @@ reportText :: TestStatus -> IO () reportText ts = putStr $ - "(" ++ show (testStatusFail ts) ++ " failed, " + "(" + ++ show (testStatusFail ts) + ++ " failed, " ++ show (testStatusPass ts) ++ " passed, " ++ show num_remain @@ -539,7 +554,8 @@ case msg of TestStarted test -> do unless fancy $ - putStr $ "Started testing " <> testCaseProgram test <> " " + putStr $ + "Started testing " <> testCaseProgram test <> " " getResults $ ts {testStatusRun = test : testStatusRun ts} TestDone test res -> do let ts' = @@ -558,7 +574,8 @@ testStatusRunPass ts' + numTestCases test } unless fancy $ - putStr $ "Finished testing " <> testCaseProgram test <> " " + putStr $ + "Finished testing " <> testCaseProgram test <> " " getResults $ ts'' {testStatusPass = testStatusPass ts + 1} Failure s -> do when fancy moveCursorToTableTop @@ -570,7 +587,8 @@ { testStatusFail = testStatusFail ts' + 1, testStatusRunPass = testStatusRunPass ts' - + numTestCases test - length s, + + numTestCases test + - length s, testStatusRunFail = testStatusRunFail ts' + length s @@ -766,8 +784,8 @@ excludeBackend config = config { configExclude = - "no_" <> T.pack (configBackend (configPrograms config)) : - configExclude config + "no_" <> T.pack (configBackend (configPrograms config)) + : configExclude config } -- | Run @futhark test@. 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 @@ -59,7 +59,7 @@ operations extra cuda_includes - [Space "device", DefaultSpace] + (Space "device", [Space "device", DefaultSpace]) cliOptions prog' where @@ -213,26 +213,28 @@ error $ "Cannot deallocate in '" ++ space ++ "' memory space." copyCUDAMemory :: GC.Copy OpenCL () -copyCUDAMemory dstmem dstidx dstSpace srcmem srcidx srcSpace nbytes = do - let (fn, prof) = memcpyFun dstSpace srcSpace +copyCUDAMemory b dstmem dstidx dstSpace srcmem srcidx srcSpace nbytes = do + let (copy, prof) = memcpyFun b dstSpace srcSpace (bef, aft) = profilingEnclosure prof GC.item - [C.citem|{ - $items:bef - CUDA_SUCCEED_OR_RETURN( - $id:fn($exp:dstmem + $exp:dstidx, - $exp:srcmem + $exp:srcidx, - $exp:nbytes)); - $items:aft - } - |] + [C.citem|{$items:bef CUDA_SUCCEED_OR_RETURN($exp:copy); $items:aft}|] where - memcpyFun DefaultSpace (Space "device") = ("cuMemcpyDtoH" :: String, copyDevToHost) - memcpyFun (Space "device") DefaultSpace = ("cuMemcpyHtoD", copyHostToDev) - memcpyFun (Space "device") (Space "device") = ("cuMemcpy", copyDevToDev) - memcpyFun _ _ = + dst = [C.cexp|$exp:dstmem + $exp:dstidx|] + src = [C.cexp|$exp:srcmem + $exp:srcidx|] + memcpyFun GC.CopyBarrier DefaultSpace (Space "device") = + ([C.cexp|cuMemcpyDtoH($exp:dst, $exp:src, $exp:nbytes)|], copyDevToHost) + memcpyFun GC.CopyBarrier (Space "device") DefaultSpace = + ([C.cexp|cuMemcpyHtoD($exp:dst, $exp:src, $exp:nbytes)|], copyHostToDev) + memcpyFun _ (Space "device") (Space "device") = + ([C.cexp|cuMemcpy($exp:dst, $exp:src, $exp:nbytes)|], copyDevToDev) + memcpyFun GC.CopyNoBarrier DefaultSpace (Space "device") = + ([C.cexp|cuMemcpyDtoHAsync($exp:dst, $exp:src, $exp:nbytes, 0)|], copyDevToHost) + memcpyFun GC.CopyNoBarrier (Space "device") DefaultSpace = + ([C.cexp|cuMemcpyHtoDAsync($exp:dst, $exp:src, $exp:nbytes, 0)|], copyHostToDev) + memcpyFun _ _ _ = error $ - "Cannot copy to '" ++ show dstSpace + "Cannot copy to '" + ++ show dstSpace ++ "' from '" ++ show srcSpace ++ "'." @@ -270,7 +272,8 @@ GC.item [C.citem|struct memblock_device $id:name = ctx->$id:name;|] staticCUDAArray _ space _ _ = error $ - "CUDA backend cannot create static array in '" ++ space + "CUDA backend cannot create static array in '" + ++ space ++ "' memory space" cudaMemoryType :: GC.MemoryType OpenCL () 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 @@ -317,8 +317,8 @@ &ctx->$id:name, ctx->cuda.module, $string:(pretty (C.toIdent name mempty))));|] - ) : - forCostCentre name + ) + : forCostCentre name (kernel_fields, init_kernel_fields) = unzip $ 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 @@ -68,7 +68,7 @@ failures ) include_opencl_h - [Space "device", DefaultSpace] + (Space "device", [Space "device", DefaultSpace]) cliOptions prog' where @@ -226,36 +226,42 @@ deallocateOpenCLBuffer _ _ space = error $ "Cannot deallocate in '" ++ space ++ "' space" +syncArg :: GC.CopyBarrier -> C.Exp +syncArg GC.CopyBarrier = [C.cexp|CL_TRUE|] +syncArg GC.CopyNoBarrier = [C.cexp|CL_FALSE|] + copyOpenCLMemory :: GC.Copy OpenCL () -- The read/write/copy-buffer functions fail if the given offset is -- out of bounds, even if asked to read zero bytes. We protect with a -- branch to avoid this. -copyOpenCLMemory destmem destidx DefaultSpace srcmem srcidx (Space "device") nbytes = +copyOpenCLMemory b destmem destidx DefaultSpace srcmem srcidx (Space "device") nbytes = GC.stm [C.cstm| if ($exp:nbytes > 0) { + typename cl_bool sync_call = $exp:(syncArg b); OPENCL_SUCCEED_OR_RETURN( clEnqueueReadBuffer(ctx->opencl.queue, $exp:srcmem, - ctx->failure_is_an_option ? CL_FALSE : CL_TRUE, + ctx->failure_is_an_option ? CL_FALSE : sync_call, (size_t)$exp:srcidx, (size_t)$exp:nbytes, $exp:destmem + $exp:destidx, 0, NULL, $exp:(profilingEvent copyHostToDev))); - if (ctx->failure_is_an_option && + if (sync_call && + ctx->failure_is_an_option && futhark_context_sync(ctx) != 0) { return 1; } } |] -copyOpenCLMemory destmem destidx (Space "device") srcmem srcidx DefaultSpace nbytes = +copyOpenCLMemory b destmem destidx (Space "device") srcmem srcidx DefaultSpace nbytes = GC.stm [C.cstm| if ($exp:nbytes > 0) { OPENCL_SUCCEED_OR_RETURN( - clEnqueueWriteBuffer(ctx->opencl.queue, $exp:destmem, CL_TRUE, + clEnqueueWriteBuffer(ctx->opencl.queue, $exp:destmem, $exp:(syncArg b), (size_t)$exp:destidx, (size_t)$exp:nbytes, $exp:srcmem + $exp:srcidx, 0, NULL, $exp:(profilingEvent copyDevToHost))); } |] -copyOpenCLMemory destmem destidx (Space "device") srcmem srcidx (Space "device") nbytes = +copyOpenCLMemory _ destmem destidx (Space "device") srcmem srcidx (Space "device") nbytes = -- Be aware that OpenCL swaps the usual order of operands for -- memcpy()-like functions. The order below is not a typo. GC.stm @@ -272,9 +278,9 @@ } } }|] -copyOpenCLMemory destmem destidx DefaultSpace srcmem srcidx DefaultSpace nbytes = +copyOpenCLMemory _ destmem destidx DefaultSpace srcmem srcidx DefaultSpace nbytes = GC.copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes -copyOpenCLMemory _ _ destspace _ _ srcspace _ = +copyOpenCLMemory _ _ _ destspace _ _ srcspace _ = error $ "Cannot copy to " ++ show destspace ++ " from " ++ show srcspace openclMemoryType :: GC.MemoryType OpenCL () @@ -443,8 +449,8 @@ ++ " 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] + [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|]] ) 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 @@ -8,6 +8,7 @@ -- | C code generator framework. module Futhark.CodeGen.Backends.GenericC ( compileProg, + compileProg', CParts (..), asLibrary, asExecutable, @@ -27,12 +28,14 @@ readScalarPointerWithQuals, Allocate, Deallocate, + CopyBarrier (..), Copy, StaticArray, -- * Monadic compiler interface CompilerM, - CompilerState (compUserState, compNameSrc), + CompilerState (compUserState, compNameSrc, compDeclaredMem), + CompilerEnv (envCachedMem), getUserState, modifyUserState, contextContents, @@ -77,6 +80,12 @@ primTypeToCType, intTypeToCType, copyMemoryDefaultSpace, + linearCode, + derefPointer, + fatMemAlloc, + fatMemSet, + fatMemUnRef, + errorMsgString, ) where @@ -84,7 +93,7 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor (first) -import Data.Char (isAlpha, isAlphaNum) +import Data.Char (isAlpha, isAlphaNum, isDigit) import qualified Data.DList as DL import Data.List (unzip4) import Data.Loc @@ -100,7 +109,7 @@ import Futhark.IR.Prop (isBuiltInFunction) import qualified Futhark.Manifest as Manifest import Futhark.MonadFreshNames -import Futhark.Util (zEncodeString) +import Futhark.Util (chunks, mapAccumLM, zEncodeString) import Futhark.Util.Pretty (prettyText) import qualified Language.C.Quote.OpenCL as C import qualified Language.C.Syntax as C @@ -112,11 +121,10 @@ data Publicness = Private | Public deriving (Eq, Ord, Show) -type ArrayType = (Space, Signedness, PrimType, Int) +type ArrayType = (Signedness, PrimType, Int) data CompilerState s = CompilerState { compArrayTypes :: M.Map ArrayType Publicness, - compOpaqueTypes :: M.Map String [ValueDesc], compEarlyDecls :: DL.DList C.Definition, compInit :: [C.Stm], compNameSrc :: VNameSource, @@ -134,7 +142,6 @@ newCompilerState src s = CompilerState { compArrayTypes = mempty, - compOpaqueTypes = mempty, compEarlyDecls = mempty, compInit = [], compNameSrc = src, @@ -152,6 +159,7 @@ -- to ensure that the header file remains structured and readable. data HeaderSection = ArrayDecl String + | OpaqueTypeDecl String | OpaqueDecl String | EntryDecl | MiscDecl @@ -198,8 +206,20 @@ -- | Create a static array of values - initialised at load time. type StaticArray op s = VName -> SpaceId -> PrimType -> ArrayContents -> CompilerM op s () +-- | Whether a copying operation should implicitly function as a +-- barrier regarding further operations on the source. This is a +-- rather subtle detail and is mostly useful for letting some +-- device/GPU copies be asynchronous (#1664). +data CopyBarrier + = CopyBarrier + | -- | Explicit context synchronisation should be done + -- before the source or target is used. + CopyNoBarrier + deriving (Eq, Show) + -- | Copy from one memory block to another. type Copy op s = + CopyBarrier -> C.Exp -> C.Exp -> Space -> @@ -264,7 +284,8 @@ (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|if (ctx->error == NULL) + ctx->error = msgprintf($string:formatstr', $args:formatargs, $string:stacktrace); err = FUTHARK_PROGRAM_ERROR; goto cleanup;|] @@ -309,9 +330,9 @@ error "Cannot allocate in non-default memory space" defDeallocate _ _ = error "Cannot deallocate in non-default memory space" - defCopy destmem destoffset DefaultSpace srcmem srcoffset DefaultSpace size = + defCopy _ destmem destoffset DefaultSpace srcmem srcoffset DefaultSpace size = copyMemoryDefaultSpace destmem destoffset srcmem srcoffset size - defCopy _ _ _ _ _ _ _ = + defCopy _ _ _ _ _ _ _ _ = error "Cannot copy to or from non-default memory space" defStaticArray _ _ _ _ = error "Cannot create static array in non-default memory space" @@ -367,12 +388,16 @@ . M.toList . compHeaderDecls -initDecls, arrayDecls, opaqueDecls, entryDecls, miscDecls :: CompilerState s -> T.Text +initDecls, arrayDecls, opaqueDecls, opaqueTypeDecls, entryDecls, miscDecls :: CompilerState s -> T.Text initDecls = declsCode (== InitDecl) arrayDecls = declsCode isArrayDecl where isArrayDecl ArrayDecl {} = True isArrayDecl _ = False +opaqueTypeDecls = declsCode isOpaqueTypeDecl + where + isOpaqueTypeDecl OpaqueTypeDecl {} = True + isOpaqueTypeDecl _ = False opaqueDecls = declsCode isOpaqueDecl where isOpaqueDecl OpaqueDecl {} = True @@ -613,7 +638,8 @@ allocRawMem dest size space desc = case space of Space sid -> join $ - asks envAllocate <*> pure [C.cexp|$exp:dest|] + asks envAllocate + <*> pure [C.cexp|$exp:dest|] <*> pure [C.cexp|$exp:size|] <*> pure [C.cexp|$exp:desc|] <*> pure sid @@ -651,7 +677,7 @@ free <- collect $ freeRawMem [C.cexp|block->mem|] space [C.cexp|desc|] ctx_ty <- contextType let unrefdef = - [C.cedecl|static int $id:(fatMemUnRef space) ($ty:ctx_ty *ctx, $ty:mty *block, const char *desc) { + [C.cedecl|int $id:(fatMemUnRef space) ($ty:ctx_ty *ctx, $ty:mty *block, const char *desc) { if (block->references != NULL) { *(block->references) -= 1; if (ctx->detail_memory) { @@ -677,7 +703,7 @@ collect $ allocRawMem [C.cexp|block->mem|] [C.cexp|size|] space [C.cexp|desc|] let allocdef = - [C.cedecl|static int $id:(fatMemAlloc space) ($ty:ctx_ty *ctx, $ty:mty *block, typename int64_t size, const char *desc) { + [C.cedecl|int $id:(fatMemAlloc space) ($ty:ctx_ty *ctx, $ty:mty *block, typename int64_t size, const char *desc) { if (size < 0) { futhark_panic(1, "Negative allocation of %lld bytes attempted for %s in %s.\n", (long long)size, desc, $string:spacedesc, ctx->$id:usagename); @@ -731,7 +757,7 @@ -- Memory setting - unreference the destination and increase the -- count of the source by one. let setdef = - [C.cedecl|static int $id:(fatMemSet space) ($ty:ctx_ty *ctx, $ty:mty *lhs, $ty:mty *rhs, const char *lhs_desc) { + [C.cedecl|int $id:(fatMemSet space) ($ty:ctx_ty *ctx, $ty:mty *lhs, $ty:mty *rhs, const char *lhs_desc) { int ret = $id:(fatMemUnRef space)(ctx, lhs, lhs_desc); if (rhs->references != NULL) { (*(rhs->references))++; @@ -915,6 +941,7 @@ new_body <- collect $ do prepare_new copy + CopyNoBarrier [C.cexp|arr->mem.mem|] [C.cexp|0|] space @@ -926,6 +953,7 @@ new_raw_body <- collect $ do prepare_new copy + CopyNoBarrier [C.cexp|arr->mem.mem|] [C.cexp|0|] space @@ -939,6 +967,7 @@ values_body <- collect $ copy + CopyNoBarrier [C.cexp|data|] [C.cexp|0|] DefaultSpace @@ -1023,23 +1052,216 @@ Manifest.arrayNew = T.pack new_array } +lookupOpaqueType :: String -> OpaqueTypes -> OpaqueType +lookupOpaqueType v (OpaqueTypes types) = + case lookup v types of + Just t -> t + Nothing -> error $ "Unknown opaque type: " ++ show v + +opaquePayload :: OpaqueTypes -> OpaqueType -> [ValueType] +opaquePayload _ (OpaqueType ts) = ts +opaquePayload types (OpaqueRecord fs) = concatMap f fs + where + f (_, TypeOpaque s) = opaquePayload types $ lookupOpaqueType s types + f (_, TypeTransparent v) = [v] + +opaqueToCType :: String -> CompilerM op s C.Type +opaqueToCType desc = do + name <- publicName $ opaqueName desc + pure [C.cty|struct $id:name|] + +valueTypeToCType :: Publicness -> ValueType -> CompilerM op s C.Type +valueTypeToCType _ (ValueType signed (Rank 0) pt) = + pure $ primAPIType signed pt +valueTypeToCType pub (ValueType signed (Rank rank) pt) = do + name <- publicName $ arrayName pt signed rank + let add = M.insertWith max (signed, pt, rank) pub + modify $ \s -> s {compArrayTypes = add $ compArrayTypes s} + pure [C.cty|struct $id:name|] + +entryPointTypeToCType :: Publicness -> EntryPointType -> CompilerM op s C.Type +entryPointTypeToCType _ (TypeOpaque desc) = opaqueToCType desc +entryPointTypeToCType pub (TypeTransparent vt) = valueTypeToCType pub vt + +entryTypeName :: EntryPointType -> Manifest.TypeName +entryTypeName (TypeOpaque desc) = T.pack desc +entryTypeName (TypeTransparent vt) = prettyText vt + +-- | Figure out which of the members of an opaque type corresponds to +-- which fields. +recordFieldPayloads :: OpaqueTypes -> [EntryPointType] -> [a] -> [[a]] +recordFieldPayloads types = chunks . map typeLength + where + typeLength (TypeTransparent _) = 1 + typeLength (TypeOpaque desc) = + length $ opaquePayload types $ lookupOpaqueType desc types + +opaqueProjectFunctions :: + OpaqueTypes -> + String -> + [(Name, EntryPointType)] -> + [ValueType] -> + CompilerM op s [Manifest.RecordField] +opaqueProjectFunctions types desc fs vds = do + opaque_type <- opaqueToCType desc + ctx_ty <- contextType + ops <- asks envOperations + let mkProject (TypeTransparent (ValueType sign (Rank 0) pt)) [(i, _)] = do + pure + ( primAPIType sign pt, + [C.citems|v = obj->$id:(tupleField i);|] + ) + mkProject (TypeTransparent vt) [(i, _)] = do + ct <- valueTypeToCType Public vt + pure + ( [C.cty|$ty:ct *|], + criticalSection + ops + [C.citems|v = malloc(sizeof($ty:ct)); + memcpy(v, obj->$id:(tupleField i), sizeof($ty:ct)); + (void)(*(v->mem.references))++;|] + ) + mkProject (TypeTransparent _) rep = + error $ "mkProject: invalid representation of transparent type: " ++ show rep + mkProject (TypeOpaque f_desc) components = do + ct <- opaqueToCType f_desc + let setField j (i, ValueType _ (Rank r) _) = + if r == 0 + then [C.citems|v->$id:(tupleField j) = obj->$id:(tupleField i);|] + else + [C.citems|v->$id:(tupleField j) = malloc(sizeof(*v->$id:(tupleField j))); + *v->$id:(tupleField j) = *obj->$id:(tupleField i); + (void)(*(v->$id:(tupleField j)->mem.references))++;|] + pure + ( [C.cty|$ty:ct *|], + criticalSection + ops + [C.citems|v = malloc(sizeof($ty:ct)); + $items:(concat (zipWith setField [0..] components))|] + ) + let onField ((f, et), elems) = do + project <- publicName $ "project_" ++ opaqueName desc ++ "_" ++ nameToString f + (et_ty, project_items) <- mkProject et elems + headerDecl + (OpaqueDecl desc) + [C.cedecl|int $id:project($ty:ctx_ty *ctx, $ty:et_ty *out, const $ty:opaque_type *obj);|] + libDecl + [C.cedecl|int $id:project($ty:ctx_ty *ctx, $ty:et_ty *out, const $ty:opaque_type *obj) { + (void)ctx; + $ty:et_ty v; + $items:project_items + *out = v; + return 0; + }|] + pure $ Manifest.RecordField (nameToText f) (entryTypeName et) (T.pack project) + + mapM onField . zip fs . recordFieldPayloads types (map snd fs) $ + zip [0 ..] vds + +opaqueNewFunctions :: + OpaqueTypes -> + String -> + [(Name, EntryPointType)] -> + [ValueType] -> + CompilerM op s Manifest.CFuncName +opaqueNewFunctions types desc fs vds = do + opaque_type <- opaqueToCType desc + ctx_ty <- contextType + ops <- asks envOperations + new <- publicName $ "new_" ++ opaqueName desc + + (params, new_stms) <- + fmap (unzip . snd) + . mapAccumLM onField 0 + . zip fs + . recordFieldPayloads types (map snd fs) + $ vds + + headerDecl + (OpaqueDecl desc) + [C.cedecl|int $id:new($ty:ctx_ty *ctx, $ty:opaque_type** out, $params:params);|] + libDecl + [C.cedecl|int $id:new($ty:ctx_ty *ctx, $ty:opaque_type** out, $params:params) { + $ty:opaque_type* v = malloc(sizeof($ty:opaque_type)); + $items:(criticalSection ops new_stms) + *out = v; + return 0; + }|] + pure $ T.pack new + where + onField offset ((f, et), f_vts) = do + let param_name = + if all isDigit (nameToString f) + then C.toIdent ("v" <> f) mempty + else C.toIdent f mempty + case et of + TypeTransparent (ValueType sign (Rank 0) pt) -> do + let ct = primAPIType sign pt + pure + ( offset + 1, + ( [C.cparam|const $ty:ct $id:param_name|], + [C.citem|v->$id:(tupleField offset) = $id:param_name;|] + ) + ) + TypeTransparent vt -> do + ct <- valueTypeToCType Public vt + pure + ( offset + 1, + ( [C.cparam|const $ty:ct* $id:param_name|], + [C.citem|{v->$id:(tupleField offset) = malloc(sizeof($ty:ct)); + *v->$id:(tupleField offset) = *$id:param_name; + (void)(*(v->$id:(tupleField offset)->mem.references))++;}|] + ) + ) + TypeOpaque f_desc -> do + ct <- opaqueToCType f_desc + let param_fields = do + i <- [0 ..] + pure [C.cexp|$id:param_name->$id:(tupleField i)|] + pure + ( offset + length f_vts, + ( [C.cparam|const $ty:ct* $id:param_name|], + [C.citem|{$stms:(zipWith3 setFieldField [offset ..] param_fields f_vts)}|] + ) + ) + + setFieldField i e (ValueType _ (Rank r) _) + | r == 0 = + [C.cstm|v->$id:(tupleField i) = $exp:e;|] + | otherwise = + [C.cstm|{v->$id:(tupleField i) = malloc(sizeof(*$exp:e)); + *v->$id:(tupleField i) = *$exp:e; + (void)(*(v->$id:(tupleField i)->mem.references))++;}|] + +processOpaqueRecord :: + OpaqueTypes -> + String -> + OpaqueType -> + [ValueType] -> + CompilerM op s (Maybe Manifest.RecordOps) +processOpaqueRecord _ _ (OpaqueType _) _ = pure Nothing +processOpaqueRecord types desc (OpaqueRecord fs) vds = + Just + <$> ( Manifest.RecordOps + <$> opaqueProjectFunctions types desc fs vds + <*> opaqueNewFunctions types desc fs vds + ) + opaqueLibraryFunctions :: + OpaqueTypes -> String -> - [ValueDesc] -> - CompilerM op s Manifest.OpaqueOps -opaqueLibraryFunctions desc vds = do - name <- publicName $ opaqueName desc vds - free_opaque <- publicName $ "free_" ++ opaqueName desc vds - store_opaque <- publicName $ "store_" ++ opaqueName desc vds - restore_opaque <- publicName $ "restore_" ++ opaqueName desc vds + OpaqueType -> + CompilerM op s (Manifest.OpaqueOps, Maybe Manifest.RecordOps) +opaqueLibraryFunctions types desc ot = do + name <- publicName $ opaqueName desc + free_opaque <- publicName $ "free_" ++ opaqueName desc + store_opaque <- publicName $ "store_" ++ opaqueName desc + restore_opaque <- publicName $ "restore_" ++ opaqueName desc let opaque_type = [C.cty|struct $id:name|] - freeComponent _ ScalarValue {} = - pure () - freeComponent i (ArrayValue _ _ pt signed shape) = do - let rank = length shape - field = tupleField i + freeComponent i (ValueType signed (Rank rank) pt) = unless (rank == 0) $ do + let field = tupleField i free_array <- publicName $ "free_" ++ arrayName pt signed rank -- Protect against NULL here, because we also want to use this -- to free partially loaded opaques. @@ -1048,16 +1270,15 @@ ret = tmp; }|] - storeComponent i (ScalarValue pt sign _) = + storeComponent i (ValueType sign (Rank 0) pt) = let field = tupleField i in ( storageSize pt 0 [C.cexp|NULL|], storeValueHeader sign pt 0 [C.cexp|NULL|] [C.cexp|out|] ++ [C.cstms|memcpy(out, &obj->$id:field, sizeof(obj->$id:field)); out += sizeof(obj->$id:field);|] ) - storeComponent i (ArrayValue _ _ pt sign shape) = - let rank = length shape - arr_name = arrayName pt sign rank + storeComponent i (ValueType sign (Rank rank) pt) = + let arr_name = arrayName pt sign rank field = tupleField i shape_array = "futhark_shape_" ++ arr_name values_array = "futhark_values_" ++ arr_name @@ -1071,6 +1292,7 @@ ctx_ty <- contextType + let vds = opaquePayload types ot free_body <- collect $ zipWithM_ freeComponent [0 ..] vds store_body <- collect $ do @@ -1083,16 +1305,15 @@ stm [C.cstm|if (p != NULL && *p == NULL) { *p = malloc(*n); }|] stm [C.cstm|if (p != NULL) { unsigned char *out = *p; $stms:(concat stores) }|] - let restoreComponent i (ScalarValue pt sign _) = do + let restoreComponent i (ValueType sign (Rank 0) pt) = do let field = tupleField i dataptr = "data_" ++ show i stms $ loadValueHeader sign pt 0 [C.cexp|NULL|] [C.cexp|src|] item [C.citem|const void* $id:dataptr = src;|] stm [C.cstm|src += sizeof(obj->$id:field);|] pure [C.cstms|memcpy(&obj->$id:field, $id:dataptr, sizeof(obj->$id:field));|] - restoreComponent i (ArrayValue _ _ pt sign shape) = do + restoreComponent i (ValueType sign (Rank rank) pt) = do let field = tupleField i - rank = length shape arr_name = arrayName pt sign rank new_array = "futhark_new_" ++ arr_name dataptr = "data_" ++ show i @@ -1110,14 +1331,14 @@ if (obj->$id:field == NULL) { err = 1; }|] load_body <- collect $ do - loads <- concat <$> zipWithM restoreComponent [0 ..] vds + loads <- concat <$> zipWithM restoreComponent [0 ..] (opaquePayload types ot) stm [C.cstm|if (err == 0) { $stms:loads }|] headerDecl - (OpaqueDecl desc) + (OpaqueTypeDecl desc) [C.cedecl|struct $id:name;|] headerDecl (OpaqueDecl desc) @@ -1129,13 +1350,17 @@ (OpaqueDecl desc) [C.cedecl|$ty:opaque_type* $id:restore_opaque($ty:ctx_ty *ctx, const void *p);|] - -- We do not need to enclose the body in a critical section, because - -- when we operate on the components of the opaque, we are calling - -- public API functions that do their own locking. + record <- processOpaqueRecord types desc ot vds + + -- We do not need to enclose most bodies in a critical section, + -- because when we operate on the components of the opaque, we are + -- calling public API functions that do their own locking. The + -- exception is projection, where we fiddle with reference counts. mapM_ libDecl [C.cunit| int $id:free_opaque($ty:ctx_ty *ctx, $ty:opaque_type *obj) { + (void)ctx; int ret = 0, tmp; $items:free_body free(obj); @@ -1144,6 +1369,7 @@ int $id:store_opaque($ty:ctx_ty *ctx, const $ty:opaque_type *obj, void **p, size_t *n) { + (void)ctx; int ret = 0; $items:store_body return ret; @@ -1165,70 +1391,77 @@ } |] - pure $ - Manifest.OpaqueOps - { Manifest.opaqueFree = T.pack free_opaque, - Manifest.opaqueStore = T.pack store_opaque, - Manifest.opaqueRestore = T.pack restore_opaque - } + pure + ( Manifest.OpaqueOps + { Manifest.opaqueFree = T.pack free_opaque, + Manifest.opaqueStore = T.pack store_opaque, + Manifest.opaqueRestore = T.pack restore_opaque + }, + record + ) -valueDescToCType :: Publicness -> ValueDesc -> CompilerM op s C.Type -valueDescToCType _ (ScalarValue pt signed _) = - pure $ primAPIType signed pt -valueDescToCType pub (ArrayValue _ space pt signed shape) = do - let rank = length shape +valueDescToType :: ValueDesc -> ValueType +valueDescToType (ScalarValue pt signed _) = + ValueType signed (Rank 0) pt +valueDescToType (ArrayValue _ _ pt signed shape) = + ValueType signed (Rank (length shape)) pt + +generateArray :: + Space -> + ((Signedness, PrimType, Int), Publicness) -> + CompilerM op s (Maybe (T.Text, Manifest.Type)) +generateArray space ((signed, pt, rank), pub) = do name <- publicName $ arrayName pt signed rank - let add = M.insertWith max (space, signed, pt, rank) pub - modify $ \s -> s {compArrayTypes = add $ compArrayTypes s} - pure [C.cty|struct $id:name|] + let memty = fatMemType space + libDecl [C.cedecl|struct $id:name { $ty:memty mem; typename int64_t shape[$int:rank]; };|] + ops <- arrayLibraryFunctions pub space pt signed rank + let pt_name = T.pack $ prettySigned (signed == Unsigned) pt + pretty_name = mconcat (replicate rank "[]") <> pt_name + arr_type = [C.cty|struct $id:name*|] + case pub of + Public -> + pure $ + Just + ( pretty_name, + Manifest.TypeArray (prettyText arr_type) pt_name rank ops + ) + Private -> + pure Nothing -opaqueToCType :: String -> [ValueDesc] -> CompilerM op s C.Type -opaqueToCType desc vds = do - name <- publicName $ opaqueName desc vds - let add = M.insert desc vds - modify $ \s -> s {compOpaqueTypes = add $ compOpaqueTypes s} - -- Now ensure that the constituent array types will exist. - mapM_ (valueDescToCType Private) vds - pure [C.cty|struct $id:name|] +generateOpaque :: + OpaqueTypes -> + (String, OpaqueType) -> + CompilerM op s (T.Text, Manifest.Type) +generateOpaque types (desc, ot) = do + name <- publicName $ opaqueName desc + members <- zipWithM field (opaquePayload types ot) [(0 :: Int) ..] + libDecl [C.cedecl|struct $id:name { $sdecls:members };|] + (ops, record) <- opaqueLibraryFunctions types desc ot + let opaque_type = [C.cty|struct $id:name*|] + pure (T.pack desc, Manifest.TypeOpaque (prettyText opaque_type) ops record) + where + field vt@(ValueType _ (Rank r) _) i = do + ct <- valueTypeToCType Private vt + pure $ + if r == 0 + then [C.csdecl|$ty:ct $id:(tupleField i);|] + else [C.csdecl|$ty:ct *$id:(tupleField i);|] -generateAPITypes :: CompilerM op s (M.Map T.Text Manifest.Type) -generateAPITypes = do - array_ts <- mapM generateArray . M.toList =<< gets compArrayTypes - opaque_ts <- mapM generateOpaque . M.toList =<< gets compOpaqueTypes +generateAPITypes :: Space -> OpaqueTypes -> CompilerM op s (M.Map T.Text Manifest.Type) +generateAPITypes arr_space types@(OpaqueTypes opaques) = do + mapM_ (findNecessaryArrays . snd) opaques + array_ts <- mapM (generateArray arr_space) . M.toList =<< gets compArrayTypes + opaque_ts <- mapM (generateOpaque types) opaques pure $ M.fromList $ catMaybes array_ts <> opaque_ts where - generateArray ((space, signed, pt, rank), pub) = do - name <- publicName $ arrayName pt signed rank - let memty = fatMemType space - libDecl [C.cedecl|struct $id:name { $ty:memty mem; typename int64_t shape[$int:rank]; };|] - ops <- arrayLibraryFunctions pub space pt signed rank - let pt_name = T.pack $ prettySigned (signed == TypeUnsigned) pt - pretty_name = mconcat (replicate rank "[]") <> pt_name - arr_type = [C.cty|struct $id:name*|] - case pub of - Public -> - pure $ - Just - ( pretty_name, - Manifest.TypeArray (prettyText arr_type) pt_name rank ops - ) - Private -> - pure Nothing - - generateOpaque (desc, vds) = do - name <- publicName $ opaqueName desc vds - members <- zipWithM field vds [(0 :: Int) ..] - libDecl [C.cedecl|struct $id:name { $sdecls:members };|] - ops <- opaqueLibraryFunctions desc vds - let opaque_type = [C.cty|struct $id:name*|] - pure (T.pack desc, Manifest.TypeOpaque (prettyText opaque_type) ops) - - field vd@ScalarValue {} i = do - ct <- valueDescToCType Private vd - pure [C.csdecl|$ty:ct $id:(tupleField i);|] - field vd i = do - ct <- valueDescToCType Private vd - pure [C.csdecl|$ty:ct *$id:(tupleField i);|] + -- Ensure that array types will be generated before the opaque + -- records that allow projection of them. This is because the + -- projection functions somewhat uglily directly poke around in + -- the innards to increment reference counts. + findNecessaryArrays (OpaqueType _) = + pure () + findNecessaryArrays (OpaqueRecord fs) = + mapM_ (entryPointTypeToCType Public . snd) fs allTrue :: [C.Exp] -> C.Exp allTrue [] = [C.cexp|true|] @@ -1241,20 +1474,20 @@ prepareEntryInputs args = collect' $ zipWithM prepare [(0 :: Int) ..] args where arg_names = namesFromList $ concatMap evNames args - evNames (OpaqueValue _ _ vds) = map vdName vds - evNames (TransparentValue _ vd) = [vdName vd] + evNames (OpaqueValue _ vds) = map vdName vds + evNames (TransparentValue vd) = [vdName vd] vdName (ArrayValue v _ _ _ _) = v vdName (ScalarValue _ _ v) = v - prepare pno (TransparentValue _ vd) = do + prepare pno (TransparentValue vd) = do let pname = "in" ++ show pno (ty, check) <- prepareValue Public [C.cexp|$id:pname|] vd pure ( [C.cparam|const $ty:ty $id:pname|], if null check then Nothing else Just $ allTrue check ) - prepare pno (OpaqueValue _ desc vds) = do - ty <- opaqueToCType desc vds + prepare pno (OpaqueValue desc vds) = do + ty <- opaqueToCType desc let pname = "in" ++ show pno field i ScalarValue {} = [C.cexp|$id:pname->$id:(tupleField i)|] field i ArrayValue {} = [C.cexp|$id:pname->$id:(tupleField i)|] @@ -1272,13 +1505,13 @@ stm [C.cstm|$id:name = $exp:src';|] pure (pt', []) prepareValue pub src vd@(ArrayValue mem _ _ _ shape) = do - ty <- valueDescToCType pub vd + ty <- valueTypeToCType pub $ valueDescToType vd stm [C.cstm|$exp:mem = $exp:src->mem;|] let rank = length shape maybeCopyDim (Var d) i - | not $ d `nameIn` arg_names = + | d `notNameIn` arg_names = ( Just [C.cstm|$id:d = $exp:src->shape[$int:i];|], [C.cexp|$id:d == $exp:src->shape[$int:i]|] ) @@ -1296,9 +1529,9 @@ prepareEntryOutputs :: [ExternalValue] -> CompilerM op s ([C.Param], [C.BlockItem]) prepareEntryOutputs = collect' . zipWithM prepare [(0 :: Int) ..] where - prepare pno (TransparentValue _ vd) = do + prepare pno (TransparentValue vd) = do let pname = "out" ++ show pno - ty <- valueDescToCType Public vd + ty <- valueTypeToCType Public $ valueDescToType vd case vd of ArrayValue {} -> do @@ -1308,18 +1541,19 @@ ScalarValue {} -> do prepareValue [C.cexp|*$id:pname|] vd pure [C.cparam|$ty:ty *$id:pname|] - prepare pno (OpaqueValue _ desc vds) = do + prepare pno (OpaqueValue desc vds) = do let pname = "out" ++ show pno - ty <- opaqueToCType desc vds - vd_ts <- mapM (valueDescToCType Private) vds + ty <- opaqueToCType desc + vd_ts <- mapM (valueTypeToCType Private . valueDescToType) vds stm [C.cstm|assert((*$id:pname = ($ty:ty*) malloc(sizeof($ty:ty))) != NULL);|] forM_ (zip3 [0 ..] vd_ts vds) $ \(i, ct, vd) -> do - let field = [C.cexp|(*$id:pname)->$id:(tupleField i)|] + let field = [C.cexp|((*$id:pname)->$id:(tupleField i))|] case vd of ScalarValue {} -> pure () - _ -> stm [C.cstm|assert(($exp:field = ($ty:ct*) malloc(sizeof($ty:ct))) != NULL);|] + ArrayValue {} -> do + stm [C.cstm|assert(($exp:field = ($ty:ct*) malloc(sizeof($ty:ct))) != NULL);|] prepareValue field vd pure [C.cparam|$ty:ty **$id:pname|] @@ -1354,8 +1588,8 @@ Name -> Function op -> CompilerM op s (Maybe (C.Definition, (T.Text, Manifest.EntryPoint))) -onEntryPoint _ _ (Function Nothing _ _ _ _ _) = pure Nothing -onEntryPoint get_consts fname (Function (Just ename) outputs inputs _ results args) = inNewFunction $ do +onEntryPoint _ _ (Function Nothing _ _ _) = pure Nothing +onEntryPoint get_consts fname (Function (Just (EntryPoint ename results args)) outputs inputs _) = inNewFunction $ do let out_args = map (\p -> [C.cexp|&$id:(paramName p)|]) outputs in_args = map (\p -> [C.cexp|$id:(paramName p)|]) inputs @@ -1369,7 +1603,7 @@ let (entry_point_input_params, entry_point_input_checks) = unzip inputs' (entry_point_output_params, pack_entry_outputs) <- - prepareEntryOutputs results + prepareEntryOutputs $ map snd results ctx_ty <- contextType @@ -1444,32 +1678,26 @@ let ty' = primTypeToCType ty decl [C.cdecl|$ty:ty' $id:name;|] - vdTypeAndUnique (TransparentValue _ (ScalarValue pt signed _)) = - ( T.pack $ prettySigned (signed == TypeUnsigned) pt, - False - ) - vdTypeAndUnique (TransparentValue u (ArrayValue _ _ pt signed shape)) = - ( T.pack $ - mconcat (replicate (length shape) "[]") - <> prettySigned (signed == TypeUnsigned) pt, - u == Unique - ) - vdTypeAndUnique (OpaqueValue u name _) = - (T.pack name, u == Unique) + vdType (TransparentValue (ScalarValue pt signed _)) = + T.pack $ prettySigned (signed == Unsigned) pt + vdType (TransparentValue (ArrayValue _ _ pt signed shape)) = + T.pack $ + mconcat (replicate (length shape) "[]") + <> prettySigned (signed == Unsigned) pt + vdType (OpaqueValue name _) = + T.pack name - outputManifest vd = - let (t, u) = vdTypeAndUnique vd - in Manifest.Output - { Manifest.outputType = t, - Manifest.outputUnique = u - } - inputManifest (v, vd) = - let (t, u) = vdTypeAndUnique vd - in Manifest.Input - { Manifest.inputName = nameToText v, - Manifest.inputType = t, - Manifest.inputUnique = u - } + outputManifest (u, vd) = + Manifest.Output + { Manifest.outputType = vdType vd, + Manifest.outputUnique = u == Unique + } + inputManifest ((v, u), vd) = + Manifest.Input + { Manifest.inputName = nameToText v, + Manifest.inputType = vdType vd, + Manifest.inputUnique = u == Unique + } -- | The result of compilation to C is multiple parts, which can be -- put together in various ways. The obvious way is to concatenate @@ -1539,26 +1767,26 @@ asServer parts = gnuSource <> disableWarnings <> cHeader parts <> cUtils parts <> cServer parts <> cLib parts --- | Compile imperative program to a C program. Always uses the --- function named "main" as entry point, so make sure it is defined. -compileProg :: +compileProg' :: MonadFreshNames m => T.Text -> T.Text -> - Operations op () -> - CompilerM op () () -> + Operations op s -> + s -> + CompilerM op s () -> T.Text -> - [Space] -> + (Space, [Space]) -> [Option] -> Definitions op -> - m CParts -compileProg backend version ops extra header_extra spaces options prog = do + m (CParts, CompilerState s) +compileProg' backend version ops def extra header_extra (arr_space, spaces) options prog = do src <- getNameSource let ((prototypes, definitions, entry_point_decls, manifest), endstate) = - runCompilerM ops src () compileProg' + runCompilerM ops src def compileProgAction initdecls = initDecls endstate entrydecls = entryDecls endstate arraydecls = arrayDecls endstate + opaquetypedecls = opaqueTypeDecls endstate opaquedecls = opaqueDecls endstate miscdecls = miscDecls endstate @@ -1582,6 +1810,7 @@ $arraydecls // Opaque values +$opaquetypedecls $opaquedecls // Entry points @@ -1651,18 +1880,20 @@ |] pure - CParts - { cHeader = headerdefs, - cUtils = utildefs, - cCLI = clidefs, - cServer = serverdefs, - cLib = libdefs, - cJsonManifest = Manifest.manifestToJSON manifest - } + ( CParts + { cHeader = headerdefs, + cUtils = utildefs, + cCLI = clidefs, + cServer = serverdefs, + cLib = libdefs, + cJsonManifest = Manifest.manifestToJSON manifest + }, + endstate + ) where - Definitions consts (Functions funs) = prog + Definitions types consts (Functions funs) = prog - compileProg' = do + compileProgAction = do (memstructs, memfuns, memreport) <- unzip3 <$> mapM defineMemorySpace spaces get_consts <- compileConstants consts @@ -1680,13 +1911,14 @@ mapM_ earlyDecl $ concat memfuns - types <- commonLibFuns memreport + type_funs <- generateAPITypes arr_space types + generateCommonLibFuns memreport pure ( T.unlines $ map prettyText prototypes, T.unlines $ map (prettyText . funcToDef) functions, T.unlines $ map prettyText entry_points, - Manifest.Manifest (M.fromList entry_points_manifest) types backend version + Manifest.Manifest (M.fromList entry_points_manifest) type_funs backend version ) funcToDef func = C.FuncDef func loc @@ -1695,9 +1927,24 @@ C.OldFunc _ _ _ _ _ _ l -> l C.Func _ _ _ _ _ l -> l -commonLibFuns :: [C.BlockItem] -> CompilerM op s (M.Map T.Text Manifest.Type) -commonLibFuns memreport = do - types <- generateAPITypes +-- | Compile imperative program to a C program. Always uses the +-- function named "main" as entry point, so make sure it is defined. +compileProg :: + MonadFreshNames m => + T.Text -> + T.Text -> + Operations op () -> + CompilerM op () () -> + T.Text -> + (Space, [Space]) -> + [Option] -> + Definitions op -> + m CParts +compileProg backend version ops extra header_extra (arr_space, spaces) options prog = + fst <$> compileProg' backend version ops () extra header_extra (arr_space, spaces) options prog + +generateCommonLibFuns :: [C.BlockItem] -> CompilerM op s () +generateCommonLibFuns memreport = do ctx <- contextType cfg <- configType ops <- asks envOperations @@ -1788,8 +2035,6 @@ }|] ) - pure types - compileConstants :: Constants op -> CompilerM op s [C.BlockItem] compileConstants (Constants ps init_consts) = do ctx_ty <- contextType @@ -1897,7 +2142,7 @@ local lexMem $ f (concatMap declCached cached') (map freeCached cached') compileFun :: [C.BlockItem] -> [C.Param] -> (Name, Function op) -> CompilerM op s (C.Definition, C.Func) -compileFun get_constants extra (fname, func@(Function _ outputs inputs body _ _)) = inNewFunction $ do +compileFun get_constants extra (fname, func@(Function _ outputs inputs body)) = inNewFunction $ do (outparams, out_ptrs) <- unzip <$> mapM compileOutput outputs inparams <- mapM compileInput inputs @@ -2164,7 +2409,7 @@ compileCode (Copy _ dest (Count destoffset) destspace src (Count srcoffset) srcspace (Count size)) = do copy <- asks envCopy join $ - copy + copy CopyBarrier <$> rawMem dest <*> compileExp (untyped destoffset) <*> pure destspace 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 @@ -190,7 +190,7 @@ [C.cstm|;|], [C.cexp|$id:dest|] ) - Just (TypeOpaque desc _) -> + Just (TypeOpaque desc _ _) -> ( [C.citems|futhark_panic(1, "Cannot read input #%d of type %s\n", $int:i, $string:(T.unpack desc));|], [C.cstm|;|], [C.cstm|;|], @@ -256,7 +256,7 @@ [C.cexp|$id:result|], [C.cstm|assert($id:(arrayFree ops)(ctx, $id:result) == 0);|] ) - Just (TypeOpaque t ops) -> + Just (TypeOpaque t ops _) -> ( [C.citem|typename $id:t $id:result;|], [C.cexp|$id:result|], [C.cstm|assert($id:(opaqueFree ops)(ctx, $id:result) == 0);|] @@ -269,7 +269,7 @@ Nothing -> let info = tname <> "_info" in [C.cstm|write_scalar(stdout, binary_output, &$id:info, &$exp:e);|] - Just (TypeOpaque desc _) -> + Just (TypeOpaque desc _ _) -> [C.cstm|printf("#", $string:(T.unpack desc));|] Just (TypeArray _ et rank ops) -> let et' = uncurry primAPIType $ scalarToPrim et @@ -409,7 +409,8 @@ (cli_entry_point_decls, entry_point_inits) = unzip $ map (uncurry (cliEntryPoint manifest)) $ - M.toList $ manifestEntryPoints manifest + M.toList $ + manifestEntryPoints manifest in prettyText [C.cunit| $esc:("#include ") diff --git a/src/Futhark/CodeGen/Backends/GenericC/Options.hs b/src/Futhark/CodeGen/Backends/GenericC/Options.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Options.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Options.hs @@ -136,8 +136,8 @@ optionStringChunk option = do short <- optionShortName option pure $ - short : - case optionArgument option of - NoArgument -> "" - RequiredArgument _ -> ":" - OptionalArgument -> "::" + short + : case optionArgument option of + NoArgument -> "" + RequiredArgument _ -> ":" + OptionalArgument -> "::" 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 @@ -113,21 +113,31 @@ typeStructName :: T.Text -> String typeStructName tname = "type_" <> zEncodeString (T.unpack tname) -typeBoilerplate :: (T.Text, Type) -> (C.Initializer, [C.Definition]) -typeBoilerplate (tname, TypeArray _ et rank ops) = +cType :: Manifest -> TypeName -> C.Type +cType manifest tname = + case M.lookup tname $ manifestTypes manifest of + Just (TypeArray ctype _ _ _) -> [C.cty|typename $id:(T.unpack ctype)|] + Just (TypeOpaque ctype _ _) -> [C.cty|typename $id:(T.unpack ctype)|] + Nothing -> uncurry primAPIType $ scalarToPrim tname + +-- First component is forward declaration so we don't have to worry +-- about ordering. +typeBoilerplate :: Manifest -> (T.Text, Type) -> (C.Definition, C.Initializer, [C.Definition]) +typeBoilerplate _ (tname, TypeArray _ et rank ops) = let type_name = typeStructName tname aux_name = type_name ++ "_aux" info_name = T.unpack et ++ "_info" shape_args = [[C.cexp|shape[$int:i]|] | i <- [0 .. rank - 1]] array_new_wrap = arrayNew ops <> "_wrap" - in ( [C.cinit|&$id:type_name|], + in ( [C.cedecl|const struct type $id:type_name;|], + [C.cinit|&$id:type_name|], [C.cunit| void* $id:array_new_wrap(struct futhark_context *ctx, const void* p, const typename int64_t* shape) { return $id:(arrayNew ops)(ctx, p, $args:shape_args); } - struct array_aux $id:aux_name = { + const struct array_aux $id:aux_name = { .name = $string:(T.unpack tname), .rank = $int:rank, .info = &$id:info_name, @@ -136,7 +146,7 @@ .shape = (typename array_shape_fn)$id:(arrayShape ops), .values = (typename array_values_fn)$id:(arrayValues ops) }; - struct type $id:type_name = { + const struct type $id:type_name = { .name = $string:(T.unpack tname), .restore = (typename restore_fn)restore_array, .store = (typename store_fn)store_array, @@ -144,28 +154,67 @@ .aux = &$id:aux_name };|] ) -typeBoilerplate (tname, TypeOpaque _ ops) = +typeBoilerplate manifest (tname, TypeOpaque c_type_name ops record) = let type_name = typeStructName tname - aux_name = type_name ++ "_aux" - in ( [C.cinit|&$id:type_name|], - [C.cunit| - struct opaque_aux $id:aux_name = { + aux_name = type_name <> "_aux" + (record_edecls, record_init) = recordDefs type_name record + in ( [C.cedecl|const struct type $id:type_name;|], + [C.cinit|&$id:type_name|], + record_edecls + ++ [C.cunit| + const struct opaque_aux $id:aux_name = { .store = (typename opaque_store_fn)$id:(opaqueStore ops), .restore = (typename opaque_restore_fn)$id:(opaqueRestore ops), .free = (typename opaque_free_fn)$id:(opaqueFree ops) }; - struct type $id:type_name = { + const struct type $id:type_name = { .name = $string:(T.unpack tname), .restore = (typename restore_fn)restore_opaque, .store = (typename store_fn)store_opaque, .free = (typename free_fn)free_opaque, - .aux = &$id:aux_name + .aux = &$id:aux_name, + .record = $init:record_init };|] ) + where + recordDefs _ Nothing = ([], [C.cinit|NULL|]) + recordDefs type_name (Just (RecordOps fields new)) = + let new_wrap = new <> "_wrap" + record_name = type_name <> "_record" + fields_name = type_name <> "_fields" + onField i (RecordField name field_tname project) = + let field_c_type = cType manifest field_tname + field_v = "v" <> show (i :: Int) + in ( [C.cinit|{.name = $string:(T.unpack name), + .type = &$id:(typeStructName field_tname), + .project = (typename project_fn)$id:project + }|], + [C.citem|const $ty:field_c_type $id:field_v = + *(const $ty:field_c_type*)fields[$int:i];|], + [C.cexp|$id:field_v|] + ) + (field_inits, get_fields, field_args) = unzip3 $ zipWith onField [0 ..] fields + in ( [C.cunit| + const struct field $id:fields_name[] = { + $inits:field_inits + }; + int $id:new_wrap(struct futhark_context* ctx, void** outp, const void* fields[]) { + typename $id:c_type_name *out = (typename $id:c_type_name*) outp; + $items:get_fields + return $id:new(ctx, out, $args:field_args); + } + const struct record $id:record_name = { + .num_fields = $int:(length fields), + .fields = $id:fields_name, + .new = $id:new_wrap + };|], + [C.cinit|&$id:record_name|] + ) -entryTypeBoilerplate :: Manifest -> ([C.Initializer], [C.Definition]) -entryTypeBoilerplate = - second concat . unzip . map typeBoilerplate . M.toList . manifestTypes +entryTypeBoilerplate :: Manifest -> ([C.Definition], [C.Initializer], [C.Definition]) +entryTypeBoilerplate manifest = + second concat . unzip3 . map (typeBoilerplate manifest) . M.toList . manifestTypes $ + manifest oneEntryBoilerplate :: Manifest -> (T.Text, EntryPoint) -> ([C.Definition], C.Initializer) oneEntryBoilerplate manifest (name, EntryPoint cfun outputs inputs) = @@ -183,14 +232,14 @@ | null in_types = ([C.citems|(void)ins;|], mempty) | otherwise = unzip $ zipWith loadIn [0 ..] in_types in ( [C.cunit| - struct type* $id:out_types_name[] = { + const struct type* $id:out_types_name[] = { $inits:(map typeStructInit out_types), NULL }; bool $id:out_unique_name[] = { $inits:(map outputUniqueInit outputs) }; - struct type* $id:in_types_name[] = { + const struct type* $id:in_types_name[] = { $inits:(map typeStructInit in_types), NULL }; @@ -219,20 +268,14 @@ uniqueInit True = [C.cinit|true|] uniqueInit False = [C.cinit|false|] - cType tname = - case M.lookup tname $ manifestTypes manifest of - Just (TypeArray ctype _ _ _) -> [C.cty|typename $id:(T.unpack ctype)|] - Just (TypeOpaque ctype _) -> [C.cty|typename $id:(T.unpack ctype)|] - Nothing -> uncurry primAPIType $ scalarToPrim tname - loadOut i tname = let v = "out" ++ show (i :: Int) - in ( [C.citem|$ty:(cType tname) *$id:v = outs[$int:i];|], + in ( [C.citem|$ty:(cType manifest tname) *$id:v = outs[$int:i];|], [C.cexp|$id:v|] ) loadIn i tname = let v = "in" ++ show (i :: Int) - in ( [C.citem|$ty:(cType tname) $id:v = *($ty:(cType tname)*)ins[$int:i];|], + in ( [C.citem|$ty:(cType manifest tname) $id:v = *($ty:(cType manifest tname)*)ins[$int:i];|], [C.cexp|$id:v|] ) @@ -241,16 +284,17 @@ first concat $ unzip $ map (oneEntryBoilerplate manifest) $ - M.toList $ manifestEntryPoints manifest + M.toList $ + manifestEntryPoints manifest mkBoilerplate :: Manifest -> ([C.Definition], [C.Initializer], [C.Initializer]) mkBoilerplate manifest = - let (type_inits, type_defs) = entryTypeBoilerplate manifest + let (type_decls, type_inits, type_defs) = entryTypeBoilerplate manifest (entry_defs, entry_inits) = entryBoilerplate manifest scalar_type_inits = map scalarTypeInit scalar_types - in (type_defs ++ entry_defs, scalar_type_inits ++ type_inits, entry_inits) + in (type_decls ++ type_defs ++ entry_defs, scalar_type_inits ++ type_inits, entry_inits) where scalarTypeInit tname = [C.cinit|&$id:(typeStructName tname)|] scalar_types = @@ -292,7 +336,7 @@ $edecls:boilerplate_defs -struct type* types[] = { +const struct type* types[] = { $inits:type_inits, NULL }; 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 @@ -56,12 +56,12 @@ import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.CodeGen.RTS.Python import Futhark.Compiler.Config (CompilerMode (..)) -import Futhark.IR.Primitive hiding (Bool) import Futhark.IR.Prop (isBuiltInFunction, subExpVars) import Futhark.IR.Syntax.Core (Space (..)) import Futhark.MonadFreshNames import Futhark.Util (zEncodeString) import Futhark.Util.Pretty (pretty, prettyText) +import Language.Futhark.Primitive hiding (Bool) -- | A substitute expression compiler, tried before the main -- compilation function. @@ -331,17 +331,20 @@ } ] -functionExternalValues :: Imp.Function a -> [Imp.ExternalValue] -functionExternalValues fun = Imp.functionResult fun ++ map snd (Imp.functionArgs fun) +functionExternalValues :: Imp.EntryPoint -> [Imp.ExternalValue] +functionExternalValues entry = + map snd (Imp.entryPointResults entry) ++ map snd (Imp.entryPointArgs entry) opaqueDefs :: Imp.Functions a -> M.Map String [PyExp] opaqueDefs (Imp.Functions funs) = - mconcat . map evd . concatMap (functionExternalValues . snd) $ - filter (isJust . Imp.functionEntry . snd) funs + mconcat + . map evd + . concatMap functionExternalValues + . mapMaybe (Imp.functionEntry . snd) + $ funs where evd Imp.TransparentValue {} = mempty - evd (Imp.OpaqueValue _ name vds) = - M.singleton name $ map (String . vd) vds + evd (Imp.OpaqueValue name vds) = M.singleton name $ map (String . vd) vds vd (Imp.ScalarValue pt s _) = readTypeEnum pt s vd (Imp.ArrayValue _ _ pt s dims) = @@ -390,7 +393,7 @@ ] ++ prog' where - Imp.Definitions consts (Imp.Functions funs) = prog + Imp.Definitions _types consts (Imp.Functions funs) = prog compileProg' = withConstantSubsts consts $ do compileConstants consts @@ -406,11 +409,11 @@ pure [ ClassDef $ Class class_name $ - Assign (Var "entry_points") (Dict entry_point_types) : - Assign - (Var "opaques") - (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads)) : - map FunDef (constructor' : definitions ++ entry_points) + Assign (Var "entry_points") (Dict entry_point_types) + : Assign + (Var "opaques") + (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads)) + : map FunDef (constructor' : definitions ++ entry_points) ] ToServer -> do (entry_points, entry_point_types) <- @@ -419,11 +422,11 @@ parse_options_server ++ [ ClassDef ( Class class_name $ - Assign (Var "entry_points") (Dict entry_point_types) : - Assign - (Var "opaques") - (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads)) : - map FunDef (constructor' : definitions ++ entry_points) + Assign (Var "entry_points") (Dict entry_point_types) + : Assign + (Var "opaques") + (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads)) + : map FunDef (constructor' : definitions ++ entry_points) ), Assign (Var "server") @@ -440,18 +443,18 @@ ( Class class_name $ map FunDef $ constructor' : definitions - ) : - classinst : - map FunDef entry_point_defs + ) + : classinst + : map FunDef entry_point_defs ++ selectEntryPoint entry_point_names entry_points parse_options_executable = - Assign (Var "runtime_file") None : - Assign (Var "do_warmup_run") (Bool False) : - Assign (Var "num_runs") (Integer 1) : - Assign (Var "entry_point") (String "main") : - Assign (Var "binary_output") (Bool False) : - generateOptionParser (executableOptions ++ options) + Assign (Var "runtime_file") None + : Assign (Var "do_warmup_run") (Bool False) + : Assign (Var "num_runs") (Integer 1) + : Assign (Var "entry_point") (String "main") + : Assign (Var "binary_output") (Bool False) + : generateOptionParser (executableOptions ++ options) parse_options_server = generateOptionParser (standardOptions ++ options) @@ -461,7 +464,8 @@ selectEntryPoint entry_point_names entry_points = [ Assign (Var "entry_points") $ - Dict $ zip (map String entry_point_names) entry_points, + Dict $ + zip (map String entry_point_names) entry_points, Assign (Var "entry_point_fun") $ simpleCall "entry_points.get" [Var "entry_point"], If @@ -492,7 +496,10 @@ constExp p = M.singleton (Imp.paramName p) $ Index (Var "self.constants") $ - IdxExp $ String $ pretty $ Imp.paramName p + IdxExp $ + String $ + pretty $ + Imp.paramName p compileConstants :: Imp.Constants op -> CompilerM op s () compileConstants (Imp.Constants _ init_consts) = do @@ -500,7 +507,7 @@ mapM_ atInit =<< collect (compileCode init_consts) compileFunc :: (Name, Imp.Function op) -> CompilerM op s PyFunDef -compileFunc (fname, Imp.Function _ outputs inputs body _ _) = do +compileFunc (fname, Imp.Function _ outputs inputs body) = do body' <- collect $ compileCode body let inputs' = map (compileName . Imp.paramName) inputs let ret = Return $ tupleOrSingle $ compileOutput outputs @@ -545,18 +552,18 @@ ] entryPointOutput :: Imp.ExternalValue -> CompilerM op s PyExp -entryPointOutput (Imp.OpaqueValue u desc vs) = +entryPointOutput (Imp.OpaqueValue desc vs) = simpleCall "opaque" . (String (pretty desc) :) - <$> mapM (entryPointOutput . Imp.TransparentValue u) vs -entryPointOutput (Imp.TransparentValue _ (Imp.ScalarValue bt ept name)) = do + <$> mapM (entryPointOutput . Imp.TransparentValue) vs +entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) = do name' <- compileVar name pure $ simpleCall tf [name'] where tf = compilePrimToExtNp bt ept -entryPointOutput (Imp.TransparentValue _ (Imp.ArrayValue mem (Imp.Space sid) bt ept dims)) = do +entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims)) = do pack_output <- asks envEntryOutput pack_output mem sid bt ept dims -entryPointOutput (Imp.TransparentValue _ (Imp.ArrayValue mem _ bt ept dims)) = do +entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ bt ept dims)) = do mem' <- Cast <$> compileVar mem <*> pure (compilePrimTypeExt bt ept) dims' <- mapM compileDim dims pure $ simpleCall "createArray" [mem', Tuple dims', Var $ compilePrimToExtNp bt ept] @@ -621,14 +628,14 @@ declEntryPointInputSizes :: [Imp.ExternalValue] -> CompilerM op s () declEntryPointInputSizes = mapM_ onSize . concatMap sizes where - sizes (Imp.TransparentValue _ v) = valueSizes v - sizes (Imp.OpaqueValue _ _ vs) = concatMap valueSizes vs + sizes (Imp.TransparentValue v) = valueSizes v + sizes (Imp.OpaqueValue _ vs) = concatMap valueSizes vs valueSizes (Imp.ArrayValue _ _ _ _ dims) = subExpVars dims valueSizes Imp.ScalarValue {} = [] onSize v = stm $ Assign (Var (compileName v)) None entryPointInput :: (Int, Imp.ExternalValue, PyExp) -> CompilerM op s () -entryPointInput (i, Imp.OpaqueValue u desc vs, e) = do +entryPointInput (i, Imp.OpaqueValue desc vs, e) = do let type_is_ok = BinOp "and" @@ -636,9 +643,9 @@ (BinOp "==" (Field e "desc") (String desc)) stm $ If (UnOp "not" type_is_ok) [badInput i e desc] [] mapM_ entryPointInput $ - zip3 (repeat i) (map (Imp.TransparentValue u) vs) $ + zip3 (repeat i) (map Imp.TransparentValue vs) $ map (Index (Field e "data") . IdxExp . Integer) [0 ..] -entryPointInput (i, Imp.TransparentValue _ (Imp.ScalarValue bt s name), e) = do +entryPointInput (i, Imp.TransparentValue (Imp.ScalarValue bt s name), e) = do vname' <- compileVar name let -- HACK: A Numpy int64 will signal an OverflowError if we pass -- it a number bigger than 2**63. This does not happen if we @@ -659,9 +666,9 @@ [Assign vname' npcall] [ Catch (Tuple [Var "TypeError", Var "AssertionError"]) - [badInput i e $ prettySigned (s == Imp.TypeUnsigned) bt] + [badInput i e $ prettySigned (s == Imp.Unsigned) bt] ] -entryPointInput (i, Imp.TransparentValue _ (Imp.ArrayValue mem (Imp.Space sid) bt ept dims), e) = do +entryPointInput (i, Imp.TransparentValue (Imp.ArrayValue mem (Imp.Space sid) bt ept dims), e) = do unpack_input <- asks envEntryInput mem' <- compileVar mem unpack <- collect $ unpack_input mem' sid bt ept dims e @@ -672,10 +679,10 @@ (Tuple [Var "TypeError", Var "AssertionError"]) [ badInput i e $ concat (replicate (length dims) "[]") - ++ prettySigned (ept == Imp.TypeUnsigned) bt + ++ prettySigned (ept == Imp.Unsigned) bt ] ] -entryPointInput (i, Imp.TransparentValue _ (Imp.ArrayValue mem _ t s dims), e) = do +entryPointInput (i, Imp.TransparentValue (Imp.ArrayValue mem _ t s dims), e) = do let type_is_wrong = UnOp "not" $ BinOp "in" (simpleCall "type" [e]) $ List [Var "np.ndarray"] let dtype_is_wrong = UnOp "not" $ BinOp "==" (Field e "dtype") $ Var $ compilePrimToExtNp t s let dim_is_wrong = UnOp "not" $ BinOp "==" (Field e "ndim") $ Integer $ toInteger $ length dims @@ -684,7 +691,7 @@ type_is_wrong [ badInput i e $ concat (replicate (length dims) "[]") - ++ prettySigned (s == Imp.TypeUnsigned) t + ++ prettySigned (s == Imp.Unsigned) t ] [] stm $ @@ -693,7 +700,7 @@ [ badInputType i e - (concat (replicate (length dims) "[]") ++ prettySigned (s == Imp.TypeUnsigned) t) + (concat (replicate (length dims) "[]") ++ prettySigned (s == Imp.Unsigned) t) (simpleCall "np.dtype" [Var (compilePrimToExtNp t s)]) (Field e "dtype") ] @@ -701,7 +708,7 @@ stm $ If dim_is_wrong - [badInputDim i e (prettySigned (s == Imp.TypeUnsigned) t) (length dims)] + [badInputDim i e (prettySigned (s == Imp.Unsigned) t) (length dims)] [] zipWithM_ (unpackDim e) dims [0 ..] @@ -711,9 +718,9 @@ stm $ Assign dest unwrap_call extValueDescName :: Imp.ExternalValue -> String -extValueDescName (Imp.TransparentValue _ v) = extName $ valueDescName v -extValueDescName (Imp.OpaqueValue _ desc []) = extName $ zEncodeString desc -extValueDescName (Imp.OpaqueValue _ desc (v : _)) = +extValueDescName (Imp.TransparentValue v) = extName $ valueDescName v +extValueDescName (Imp.OpaqueValue desc []) = extName $ zEncodeString desc +extValueDescName (Imp.OpaqueValue desc (v : _)) = extName $ zEncodeString desc ++ "_" ++ pretty (baseTag (valueDescVName v)) extName :: String -> String @@ -728,14 +735,14 @@ -- Key into the FUTHARK_PRIMTYPES dict. readTypeEnum :: PrimType -> Imp.Signedness -> String -readTypeEnum (IntType Int8) Imp.TypeUnsigned = "u8" -readTypeEnum (IntType Int16) Imp.TypeUnsigned = "u16" -readTypeEnum (IntType Int32) Imp.TypeUnsigned = "u32" -readTypeEnum (IntType Int64) Imp.TypeUnsigned = "u64" -readTypeEnum (IntType Int8) Imp.TypeDirect = "i8" -readTypeEnum (IntType Int16) Imp.TypeDirect = "i16" -readTypeEnum (IntType Int32) Imp.TypeDirect = "i32" -readTypeEnum (IntType Int64) Imp.TypeDirect = "i64" +readTypeEnum (IntType Int8) Imp.Unsigned = "u8" +readTypeEnum (IntType Int16) Imp.Unsigned = "u16" +readTypeEnum (IntType Int32) Imp.Unsigned = "u32" +readTypeEnum (IntType Int64) Imp.Unsigned = "u64" +readTypeEnum (IntType Int8) Imp.Signed = "i8" +readTypeEnum (IntType Int16) Imp.Signed = "i16" +readTypeEnum (IntType Int32) Imp.Signed = "i32" +readTypeEnum (IntType Int64) Imp.Signed = "i64" readTypeEnum (FloatType Float16) _ = "f16" readTypeEnum (FloatType Float32) _ = "f32" readTypeEnum (FloatType Float64) _ = "f64" @@ -743,15 +750,15 @@ readTypeEnum Unit _ = "bool" readInput :: Imp.ExternalValue -> PyStmt -readInput (Imp.OpaqueValue _ desc _) = +readInput (Imp.OpaqueValue desc _) = Raise $ simpleCall "Exception" [String $ "Cannot read argument of type " ++ desc ++ "."] -readInput decl@(Imp.TransparentValue _ (Imp.ScalarValue bt ept _)) = +readInput decl@(Imp.TransparentValue (Imp.ScalarValue bt ept _)) = let type_name = readTypeEnum bt ept in Assign (Var $ extValueDescName decl) $ simpleCall "read_value" [String type_name] -readInput decl@(Imp.TransparentValue _ (Imp.ArrayValue _ _ bt ept dims)) = +readInput decl@(Imp.TransparentValue (Imp.ArrayValue _ _ bt ept dims)) = let type_name = readTypeEnum bt ept in Assign (Var $ extValueDescName decl) $ simpleCall @@ -766,17 +773,17 @@ -- that returns an equivalent Numpy array. This works for PyOpenCL, -- but we will probably need yet another plugin mechanism here in -- the future. - printValue' (Imp.OpaqueValue _ desc _) _ = + printValue' (Imp.OpaqueValue desc _) _ = pure [ Exp $ simpleCall "sys.stdout.write" [String $ "#"] ] - printValue' (Imp.TransparentValue u (Imp.ArrayValue mem (Space _) bt ept shape)) e = - printValue' (Imp.TransparentValue u (Imp.ArrayValue mem DefaultSpace bt ept shape)) $ + printValue' (Imp.TransparentValue (Imp.ArrayValue mem (Space _) bt ept shape)) e = + printValue' (Imp.TransparentValue (Imp.ArrayValue mem DefaultSpace bt ept shape)) $ simpleCall (pretty e ++ ".get") [] - printValue' (Imp.TransparentValue _ _) e = + printValue' (Imp.TransparentValue _) e = pure [ Exp $ Call @@ -788,6 +795,7 @@ ] prepareEntry :: + Imp.EntryPoint -> (Name, Imp.Function op) -> CompilerM op @@ -798,7 +806,7 @@ [PyStmt], [(Imp.ExternalValue, PyExp)] ) -prepareEntry (fname, Imp.Function _ outputs inputs _ results args) = do +prepareEntry (Imp.EntryPoint _ results args) (fname, Imp.Function _ outputs inputs _) = do let output_paramNames = map (compileName . Imp.paramName) outputs funTuple = tupleOrSingle $ fmap Var output_paramNames @@ -806,7 +814,7 @@ declEntryPointInputSizes $ map snd args mapM_ entryPointInput . zip3 [0 ..] (map snd args) $ map (Var . extValueDescName . snd) args - (res, prepareOut) <- collect' $ mapM entryPointOutput results + (res, prepareOut) <- collect' $ mapM (entryPointOutput . snd) results let argexps_lib = map (compileName . Imp.paramName) inputs fname' = "self." ++ futharkFun (nameToString fname) @@ -827,7 +835,7 @@ prepareIn, call argexps_lib, prepareOut, - zip results res + zip (map snd results) res ) copyMemoryDefaultSpace :: @@ -855,9 +863,10 @@ ReturnTiming -> (Name, Imp.Function op) -> CompilerM op s (Maybe (PyFunDef, (PyExp, PyExp))) -compileEntryFun sync timing entry - | Just ename <- Imp.functionEntry $ snd entry = do - (params, prepareIn, body_lib, prepareOut, res) <- prepareEntry entry +compileEntryFun sync timing fun + | Just entry <- Imp.functionEntry $ snd fun = do + let ename = Imp.entryPointName entry + (params, prepareIn, body_lib, prepareOut, res) <- prepareEntry entry fun let (maybe_sync, ret) = case timing of DoNotReturnTiming -> @@ -872,11 +881,12 @@ tupleOrSingle $ map snd res ] ) - (pts, rts) = entryTypes $ snd entry + (pts, rts) = entryTypes entry do_run = - Assign (Var "time_start") (simpleCall "time.time" []) : - body_lib ++ maybe_sync + Assign (Var "time_start") (simpleCall "time.time" []) + : body_lib + ++ maybe_sync ++ [ Assign (Var "runtime") $ BinOp "-" @@ -892,24 +902,24 @@ ) | otherwise = pure Nothing -entryTypes :: Imp.Function op -> ([String], [String]) -entryTypes func = - ( map (desc . snd) $ Imp.functionArgs func, - map desc $ Imp.functionResult func - ) +entryTypes :: Imp.EntryPoint -> ([String], [String]) +entryTypes (Imp.EntryPoint _ res args) = + (map descArg args, map desc res) where - desc (Imp.OpaqueValue u d _) = pretty u <> d - desc (Imp.TransparentValue u (Imp.ScalarValue pt s _)) = pretty u <> readTypeEnum pt s - desc (Imp.TransparentValue u (Imp.ArrayValue _ _ pt s dims)) = + descArg ((_, u), d) = desc (u, d) + desc (u, Imp.OpaqueValue d _) = pretty u <> d + desc (u, Imp.TransparentValue (Imp.ScalarValue pt s _)) = pretty u <> readTypeEnum pt s + desc (u, Imp.TransparentValue (Imp.ArrayValue _ _ pt s dims)) = pretty u <> concat (replicate (length dims) "[]") <> readTypeEnum pt s callEntryFun :: [PyStmt] -> (Name, Imp.Function op) -> CompilerM op s (Maybe (PyFunDef, String, PyExp)) -callEntryFun _ (_, Imp.Function Nothing _ _ _ _ _) = pure Nothing -callEntryFun pre_timing entry@(fname, Imp.Function (Just ename) _ _ _ _ decl_args) = do - (_, prepare_in, body_bin, _, res) <- prepareEntry entry +callEntryFun _ (_, Imp.Function Nothing _ _ _) = pure Nothing +callEntryFun pre_timing fun@(fname, Imp.Function (Just entry) _ _ _) = do + let Imp.EntryPoint ename _ decl_args = entry + (_, prepare_in, body_bin, _, res) <- prepareEntry entry fun let str_input = map (readInput . snd) decl_args end_of_input = [Exp $ simpleCall "end_of_input" [String $ pretty fname]] @@ -935,7 +945,9 @@ pure $ Just ( Def fname' [] $ - str_input ++ end_of_input ++ prepare_in + str_input + ++ end_of_input + ++ prepare_in ++ [Try [do_warmup_run, do_num_runs] [except']] ++ [close_runtime_file] ++ str_output, @@ -1014,10 +1026,10 @@ compilePrimTypeExt :: PrimType -> Imp.Signedness -> String compilePrimTypeExt t ept = case (t, ept) of - (IntType Int8, Imp.TypeUnsigned) -> "ct.c_uint8" - (IntType Int16, Imp.TypeUnsigned) -> "ct.c_uint16" - (IntType Int32, Imp.TypeUnsigned) -> "ct.c_uint32" - (IntType Int64, Imp.TypeUnsigned) -> "ct.c_uint64" + (IntType Int8, Imp.Unsigned) -> "ct.c_uint8" + (IntType Int16, Imp.Unsigned) -> "ct.c_uint16" + (IntType Int32, Imp.Unsigned) -> "ct.c_uint32" + (IntType Int64, Imp.Unsigned) -> "ct.c_uint64" (IntType Int8, _) -> "ct.c_int8" (IntType Int16, _) -> "ct.c_int16" (IntType Int32, _) -> "ct.c_int32" @@ -1046,10 +1058,10 @@ compilePrimToExtNp :: Imp.PrimType -> Imp.Signedness -> String compilePrimToExtNp bt ept = case (bt, ept) of - (IntType Int8, Imp.TypeUnsigned) -> "np.uint8" - (IntType Int16, Imp.TypeUnsigned) -> "np.uint16" - (IntType Int32, Imp.TypeUnsigned) -> "np.uint32" - (IntType Int64, Imp.TypeUnsigned) -> "np.uint64" + (IntType Int8, Imp.Unsigned) -> "np.uint8" + (IntType Int16, Imp.Unsigned) -> "np.uint16" + (IntType Int32, Imp.Unsigned) -> "np.uint32" + (IntType Int64, Imp.Unsigned) -> "np.uint64" (IntType Int8, _) -> "np.int8" (IntType Int16, _) -> "np.int16" (IntType Int32, _) -> "np.int32" 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 @@ -131,18 +131,22 @@ instance Pretty PyStmt where ppr (If cond [] []) = - text "if" <+> ppr cond <> text ":" + text "if" + <+> ppr cond <> text ":" indent 2 (text "pass") ppr (If cond [] fbranch) = - text "if" <+> ppr cond <> text ":" + text "if" + <+> ppr cond <> text ":" indent 2 (text "pass") text "else:" indent 2 (stack $ map ppr fbranch) ppr (If cond tbranch []) = - text "if" <+> ppr cond <> text ":" + text "if" + <+> ppr cond <> text ":" indent 2 (stack $ map ppr tbranch) ppr (If cond tbranch fbranch) = - text "if" <+> ppr cond <> text ":" + text "if" + <+> ppr cond <> text ":" indent 2 (stack $ map ppr tbranch) text "else:" indent 2 (stack $ map ppr fbranch) @@ -151,13 +155,18 @@ indent 2 (stack $ map ppr pystms) stack (map ppr pyexcepts) ppr (While cond body) = - text "while" <+> ppr cond <> text ":" + text "while" + <+> ppr cond <> text ":" indent 2 (stack $ map ppr body) ppr (For i what body) = - text "for" <+> ppr i <+> text "in" <+> ppr what <> text ":" + text "for" + <+> ppr i + <+> text "in" + <+> ppr what <> text ":" indent 2 (stack $ map ppr body) ppr (With what body) = - text "with" <+> ppr what <> text ":" + text "with" + <+> ppr what <> text ":" indent 2 (stack $ map ppr body) ppr (Assign e1 e2) = ppr e1 <+> text "=" <+> ppr e2 ppr (AssignOp op e1 e2) = ppr e1 <+> text (op ++ "=") <+> ppr e2 @@ -177,17 +186,21 @@ instance Pretty PyFunDef where ppr (Def fname params body) = - text "def" <+> text fname <> parens (commasep $ map ppr params) <> text ":" + text "def" + <+> text fname <> parens (commasep $ map ppr params) <> text ":" indent 2 (stack (map ppr body)) instance Pretty PyClassDef where ppr (Class cname body) = - text "class" <+> text cname <> text ":" + text "class" + <+> text cname <> text ":" indent 2 (stack (map ppr body)) instance Pretty PyExcept where ppr (Catch pyexp stms) = - text "except" <+> ppr pyexp <+> text "as e:" + text "except" + <+> ppr pyexp + <+> text "as e:" indent 2 (stack $ map ppr stms) instance Pretty PyProg where diff --git a/src/Futhark/CodeGen/Backends/GenericPython/Options.hs b/src/Futhark/CodeGen/Backends/GenericPython/Options.hs --- a/src/Futhark/CodeGen/Backends/GenericPython/Options.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython/Options.hs @@ -83,7 +83,9 @@ For "optarg" ( Index (Var "parser_result") $ - IdxExp $ String $ fieldName option + IdxExp $ + String $ + fieldName option ) $ optionAction option diff --git a/src/Futhark/CodeGen/Backends/GenericWASM.hs b/src/Futhark/CodeGen/Backends/GenericWASM.hs --- a/src/Futhark/CodeGen/Backends/GenericWASM.hs +++ b/src/Futhark/CodeGen/Backends/GenericWASM.hs @@ -22,26 +22,26 @@ import Futhark.CodeGen.Backends.SimpleRep (opaqueName) import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import Futhark.CodeGen.RTS.JavaScript -import Futhark.IR.Primitive +import Language.Futhark.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 +extToString (Imp.TransparentValue (Imp.ArrayValue vn _ pt s dimSize)) = + concat (replicate (length dimSize) "[]") ++ extToString (Imp.TransparentValue (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.Signed _)) = "i8" +extToString (Imp.TransparentValue (Imp.ScalarValue (IntType Int16) Imp.Signed _)) = "i16" +extToString (Imp.TransparentValue (Imp.ScalarValue (IntType Int32) Imp.Signed _)) = "i32" +extToString (Imp.TransparentValue (Imp.ScalarValue (IntType Int64) Imp.Signed _)) = "i64" +extToString (Imp.TransparentValue (Imp.ScalarValue (IntType Int8) Imp.Unsigned _)) = "u8" +extToString (Imp.TransparentValue (Imp.ScalarValue (IntType Int16) Imp.Unsigned _)) = "u16" +extToString (Imp.TransparentValue (Imp.ScalarValue (IntType Int32) Imp.Unsigned _)) = "u32" +extToString (Imp.TransparentValue (Imp.ScalarValue (IntType Int64) Imp.Unsigned _)) = "u64" +extToString (Imp.TransparentValue (Imp.ScalarValue Bool _ _)) = "bool" +extToString (Imp.TransparentValue (Imp.ScalarValue Unit _ _)) = error "extToString: Unit" +extToString (Imp.OpaqueValue oname _) = opaqueName oname type EntryPointType = String @@ -204,7 +204,9 @@ makeResult :: Int -> String -> String makeResult i typ = - " var result" ++ show i ++ " = " + " var result" + ++ show i + ++ " = " ++ if isArray typ then "this.new_" ++ signature ++ "_from_ptr(" ++ readout ++ ");" else 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 @@ -12,6 +12,20 @@ GC.asServer, operations, cliOptions, + compileOp, + ValueType (..), + paramToCType, + prepareTaskStruct, + closureFreeStructField, + generateParLoopFn, + addTimingFields, + functionTiming, + functionIterations, + multiCoreReport, + multicoreDef, + multicoreName, + DefSpecifier, + atomicOps, ) where @@ -23,7 +37,7 @@ 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 Futhark.CodeGen.ImpCode.Multicore hiding (ValueType) import qualified Futhark.CodeGen.ImpGen.Multicore as ImpGen import Futhark.CodeGen.RTS.C (schedulerH) import Futhark.IR.MCMem (MCMem, Prog) @@ -42,10 +56,10 @@ operations generateContext "" - [DefaultSpace] + (DefaultSpace, [DefaultSpace]) cliOptions ) - <=< ImpGen.compileProg ImpGen.AllowDynamicScheduling + <=< ImpGen.compileProg -- | Generate the multicore context definitions. This is exported -- because the WASM backend needs it. @@ -304,7 +318,10 @@ compileSetRetvalStructValues struct vnames we = concat $ zipWith field vnames we where field name (ct, Prim _) = - [C.cstms|$id:struct.$id:(closureRetvalStructField name)=(($ty:ct*)&$id:name);|] + [C.cstms|$id:struct.$id:(closureRetvalStructField name)=(($ty:ct*)&$id:name); + $escstm:("#if ISPC") + $id:struct.$id:(closureRetvalStructField name)+= programIndex; + $escstm:("#endif")|] field name (_, MemBlock) = [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name.mem;|] field name (_, RawMem) = @@ -576,7 +593,7 @@ e' <- GC.compileExp e - let lexical = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] params seq_code [] [] + let lexical = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] params seq_code fstruct <- prepareTaskStruct multicoreDef "task" free_args free_ctypes retval_args retval_ctypes @@ -601,7 +618,7 @@ -- Generate the nested segop function if available fnpar_task <- case par_task of Just (ParallelTask nested_code) -> do - let lexical_nested = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] params nested_code [] [] + let lexical_nested = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] params nested_code fnpar_task <- generateParLoopFn lexical_nested (name ++ "_nested_task") nested_code fstruct free retval GC.stm [C.cstm|$id:ftask_name.nested_fn = $id:fnpar_task;|] pure $ zip [fnpar_task] [True] @@ -627,7 +644,7 @@ free_ctypes <- mapM paramToCType free let free_args = map paramName free - let lexical = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] free body [] [] + let lexical = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] free body fstruct <- prepareTaskStruct multicoreDef (s' ++ "_parloop_struct") free_args free_ctypes mempty mempty @@ -686,6 +703,29 @@ mapM_ GC.profileReport $ multiCoreReport $ zip [ftask, ftask_total] [True, False] compileOp (Atomic aop) = atomicOps aop (\ty _ -> pure [C.cty|$ty:ty*|]) +compileOp (ISPCKernel body _) = + scopedBlock body +compileOp (ForEach i from bound body) = do + let i' = C.toIdent i + t = primTypeToCType $ primExpType bound + from' <- GC.compileExp from + bound' <- GC.compileExp bound + body' <- GC.collect $ GC.compileCode body + GC.stm + [C.cstm|for ($ty:t $id:i' = $exp:from'; $id:i' < $exp:bound'; $id:i'++) { + $items:body' + }|] +compileOp (ForEachActive i body) = do + GC.decl [C.cdecl|typename int64_t $id:i = 0;|] + scopedBlock body +compileOp (ExtractLane dest tar _) = do + tar' <- GC.compileExp tar + GC.stm [C.cstm|$id:dest = $exp:tar';|] + +scopedBlock :: MCCode -> GC.CompilerM Multicore s () +scopedBlock code = do + inner <- GC.collect $ GC.compileCode code + GC.stm [C.cstm|{$items:inner}|] doAtomic :: (C.ToIdent a1) => diff --git a/src/Futhark/CodeGen/Backends/MulticoreISPC.hs b/src/Futhark/CodeGen/Backends/MulticoreISPC.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/MulticoreISPC.hs @@ -0,0 +1,1114 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | C code generator. This module can convert a correct ImpCode +-- program to an equivalent ISPC program. +module Futhark.CodeGen.Backends.MulticoreISPC + ( compileProg, + GC.CParts (..), + GC.asLibrary, + GC.asExecutable, + GC.asServer, + operations, + ISPCState, + ) +where + +import Control.Lens (each, over) +import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Data.Bifunctor +import qualified Data.DList as DL +import Data.List (unzip4) +import Data.Loc (noLoc) +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import qualified Futhark.CodeGen.Backends.GenericC as GC +import qualified Futhark.CodeGen.Backends.MulticoreC as MC +import Futhark.CodeGen.Backends.SimpleRep +import Futhark.CodeGen.ImpCode.Multicore +import qualified Futhark.CodeGen.ImpGen.Multicore as ImpGen +import Futhark.CodeGen.RTS.C (errorsH, ispcUtilH, uniformH) +import Futhark.IR.MCMem (MCMem, Prog) +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) + +type ISPCCompilerM a = GC.CompilerM Multicore ISPCState a + +-- | Transient state tracked by the ISPC backend. +data ISPCState = ISPCState + { sDefs :: DL.DList C.Definition, + sUniform :: Names + } + +uniform :: C.TypeQual +uniform = C.EscTypeQual "uniform" noLoc + +unmasked :: C.TypeQual +unmasked = C.EscTypeQual "unmasked" noLoc + +export :: C.TypeQual +export = C.EscTypeQual "export" noLoc + +varying :: C.TypeQual +varying = C.EscTypeQual "varying" noLoc + +-- | Compile the program to C and ISPC code using multicore operations. +compileProg :: + MonadFreshNames m => T.Text -> Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text)) +compileProg version prog = do + -- Dynamic scheduling seems completely broken currently, so we disable it. + (ws, defs) <- ImpGen.compileProg prog + let Functions funs = defFuns defs + + (ws', (cparts, endstate)) <- + traverse + ( GC.compileProg' + "ispc" + version + operations + (ISPCState mempty mempty) + ( do + GC.libDecl [C.cedecl|char** futhark_get_error_ref(struct futhark_context* ctx) { return &ctx->error; }|] + MC.generateContext + mapM_ compileBuiltinFun funs + ) + mempty + (DefaultSpace, [DefaultSpace]) + MC.cliOptions + ) + (ws, defs) + + let ispc_decls = T.unlines $ map prettyText $ DL.toList $ sDefs $ GC.compUserState endstate + + -- The bool #define is a workaround around an ISPC bug, stdbool doesn't get included. + let ispcdefs = + [untrimming| +#define bool uint8 +typedef int64 int64_t; +typedef int32 int32_t; +typedef int16 int16_t; +typedef int8 int8_t; +typedef int8 char; +typedef unsigned int64 uint64_t; +typedef unsigned int32 uint32_t; +typedef unsigned int16 uint16_t; +typedef unsigned int8 uint8_t; +#define volatile + +$errorsH + +#define INFINITY (floatbits((uniform int)0x7f800000)) +#define NAN (floatbits((uniform int)0x7fc00000)) +#define fabs(x) abs(x) +#define FUTHARK_F64_ENABLED +$cScalarDefs + +$uniformH + +$ispcUtilH + +$ispc_decls|] + + pure (ws', (cparts, ispcdefs)) + +-- | Compiler operations specific to the ISPC multicore backend. +operations :: GC.Operations Multicore ISPCState +operations = + MC.operations + { GC.opsCompiler = compileOp + } + +ispcDecl :: C.Definition -> ISPCCompilerM () +ispcDecl def = + GC.modifyUserState (\s -> s {sDefs = sDefs s <> DL.singleton def}) + +ispcEarlyDecl :: C.Definition -> ISPCCompilerM () +ispcEarlyDecl def = + GC.modifyUserState (\s -> s {sDefs = DL.singleton def <> sDefs s}) + +ispcDef :: MC.DefSpecifier ISPCState +ispcDef s f = do + s' <- MC.multicoreName s + ispcDecl =<< f s' + pure s' + +-- | Expose a struct to both ISPC and C. +sharedDef :: MC.DefSpecifier ISPCState +sharedDef s f = do + s' <- MC.multicoreName s + ispcDecl =<< f s' + GC.earlyDecl =<< f s' + pure s' + +-- | Copy memory where one of the operands is using an AoS layout. +copyMemoryAOS :: + PrimType -> + C.Exp -> + C.Exp -> + C.Exp -> + C.Exp -> + C.Exp -> + GC.CompilerM op s () +copyMemoryAOS pt destmem destidx srcmem srcidx nbytes = + GC.stm + [C.cstm|if ($exp:nbytes > 0) { + $id:overload($exp:destmem + $exp:destidx, + $exp:srcmem + $exp:srcidx, + extract($exp:nbytes, 0)); + }|] + where + size = show (8 * primByteSize pt :: Integer) + overload = "memmove_" <> size + +-- | ISPC has no string literals, so this makes one in C and exposes it via an +-- external function, returning the name. +makeStringLiteral :: String -> ISPCCompilerM Name +makeStringLiteral str = do + name <- MC.multicoreDef "strlit_shim" $ \s -> + pure [C.cedecl|char* $id:s() { return $string:str; }|] + ispcDecl + [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform char* $tyqual:uniform $id:name();|] + pure name + +-- | Set memory in ISPC +setMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> ISPCCompilerM () +setMem dest src space = do + let src_s = pretty $ C.toExp src noLoc + strlit <- makeStringLiteral src_s + GC.stm + [C.cstm|if ($id:(GC.fatMemSet space)(ctx, &$exp:dest, &$exp:src, + $id:strlit()) != 0) { + $escstm:("unmasked { return 1; }") + }|] + +-- | Unref memory in ISPC +unRefMem :: C.ToExp a => a -> Space -> ISPCCompilerM () +unRefMem mem space = do + cached <- isJust <$> GC.cacheMem mem + let mem_s = pretty $ C.toExp mem noLoc + strlit <- makeStringLiteral mem_s + unless cached $ + GC.stm + [C.cstm|if ($id:(GC.fatMemUnRef space)(ctx, &$exp:mem, $id:strlit()) != 0) { + $escstm:("unmasked { return 1; }") + }|] + +-- | Allocate memory in ISPC +allocMem :: + (C.ToExp a, C.ToExp b) => + a -> + b -> + Space -> + C.Stm -> + ISPCCompilerM () +allocMem mem size space on_failure = do + let mem_s = pretty $ C.toExp mem noLoc + strlit <- makeStringLiteral mem_s + GC.stm + [C.cstm|if ($id:(GC.fatMemAlloc space)(ctx, &$exp:mem, $exp:size, + $id:strlit())) { + $stm:on_failure + }|] + +-- | Free memory in ISPC +freeAllocatedMem :: ISPCCompilerM [C.BlockItem] +freeAllocatedMem = GC.collect $ mapM_ (uncurry unRefMem) =<< gets GC.compDeclaredMem + +-- | Given a ImpCode function, generate all the required machinery for calling +-- it in ISPC, both in a varying or uniform context. This involves handling +-- for the fact that ISPC cannot pass structs by value to external functions. +compileBuiltinFun :: (Name, Function op) -> ISPCCompilerM () +compileBuiltinFun (fname, func@(Function _ outputs inputs _)) + | isNothing $ functionEntry func = do + let extra = [[C.cparam|$tyqual:uniform struct futhark_context * $tyqual:uniform ctx|]] + extra_c = [[C.cparam|struct futhark_context * ctx|]] + extra_exp = [[C.cexp|$id:p|] | C.Param (Just p) _ _ _ <- extra] + + (inparams_c, in_args_c) <- unzip <$> mapM (compileInputsExtern []) inputs + (outparams_c, out_args_c) <- unzip <$> mapM (compileOutputsExtern []) outputs + + (inparams_extern, _) <- unzip <$> mapM (compileInputsExtern [C.ctyquals|$tyqual:uniform|]) inputs + (outparams_extern, _) <- unzip <$> mapM (compileOutputsExtern [C.ctyquals|$tyqual:uniform|]) outputs + + (inparams_uni, in_args_noderef) <- unzip <$> mapM compileInputsUniform inputs + (outparams_uni, out_args_noderef) <- unzip <$> mapM compileOutputsUniform outputs + + (inparams_varying, in_args_vary, prebody_in') <- unzip3 <$> mapM compileInputsVarying inputs + (outparams_varying, out_args_vary, prebody_out', postbody_out') <- unzip4 <$> mapM compileOutputsVarying outputs + let (prebody_in, prebody_out, postbody_out) = over each concat (prebody_in', prebody_out', postbody_out') + + GC.libDecl + =<< pure + [C.cedecl|int $id:((funName fname) ++ "_extern")($params:extra_c, $params:outparams_c, $params:inparams_c) { + return $id:(funName fname)($args:extra_exp, $args:out_args_c, $args:in_args_c); + }|] + + let ispc_extern = + [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform int $id:((funName fname) ++ "_extern") + ($params:extra, $params:outparams_extern, $params:inparams_extern);|] + + ispc_uniform = + [C.cedecl|$tyqual:uniform int $id:(funName fname) + ($params:extra, $params:outparams_uni, $params:inparams_uni) { + return $id:(funName $ fname<>"_extern")( + $args:extra_exp, + $args:out_args_noderef, + $args:in_args_noderef); + }|] + + ispc_varying = + [C.cedecl|$tyqual:uniform int $id:(funName fname) + ($params:extra, $params:outparams_varying, $params:inparams_varying) { + $tyqual:uniform int err = 0; + $items:prebody_in + $items:prebody_out + $escstm:("foreach_active (i)") + { + err |= $id:(funName $ fname<>"_extern")( + $args:extra_exp, + $args:out_args_vary, + $args:in_args_vary); + } + $items:postbody_out + return err; + }|] + + mapM_ ispcEarlyDecl [ispc_varying, ispc_uniform, ispc_extern] + | otherwise = pure () + where + compileInputsExtern vari (ScalarParam name bt) = do + let ctp = GC.primTypeToCType bt + pure ([C.cparam|$tyquals:vari $ty:ctp $id:name|], [C.cexp|$id:name|]) + compileInputsExtern vari (MemParam name space) = do + ty <- GC.memToCType name space + pure ([C.cparam|$tyquals:vari $ty:ty * $tyquals:vari $id:name|], [C.cexp|*$id:name|]) + + compileOutputsExtern vari (ScalarParam name bt) = do + p_name <- newVName $ "out_" ++ baseString name + let ctp = GC.primTypeToCType bt + pure ([C.cparam|$tyquals:vari $ty:ctp * $tyquals:vari $id:p_name|], [C.cexp|$id:p_name|]) + compileOutputsExtern vari (MemParam name space) = do + ty <- GC.memToCType name space + p_name <- newVName $ baseString name ++ "_p" + pure ([C.cparam|$tyquals:vari $ty:ty * $tyquals:vari $id:p_name|], [C.cexp|$id:p_name|]) + + compileInputsUniform (ScalarParam name bt) = do + let ctp = GC.primTypeToCType bt + params = [C.cparam|$tyqual:uniform $ty:ctp $id:name|] + args = [C.cexp|$id:name|] + pure (params, args) + compileInputsUniform (MemParam name space) = do + ty <- GC.memToCType name space + let params = [C.cparam|$tyqual:uniform $ty:ty $id:name|] + args = [C.cexp|&$id:name|] + pure (params, args) + + compileOutputsUniform (ScalarParam name bt) = do + p_name <- newVName $ "out_" ++ baseString name + let ctp = GC.primTypeToCType bt + params = [C.cparam|$tyqual:uniform $ty:ctp *$tyqual:uniform $id:p_name|] + args = [C.cexp|$id:p_name|] + pure (params, args) + compileOutputsUniform (MemParam name space) = do + ty <- GC.memToCType name space + p_name <- newVName $ baseString name ++ "_p" + let params = [C.cparam|$tyqual:uniform $ty:ty $id:p_name|] + args = [C.cexp|&$id:p_name|] + pure (params, args) + + compileInputsVarying (ScalarParam name bt) = do + let ctp = GC.primTypeToCType bt + params = [C.cparam|$ty:ctp $id:name|] + args = [C.cexp|extract($id:name,i)|] + pre_body = [] + pure (params, args, pre_body) + compileInputsVarying (MemParam name space) = do + typ <- GC.memToCType name space + newvn <- newVName $ "aos_" <> baseString name + let params = [C.cparam|$ty:typ $id:name|] + args = [C.cexp|&$id:(newvn)[i]|] + pre_body = + [C.citems|$tyqual:uniform $ty:typ $id:(newvn)[programCount]; + $id:(newvn)[programIndex] = $id:name;|] + pure (params, args, pre_body) + + compileOutputsVarying (ScalarParam name bt) = do + p_name <- newVName $ "out_" ++ baseString name + deref_name <- newVName $ "aos_" ++ baseString name + vari_p_name <- newVName $ "convert_" ++ baseString name + let ctp = GC.primTypeToCType bt + pre_body = + [C.citems|$tyqual:varying $ty:ctp $id:vari_p_name = *$id:p_name; + $tyqual:uniform $ty:ctp $id:deref_name[programCount]; + $id:deref_name[programIndex] = $id:vari_p_name;|] + post_body = [C.citems|*$id:p_name = $id:(deref_name)[programIndex];|] + params = [C.cparam|$tyqual:varying $ty:ctp * $tyqual:uniform $id:p_name|] + args = [C.cexp|&$id:(deref_name)[i]|] + pure (params, args, pre_body, post_body) + compileOutputsVarying (MemParam name space) = do + typ <- GC.memToCType name space + newvn <- newVName $ "aos_" <> baseString name + let params = [C.cparam|$ty:typ $id:name|] + args = [C.cexp|&$id:(newvn)[i]|] + pre_body = + [C.citems|$tyqual:uniform $ty:typ $id:(newvn)[programCount]; + $id:(newvn)[programIndex] = $id:name;|] + pure (params, args, pre_body, []) + +-- | Handle logging an error message in ISPC. +handleError :: ErrorMsg Exp -> String -> ISPCCompilerM () +handleError msg stacktrace = do + -- Get format sting + (formatstr, formatargs) <- GC.errorMsgString msg + let formatstr' = "Error: " <> formatstr <> "\n\nBacktrace:\n%s" + -- Get args types and names for shim + let arg_types = errorMsgArgTypes msg + arg_names <- mapM (newVName . const "arg") arg_types + let params = zipWith (\ty name -> [C.cparam|$ty:(GC.primTypeToCType ty) $id:name|]) arg_types arg_names + let params_uni = zipWith (\ty name -> [C.cparam|$tyqual:uniform $ty:(GC.primTypeToCType ty) $id:name|]) arg_types arg_names + -- Make shim + let formatargs' = mapArgNames msg formatargs arg_names + shim <- MC.multicoreDef "assert_shim" $ \s -> do + pure + [C.cedecl|void $id:s(struct futhark_context* ctx, $params:params) { + if (ctx->error == NULL) + ctx->error = msgprintf($string:formatstr', $args:formatargs', $string:stacktrace); + }|] + ispcDecl + [C.cedecl|extern "C" $tyqual:unmasked void $id:shim($tyqual:uniform struct futhark_context* $tyqual:uniform, $params:params_uni);|] + -- Call the shim + args <- getErrorValExps msg + uni <- newVName "uni" + let args' = map (\x -> [C.cexp|extract($exp:x, $id:uni)|]) args + GC.items + [C.citems| + $escstm:("foreach_active(" <> pretty uni <> ")") + { + $id:shim(ctx, $args:args'); + err = FUTHARK_PROGRAM_ERROR; + } + $escstm:("unmasked { return err; }")|] + where + getErrorVal (ErrorString _) = Nothing + getErrorVal (ErrorVal _ v) = Just v + + getErrorValExps (ErrorMsg m) = mapM compileExp $ mapMaybe getErrorVal m + + mapArgNames' (x : xs) (y : ys) (t : ts) + | isJust $ getErrorVal x = [C.cexp|$id:t|] : mapArgNames' xs ys ts + | otherwise = y : mapArgNames' xs ys (t : ts) + mapArgNames' _ ys [] = ys + mapArgNames' _ _ _ = [] + + mapArgNames (ErrorMsg parts) = mapArgNames' parts + +-- | Given the name and type of a parameter, return the C type used to +-- represent it. We use uniform pointers to varying values for lexical +-- memory blocks, as this generally results in less gathers/scatters. +getMemType :: VName -> PrimType -> ISPCCompilerM C.Type +getMemType dest elemtype = do + cached <- isJust <$> GC.cacheMem dest + if cached + then pure [C.cty|$tyqual:varying $ty:(primStorageType elemtype)* uniform|] + else pure [C.cty|$ty:(primStorageType elemtype)*|] + +compileExp :: Exp -> ISPCCompilerM C.Exp +compileExp e@(ValueExp (FloatValue (Float64Value v))) = + if isInfinite v || isNaN v + then GC.compileExp e + else pure [C.cexp|$esc:(pretty v <> "d")|] +compileExp e@(ValueExp (FloatValue (Float16Value v))) = + if isInfinite v || isNaN v + then GC.compileExp e + else pure [C.cexp|$esc:(pretty v <> "f16")|] +compileExp (ValueExp val) = + pure $ C.toExp val mempty +compileExp (LeafExp v _) = + pure [C.cexp|$id:v|] +compileExp (UnOpExp Complement {} x) = do + x' <- compileExp x + pure [C.cexp|~$exp:x'|] +compileExp (UnOpExp Not {} x) = do + x' <- compileExp x + pure [C.cexp|!$exp:x'|] +compileExp (UnOpExp (FAbs Float32) x) = do + x' <- compileExp x + pure [C.cexp|(float)fabs($exp:x')|] +compileExp (UnOpExp (FAbs Float64) x) = do + x' <- compileExp x + pure [C.cexp|fabs($exp:x')|] +compileExp (UnOpExp SSignum {} x) = do + x' <- compileExp x + pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0)|] +compileExp (UnOpExp USignum {} x) = do + x' <- compileExp x + pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0) != 0|] +compileExp (UnOpExp op x) = do + x' <- compileExp x + pure [C.cexp|$id:(pretty op)($exp:x')|] +compileExp (CmpOpExp cmp x y) = do + x' <- compileExp x + y' <- compileExp y + pure $ case cmp of + CmpEq {} -> [C.cexp|$exp:x' == $exp:y'|] + FCmpLt {} -> [C.cexp|$exp:x' < $exp:y'|] + FCmpLe {} -> [C.cexp|$exp:x' <= $exp:y'|] + CmpLlt {} -> [C.cexp|$exp:x' < $exp:y'|] + CmpLle {} -> [C.cexp|$exp:x' <= $exp:y'|] + _ -> [C.cexp|$id:(pretty cmp)($exp:x', $exp:y')|] +compileExp (ConvOpExp conv x) = do + x' <- compileExp x + pure [C.cexp|$id:(pretty conv)($exp:x')|] +compileExp (BinOpExp bop x y) = do + x' <- compileExp x + y' <- compileExp y + pure $ case bop of + Add _ OverflowUndef -> [C.cexp|$exp:x' + $exp:y'|] + Sub _ OverflowUndef -> [C.cexp|$exp:x' - $exp:y'|] + Mul _ OverflowUndef -> [C.cexp|$exp:x' * $exp:y'|] + FAdd {} -> [C.cexp|$exp:x' + $exp:y'|] + FSub {} -> [C.cexp|$exp:x' - $exp:y'|] + FMul {} -> [C.cexp|$exp:x' * $exp:y'|] + FDiv {} -> [C.cexp|$exp:x' / $exp:y'|] + Xor {} -> [C.cexp|$exp:x' ^ $exp:y'|] + And {} -> [C.cexp|$exp:x' & $exp:y'|] + Or {} -> [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')|] +compileExp (FunExp h args _) = do + args' <- mapM compileExp args + pure [C.cexp|$id:(funName (nameFromString h))($args:args')|] + +-- | Compile a block of code with ISPC specific semantics, falling back +-- to generic C when this semantics is not needed. +-- All recursive constructors are duplicated here, since not doing so +-- would cause use to enter regular generic C codegen with no escape. +compileCode :: MCCode -> ISPCCompilerM () +compileCode (Comment s code) = do + xs <- GC.collect $ compileCode code + let comment = "// " ++ s + GC.stm + [C.cstm|$comment:comment + { $items:xs } + |] +compileCode (DeclareScalar name _ t) = do + let ct = GC.primTypeToCType t + quals <- getVariabilityQuals name + GC.decl [C.cdecl|$tyquals:quals $ty:ct $id:name;|] +compileCode (DeclareArray name DefaultSpace t vs) = do + name_realtype <- newVName $ baseString name ++ "_realtype" + let ct = GC.primTypeToCType t + case vs of + ArrayValues vs' -> do + let vs'' = [[C.cinit|$exp:v|] | v <- vs'] + GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs')] = {$inits:vs''};|] + ArrayZeros n -> + GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] + -- Fake a memory block. + GC.contextField + (C.toIdent name noLoc) + [C.cty|struct memblock|] + $ Just [C.cexp|(struct memblock){NULL, (char*)$id:name_realtype, 0}|] + -- Make an exported C shim to access it + shim <- MC.multicoreDef "get_static_array_shim" $ \f -> + pure [C.cedecl|struct memblock* $id:f(struct futhark_context* ctx) { return &ctx->$id:name; }|] + ispcDecl + [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform struct memblock * $tyqual:uniform + $id:shim($tyqual:uniform struct futhark_context* $tyqual:uniform ctx);|] + -- Call it + GC.item [C.citem|$tyqual:uniform struct memblock $id:name = *$id:shim(ctx);|] +compileCode (c1 :>>: c2) = go (GC.linearCode (c1 :>>: c2)) + where + go (DeclareScalar name _ t : SetScalar dest e : code) + | name == dest = do + let ct = GC.primTypeToCType t + e' <- compileExp e + quals <- getVariabilityQuals name + GC.item [C.citem|$tyquals:quals $ty:ct $id:name = $exp:e';|] + go code + go (x : xs) = compileCode x >> go xs + go [] = pure () +compileCode (Allocate name (Count (TPrimExp e)) space) = do + size <- compileExp e + cached <- GC.cacheMem name + case cached of + Just cur_size -> + GC.stm + [C.cstm|if ($exp:cur_size < $exp:size) { + err = lexical_realloc(futhark_get_error_ref(ctx), &$exp:name, &$exp:cur_size, $exp:size); + if (err != FUTHARK_SUCCESS) { + $escstm:("unmasked { return err; }") + } + }|] + _ -> + allocMem name size space [C.cstm|$escstm:("unmasked { return 1; }")|] +compileCode (SetMem dest src space) = + setMem dest src space +compileCode (Write dest (Count idx) elemtype DefaultSpace _ elemexp) + | isConstExp (untyped idx) = do + dest' <- GC.rawMem dest + idxexp <- compileExp (untyped idx) + varis <- mapM getVariability (namesToList $ freeIn idx) + let quals = if all (== Uniform) varis then [C.ctyquals|$tyqual:uniform|] else [] + tmp <- newVName "tmp_idx" + -- Disambiguate the variability of the constant index + GC.decl [C.cdecl|$tyquals:quals typename int64_t $id:tmp = $exp:idxexp;|] + deref <- + GC.derefPointer dest' [C.cexp|$id:tmp|] + <$> getMemType dest elemtype + elemexp' <- toStorage elemtype <$> compileExp elemexp + GC.stm [C.cstm|$exp:deref = $exp:elemexp';|] + | otherwise = do + dest' <- GC.rawMem dest + deref <- + GC.derefPointer dest' + <$> compileExp (untyped idx) + <*> getMemType dest elemtype + elemexp' <- toStorage elemtype <$> compileExp elemexp + GC.stm [C.cstm|$exp:deref = $exp:elemexp';|] + where + isConstExp = isSimple . constFoldPrimExp + isSimple (ValueExp _) = True + isSimple _ = False +compileCode (Read x src (Count iexp) restype DefaultSpace _) = do + src' <- GC.rawMem src + e <- + fmap (fromStorage restype) $ + GC.derefPointer src' + <$> compileExp (untyped iexp) + <*> getMemType src restype + GC.stm [C.cstm|$id:x = $exp:e;|] +compileCode code@(Copy pt dest (Count destoffset) DefaultSpace src (Count srcoffset) DefaultSpace (Count size)) = do + dm <- isJust <$> GC.cacheMem dest + sm <- isJust <$> GC.cacheMem src + if dm || sm + then + join $ + copyMemoryAOS pt + <$> GC.rawMem dest + <*> compileExp (untyped destoffset) + <*> GC.rawMem src + <*> compileExp (untyped srcoffset) + <*> compileExp (untyped size) + else GC.compileCode code +compileCode (Free name space) = do + cached <- isJust <$> GC.cacheMem name + unless cached $ unRefMem name space +compileCode (For i bound body) = do + let i' = C.toIdent i + t = GC.primTypeToCType $ primExpType bound + bound' <- compileExp bound + body' <- GC.collect $ compileCode body + quals <- getVariabilityQuals i + GC.stm + [C.cstm|for ($tyquals:quals $ty:t $id:i' = 0; $id:i' < $exp:bound'; $id:i'++) { + $items:body' + }|] +compileCode (While cond body) = do + cond' <- compileExp $ untyped cond + body' <- GC.collect $ compileCode body + GC.stm + [C.cstm|while ($exp:cond') { + $items:body' + }|] +compileCode (If cond tbranch fbranch) = do + cond' <- compileExp $ untyped cond + tbranch' <- GC.collect $ compileCode tbranch + fbranch' <- GC.collect $ compileCode fbranch + GC.stm $ case (tbranch', fbranch') of + (_, []) -> + [C.cstm|if ($exp:cond') { $items:tbranch' }|] + ([], _) -> + [C.cstm|if (!($exp:cond')) { $items:fbranch' }|] + _ -> + [C.cstm|if ($exp:cond') { $items:tbranch' } else { $items:fbranch' }|] +compileCode (Call dests fname args) = + defCallIspc dests fname =<< mapM compileArg args + where + compileArg (MemArg m) = pure [C.cexp|$exp:m|] + compileArg (ExpArg e) = compileExp e + defCallIspc dests' fname' args' = do + let out_args = [[C.cexp|&$id:d|] | d <- dests'] + args'' + | isBuiltInFunction fname' = args' + | otherwise = [C.cexp|ctx|] : out_args ++ args' + case dests' of + [d] + | isBuiltInFunction fname' -> + GC.stm [C.cstm|$id:d = $id:(funName fname')($args:args'');|] + _ -> + GC.item + [C.citem| + if ($id:(funName fname')($args:args'') != 0) { + $escstm:("unmasked { return 1; }") + }|] +compileCode (Assert e msg (loc, locs)) = do + e' <- compileExp e + err <- GC.collect $ handleError msg stacktrace + GC.stm [C.cstm|if (!$exp:e') { $items:err }|] + where + stacktrace = prettyStacktrace 0 $ map locStr $ loc : locs +compileCode code = + GC.compileCode code + +-- | Prepare a struct with memory allocted in the scope and populate +-- its fields with values +prepareMemStruct :: [(VName, VName)] -> [VName] -> ISPCCompilerM Name +prepareMemStruct lexmems fatmems = do + let lex_defs = concatMap lexMemDef lexmems + let fat_defs = map fatMemDef fatmems + name <- ispcDef "mem_struct" $ \s -> do + pure + [C.cedecl|struct $id:s { + $sdecls:lex_defs + $sdecls:fat_defs + };|] + let name' = name <> "_" + GC.decl [C.cdecl|$tyqual:uniform struct $id:name $id:name';|] + forM_ (concatMap (\(a, b) -> [a, b]) lexmems) $ \m -> + GC.stm [C.cstm|$id:name'.$id:m = $id:m;|] + forM_ fatmems $ \m -> + GC.stm [C.cstm|$id:name'.$id:m = &$id:m;|] + pure name + where + lexMemDef (name, size) = + [ [C.csdecl|$tyqual:varying unsigned char * $tyqual:uniform $id:name;|], + [C.csdecl|$tyqual:varying size_t $id:size;|] + ] + fatMemDef name = + [C.csdecl|$tyqual:varying struct memblock * $tyqual:uniform $id:name;|] + +-- | Get memory from the memory struct into local variables +compileGetMemStructVals :: Name -> [(VName, VName)] -> [VName] -> ISPCCompilerM () +compileGetMemStructVals struct lexmems fatmems = do + forM_ fatmems $ \m -> + GC.decl [C.cdecl|struct memblock $id:m = *$id:struct->$id:m;|] + forM_ lexmems $ \(m, s) -> do + GC.decl [C.cdecl|$tyqual:varying unsigned char * $tyqual:uniform $id:m = $id:struct->$id:m;|] + GC.decl [C.cdecl|size_t $id:s = $id:struct->$id:s;|] + +-- | Write back potentially changed memory addresses and sizes to the memory struct +compileWritebackMemStructVals :: Name -> [(VName, VName)] -> [VName] -> ISPCCompilerM () +compileWritebackMemStructVals struct lexmems fatmems = do + forM_ fatmems $ \m -> + GC.stm [C.cstm|*$id:struct->$id:m = $id:m;|] + forM_ lexmems $ \(m, s) -> do + GC.stm [C.cstm|$id:struct->$id:m = $id:m;|] + GC.stm [C.cstm|$id:struct->$id:s = $id:s;|] + +-- | Read back potentially changed memory addresses and sizes to the memory struct into local variables +compileReadbackMemStructVals :: Name -> [(VName, VName)] -> [VName] -> ISPCCompilerM () +compileReadbackMemStructVals struct lexmems fatmems = do + forM_ fatmems $ \m -> + GC.stm [C.cstm|$id:m = *$id:struct.$id:m;|] + forM_ lexmems $ \(m, s) -> do + GC.stm [C.cstm|$id:m = $id:struct.$id:m;|] + GC.stm [C.cstm|$id:s = $id:struct.$id:s;|] + +compileGetStructVals :: + Name -> + [VName] -> + [(C.Type, MC.ValueType)] -> + ISPCCompilerM [C.BlockItem] +compileGetStructVals struct a b = concat <$> zipWithM field a b + where + struct' = struct <> "_" + field name (ty, MC.Prim pt) = do + let inner = [C.cexp|$id:struct'->$id:(MC.closureFreeStructField name)|] + pure [C.citems|$tyqual:uniform $ty:ty $id:name = $exp:(fromStorage pt inner);|] + field name (_, _) = do + strlit <- makeStringLiteral $ pretty name + pure + [C.citems|$tyqual:uniform struct memblock $id:name; + $id:name.desc = $id:strlit(); + $id:name.mem = $id:struct'->$id:(MC.closureFreeStructField name); + $id:name.size = 0; + $id:name.references = NULL;|] + +-- | Can the given code produce an error? If so, we can't use foreach +-- loops, since they don't allow for early-outs in error handling. +mayProduceError :: MCCode -> Bool +mayProduceError (x :>>: y) = mayProduceError x || mayProduceError y +mayProduceError (If _ x y) = mayProduceError x || mayProduceError y +mayProduceError (For _ _ x) = mayProduceError x +mayProduceError (While _ x) = mayProduceError x +mayProduceError (Comment _ x) = mayProduceError x +mayProduceError (Op (ForEachActive _ body)) = mayProduceError body +mayProduceError (Op (ForEach _ _ _ body)) = mayProduceError body +mayProduceError (Op SegOp {}) = True +mayProduceError Allocate {} = True +mayProduceError Assert {} = True +mayProduceError SetMem {} = True +mayProduceError Free {} = True +mayProduceError Call {} = True +mayProduceError _ = False + +-- Generate a segop function for top_level and potentially nested SegOp code +compileOp :: GC.OpCompiler Multicore ISPCState +compileOp (SegOp name params seq_task par_task retvals (SchedulerInfo e sched)) = do + let (ParallelTask seq_code) = seq_task + free_ctypes <- mapM MC.paramToCType params + retval_ctypes <- mapM MC.paramToCType retvals + let free_args = map paramName params + retval_args = map paramName retvals + free = zip free_args free_ctypes + retval = zip retval_args retval_ctypes + + e' <- compileExp e + + let lexical = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] params seq_code + + fstruct <- + MC.prepareTaskStruct sharedDef "task" free_args free_ctypes retval_args retval_ctypes + + fpar_task <- MC.generateParLoopFn lexical (name ++ "_task") seq_code fstruct free retval + MC.addTimingFields fpar_task + + let ftask_name = fstruct <> "_task" + + to_c <- GC.collect $ do + GC.decl [C.cdecl|struct scheduler_segop $id:ftask_name;|] + GC.stm [C.cstm|$id:ftask_name.args = args;|] + GC.stm [C.cstm|$id:ftask_name.top_level_fn = $id:fpar_task;|] + GC.stm [C.cstm|$id:ftask_name.name = $string:(nameToString fpar_task);|] + GC.stm [C.cstm|$id:ftask_name.iterations = iterations;|] + -- Create the timing fields for the task + GC.stm [C.cstm|$id:ftask_name.task_time = &ctx->$id:(MC.functionTiming fpar_task);|] + GC.stm [C.cstm|$id:ftask_name.task_iter = &ctx->$id:(MC.functionIterations fpar_task);|] + + case sched of + Dynamic -> GC.stm [C.cstm|$id:ftask_name.sched = DYNAMIC;|] + Static -> GC.stm [C.cstm|$id:ftask_name.sched = STATIC;|] + + -- Generate the nested segop function if available + fnpar_task <- case par_task of + Just (ParallelTask nested_code) -> do + let lexical_nested = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] params nested_code + fnpar_task <- MC.generateParLoopFn lexical_nested (name ++ "_nested_task") nested_code fstruct free retval + GC.stm [C.cstm|$id:ftask_name.nested_fn = $id:fnpar_task;|] + pure $ zip [fnpar_task] [True] + Nothing -> do + GC.stm [C.cstm|$id:ftask_name.nested_fn=NULL;|] + pure mempty + + GC.stm [C.cstm|return scheduler_prepare_task(&ctx->scheduler, &$id:ftask_name);|] + + -- Add profile fields for -P option + mapM_ GC.profileReport $ MC.multiCoreReport $ (fpar_task, True) : fnpar_task + + schedn <- MC.multicoreDef "schedule_shim" $ \s -> + pure + [C.cedecl|int $id:s(struct futhark_context* ctx, void* args, typename int64_t iterations) { + $items:to_c + }|] + + ispcDecl + [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform int $id:schedn + (struct futhark_context $tyqual:uniform * $tyqual:uniform ctx, + struct $id:fstruct $tyqual:uniform * $tyqual:uniform args, + $tyqual:uniform int iterations);|] + + aos_name <- newVName "aos" + GC.items + [C.citems| + $escstm:("#if ISPC") + $tyqual:uniform struct $id:fstruct $id:aos_name[programCount]; + $id:aos_name[programIndex] = $id:(fstruct <> "_"); + $escstm:("foreach_active (i)") + { + if (err == 0) { + err = $id:schedn(ctx, &$id:aos_name[i], extract($exp:e', i)); + } + } + if (err != 0) { + $escstm:("unmasked { return err; }") + } + $escstm:("#else") + err = $id:schedn(ctx, &$id:(fstruct <> "_"), $exp:e'); + if (err != 0) { + goto cleanup; + } + $escstm:("#endif")|] +compileOp (ISPCKernel body free) = do + free_ctypes <- mapM MC.paramToCType free + let free_args = map paramName free + + let lexical = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] free body + -- Generate ISPC kernel + fstruct <- MC.prepareTaskStruct sharedDef "param_struct" free_args free_ctypes [] [] + let fstruct' = fstruct <> "_" + + ispcShim <- ispcDef "loop_ispc" $ \s -> do + mainBody <- GC.inNewFunction $ + analyzeVariability body $ + cachingMemory lexical $ \decl_cached free_cached lexmems -> + GC.collect $ do + GC.decl [C.cdecl|$tyqual:uniform struct futhark_context * $tyqual:uniform ctx = $id:fstruct'->ctx;|] + GC.items =<< compileGetStructVals fstruct free_args free_ctypes + body' <- GC.collect $ compileCode body + mapM_ GC.item decl_cached + mapM_ GC.item =<< GC.declAllocatedMem + + -- Make inner kernel for error handling, if needed + if mayProduceError body + then do + fatmems <- gets (map fst . GC.compDeclaredMem) + mstruct <- prepareMemStruct lexmems fatmems + let mstruct' = mstruct <> "_" + innerShim <- ispcDef "inner_ispc" $ \t -> do + innerBody <- GC.collect $ do + GC.decl [C.cdecl|$tyqual:uniform struct futhark_context * $tyqual:uniform ctx = $id:fstruct'->ctx;|] + GC.items =<< compileGetStructVals fstruct free_args free_ctypes + compileGetMemStructVals mstruct' lexmems fatmems + GC.decl [C.cdecl|$tyqual:uniform int err = 0;|] + mapM_ GC.item body' + compileWritebackMemStructVals mstruct' lexmems fatmems + GC.stm [C.cstm|return err;|] + pure + [C.cedecl| + static $tyqual:unmasked inline $tyqual:uniform int $id:t( + $tyqual:uniform typename int64_t start, + $tyqual:uniform typename int64_t end, + struct $id:fstruct $tyqual:uniform * $tyqual:uniform $id:fstruct', + struct $id:mstruct $tyqual:uniform * $tyqual:uniform $id:mstruct') { + $items:innerBody + }|] + -- Call the kernel and read back potentially changed memory + GC.decl [C.cdecl|$tyqual:uniform int err = $id:innerShim(start, end, $id:fstruct', &$id:mstruct');|] + compileReadbackMemStructVals mstruct' lexmems fatmems + else do + GC.decl [C.cdecl|$tyqual:uniform int err = 0;|] + mapM_ GC.item body' + + free_mem <- freeAllocatedMem + GC.stm [C.cstm|cleanup: {$stms:free_cached $items:free_mem}|] + GC.stm [C.cstm|return err;|] + GC.earlyDecl + [C.cedecl|int $id:s(typename int64_t start, + typename int64_t end, + struct $id:fstruct * $id:fstruct');|] + pure + [C.cedecl| + $tyqual:export $tyqual:uniform int $id:s($tyqual:uniform typename int64_t start, + $tyqual:uniform typename int64_t end, + struct $id:fstruct $tyqual:uniform * $tyqual:uniform $id:fstruct' ) { + $items:mainBody + }|] + + -- Generate C code to call into ISPC kernel + GC.items + [C.citems| + err = $id:ispcShim(start, end, & $id:fstruct'); + if (err != 0) { + goto cleanup; + }|] +compileOp (ForEach i from bound body) = do + from' <- compileExp from + bound' <- compileExp bound + body' <- GC.collect $ compileCode body + if mayProduceError body + then + GC.stms + [C.cstms| + for ($tyqual:uniform typename int64_t i = 0; i < (($exp:bound' - $exp:from') / programCount); i++) { + typename int64_t $id:i = $exp:from' + programIndex + i * programCount; + $items:body' + } + if (programIndex < (($exp:bound' - $exp:from') % programCount)) { + typename int64_t $id:i = $exp:from' + programIndex + ((($exp:bound' - $exp:from') / programCount) * programCount); + $items:body' + }|] + else + GC.stms + [C.cstms| + $escstm:("foreach (" <> pretty i <> " = " <> pretty from' <> " ... " <> pretty bound' <> ")") { + $items:body' + }|] +compileOp (ForEachActive name body) = do + body' <- GC.collect $ compileCode body + GC.stms + [C.cstms| + for ($tyqual:uniform unsigned int $id:name = 0; $id:name < programCount; $id:name++) { + if (programIndex == $id:name) { + $items:body' + } + }|] +compileOp (ExtractLane dest tar lane) = do + tar' <- compileExp tar + lane' <- compileExp lane + GC.stm [C.cstm|$id:dest = extract($exp:tar', $exp:lane');|] +compileOp (Atomic aop) = + MC.atomicOps aop $ \ty arr -> do + cached <- isJust <$> GC.cacheMem arr + if cached + then pure [C.cty|$tyqual:varying $ty:ty* $tyqual:uniform|] + else pure [C.cty|$ty:ty*|] +compileOp op = MC.compileOp op + +-- | Like @GenericC.cachingMemory@, but adapted for ISPC codegen. +cachingMemory :: + M.Map VName Space -> + ([C.BlockItem] -> [C.Stm] -> [(VName, VName)] -> GC.CompilerM op s a) -> + GC.CompilerM op s a +cachingMemory lexical f = do + let cached = M.keys $ M.filter (== DefaultSpace) lexical + + cached' <- forM cached $ \mem -> do + size <- newVName $ pretty mem <> "_cached_size" + pure (mem, size) + + let lexMem env = + env + { GC.envCachedMem = + M.fromList (map (first (`C.toExp` noLoc)) cached') + <> GC.envCachedMem env + } + + declCached (mem, size) = + [ [C.citem|size_t $id:size = 0;|], + [C.citem|$tyqual:varying unsigned char * $tyqual:uniform $id:mem = NULL;|] + ] + + freeCached (mem, _) = + [C.cstm|free($id:mem);|] + + local lexMem $ f (concatMap declCached cached') (map freeCached cached') cached' + +-- Variability analysis +type Dependencies = M.Map VName Names + +data Variability = Uniform | Varying + deriving (Eq, Ord, Show) + +newtype VariabilityM a + = VariabilityM (ReaderT Names (State Dependencies) a) + deriving + ( Functor, + Applicative, + Monad, + MonadState Dependencies, + MonadReader Names + ) + +execVariabilityM :: VariabilityM a -> Dependencies +execVariabilityM (VariabilityM m) = + execState (runReaderT m mempty) mempty + +-- | Extend the set of dependencies with a new one +addDeps :: VName -> Names -> VariabilityM () +addDeps v ns = do + deps <- get + env <- ask + case M.lookup v deps of + Nothing -> put $ M.insert v (ns <> env) deps + Just ns' -> put $ M.insert v (ns <> ns') deps + +-- | Find all the dependencies in a body of code +findDeps :: MCCode -> VariabilityM () +findDeps (x :>>: y) = do + findDeps x + findDeps y +findDeps (If cond x y) = + local (<> freeIn cond) $ do + findDeps x + findDeps y +findDeps (For idx bound x) = do + addDeps idx free + local (<> free) $ findDeps x + where + free = freeIn bound +findDeps (While cond x) = do + local (<> freeIn cond) $ findDeps x +findDeps (Comment _ x) = + findDeps x +findDeps (Op (SegOp _ free _ _ retvals _)) = + mapM_ + ( \x -> + addDeps (paramName x) $ + namesFromList $ + map paramName free + ) + retvals +findDeps (Op (ForEach _ _ _ body)) = + findDeps body +findDeps (Op (ForEachActive _ body)) = + findDeps body +findDeps (SetScalar name e) = + addDeps name $ freeIn e +findDeps (Call tars _ args) = + mapM_ (\x -> addDeps x $ freeIn args) tars +findDeps (Read x arr (Count iexp) _ DefaultSpace _) = do + addDeps x $ freeIn (untyped iexp) + addDeps x $ oneName arr +findDeps (Op (GetLoopBounds x y)) = do + addDeps x mempty + addDeps y mempty +findDeps (Op (ExtractLane x _ _)) = do + addDeps x mempty +findDeps (Op (Atomic (AtomicCmpXchg _ old arr ind res val))) = do + addDeps res $ freeIn arr <> freeIn ind <> freeIn val + addDeps old $ freeIn arr <> freeIn ind <> freeIn val +findDeps _ = pure () + +-- | Take a list of dependencies and iterate them to a fixed point. +depsFixedPoint :: Dependencies -> Dependencies +depsFixedPoint deps = + if deps == deps' + then deps + else depsFixedPoint deps' + where + grow names = + names <> foldMap (\n -> M.findWithDefault mempty n deps) (namesIntMap names) + deps' = M.map grow deps + +-- | Find roots of variance. These are memory blocks declared in +-- the current scope as well as loop indices of foreach loops. +findVarying :: MCCode -> [VName] +findVarying (x :>>: y) = findVarying x ++ findVarying y +findVarying (If _ x y) = findVarying x ++ findVarying y +findVarying (For _ _ x) = findVarying x +findVarying (While _ x) = findVarying x +findVarying (Comment _ x) = findVarying x +findVarying (Op (ForEachActive _ body)) = findVarying body +findVarying (Op (ForEach idx _ _ body)) = idx : findVarying body +findVarying (DeclareMem mem _) = [mem] +findVarying _ = [] + +-- | Analyze variability in a body of code and run an action with +-- info about that variability in the compiler state. +analyzeVariability :: MCCode -> ISPCCompilerM a -> ISPCCompilerM a +analyzeVariability code m = do + let roots = findVarying code + let deps = depsFixedPoint $ execVariabilityM $ findDeps code + let safelist = M.filter (\b -> all (`notNameIn` b) roots) deps + let safe = namesFromList $ M.keys safelist + pre_state <- GC.getUserState + GC.modifyUserState (\s -> s {sUniform = safe}) + a <- m + GC.modifyUserState (\s -> s {sUniform = sUniform pre_state}) + pure a + +-- | Get the variability of a variable +getVariability :: VName -> ISPCCompilerM Variability +getVariability name = do + uniforms <- sUniform <$> GC.getUserState + pure $ + if name `nameIn` uniforms + then Uniform + else Varying + +-- | Get the variability qualifiers of a variable +getVariabilityQuals :: VName -> ISPCCompilerM [C.TypeQual] +getVariabilityQuals name = variQuals <$> getVariability name + where + variQuals Uniform = [C.ctyquals|$tyqual:uniform|] + variQuals Varying = [] diff --git a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs --- a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs @@ -43,7 +43,7 @@ Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String])) compileProg version prog = do - (ws, prog') <- ImpGen.compileProg ImpGen.AllowDynamicScheduling prog + (ws, prog') <- ImpGen.compileProg prog prog'' <- GC.compileProg @@ -52,7 +52,7 @@ MC.operations MC.generateContext "" - [DefaultSpace] + (DefaultSpace, [DefaultSpace]) MC.cliOptions prog' @@ -67,12 +67,12 @@ fRepMyRep :: Imp.Definitions Imp.Multicore -> [JSEntryPoint] fRepMyRep prog = let Imp.Functions fs = Imp.defFuns prog - function (Imp.Function entry _ _ _ res args) = do - n <- entry + function (Imp.Function entry _ _ _) = do + Imp.EntryPoint n res args <- entry Just $ JSEntryPoint { name = nameToString n, parameters = map (extToString . snd) args, - ret = map extToString res + ret = map (extToString . snd) 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 @@ -43,15 +43,15 @@ ImpGen.compileProg prog -- prepare the strings for assigning the kernels and set them as global let assign = - unlines $ - map + unlines + $ map ( \x -> pretty $ Assign (Var ("self." ++ zEncodeString (nameToString x) ++ "_var")) (Var $ "program." ++ zEncodeString (nameToString x)) ) - $ M.keys kernels + $ M.keys kernels let defines = [ Assign (Var "synchronous") $ Bool False, @@ -206,7 +206,8 @@ v' <- Py.compileVar v Py.stm $ Assign v' $ - Var $ "self.max_" ++ pretty size_class + Var $ + "self.max_" ++ pretty size_class callKernel (Imp.LaunchKernel safety name args num_workgroups workgroup_size) = do num_workgroups' <- mapM (fmap asLong . Py.compileExp) num_workgroups workgroup_size' <- mapM (fmap asLong . Py.compileExp) workgroup_size @@ -408,7 +409,8 @@ -- Store the memory block for later reference. Py.stm $ Assign (Field (Var "self") name') $ - Var $ Py.compileName static_mem + Var $ + Py.compileName static_mem Py.stm $ Assign (Var name') (Field (Var "self") name') where 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 @@ -115,7 +115,8 @@ what' = Lambda "device" $ runIdentity $ - Py.compilePrimExp onLeaf $ untyped what + Py.compilePrimExp onLeaf $ + untyped what onLeaf (DeviceInfo s) = pure $ 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 @@ -25,7 +25,7 @@ compileProg :: MonadFreshNames m => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, GC.CParts) compileProg version = traverse - (GC.compileProg "c" version operations generateBoilerplate mempty [DefaultSpace] []) + (GC.compileProg "c" version operations generateBoilerplate mempty (DefaultSpace, [DefaultSpace]) []) <=< ImpGen.compileProg where operations :: GC.Operations Imp.Sequential () diff --git a/src/Futhark/CodeGen/Backends/SequentialWASM.hs b/src/Futhark/CodeGen/Backends/SequentialWASM.hs --- a/src/Futhark/CodeGen/Backends/SequentialWASM.hs +++ b/src/Futhark/CodeGen/Backends/SequentialWASM.hs @@ -48,7 +48,7 @@ operations generateBoilerplate "" - [DefaultSpace] + (DefaultSpace, [DefaultSpace]) [] prog' pure (ws, (prog'', javascriptWrapper (fRepMyRep prog'), emccExportNames (fRepMyRep prog'))) @@ -62,12 +62,12 @@ fRepMyRep :: Imp.Program -> [JSEntryPoint] fRepMyRep prog = let Imp.Functions fs = Imp.defFuns prog - function (Imp.Function entry _ _ _ res args) = do - n <- entry + function (Imp.Function entry _ _ _) = do + Imp.EntryPoint n res args <- entry Just $ JSEntryPoint { name = nameToString n, parameters = map (extToString . snd) args, - ret = map extToString res + ret = map (extToString . snd) 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 @@ -78,8 +78,8 @@ -- | The C API corresponding to a primitive type. Integers are -- assumed to have the specified sign. primAPIType :: Signedness -> PrimType -> C.Type -primAPIType TypeUnsigned (IntType t) = uintTypeToCType t -primAPIType TypeDirect (IntType t) = intTypeToCType t +primAPIType Unsigned (IntType t) = uintTypeToCType t +primAPIType Signed (IntType t) = intTypeToCType t primAPIType _ t = primStorageType t -- | Convert from scalar to storage representation for the given type. @@ -108,11 +108,12 @@ -- | The name of exposed array type structs. arrayName :: PrimType -> Signedness -> Int -> String arrayName pt signed rank = - prettySigned (signed == TypeUnsigned) pt ++ "_" ++ show rank ++ "d" + prettySigned (signed == Unsigned) pt ++ "_" ++ show rank ++ "d" -- | The name of exposed opaque types. -opaqueName :: String -> [ValueDesc] -> String -opaqueName s _ +opaqueName :: String -> String +opaqueName "()" = "opaque_unit" -- Hopefully this ad-hoc convenience won't bite us. +opaqueName s | valid = "opaque_" ++ s where valid = @@ -120,18 +121,15 @@ && not (isDigit $ head s) && all ok s ok c = isAlphaNum c || c == '_' -opaqueName s vds = "opaque_" ++ hash (zipWith xor [0 ..] $ map ord (s ++ concatMap p vds)) +opaqueName s = "opaque_" ++ hash (zipWith xor [0 ..] $ map ord s) where - p (ScalarValue pt signed _) = - show (pt, signed) - p (ArrayValue _ space pt signed dims) = - show (space, pt, signed, length dims) - -- FIXME: a stupid hash algorithm; may have collisions. hash = - printf "%x" . foldl xor 0 + printf "%x" + . foldl xor 0 . map - ( iter . (* 0x45d9f3b) + ( iter + . (* 0x45d9f3b) . iter . (* 0x45d9f3b) . iter @@ -142,18 +140,18 @@ -- | The 'PrimType' (and sign) correspond to a human-readable scalar -- type name (e.g. @f64@). Beware: partial! scalarToPrim :: T.Text -> (Signedness, PrimType) -scalarToPrim "bool" = (TypeDirect, Bool) -scalarToPrim "i8" = (TypeDirect, IntType Int8) -scalarToPrim "i16" = (TypeDirect, IntType Int16) -scalarToPrim "i32" = (TypeDirect, IntType Int32) -scalarToPrim "i64" = (TypeDirect, IntType Int64) -scalarToPrim "u8" = (TypeUnsigned, IntType Int8) -scalarToPrim "u16" = (TypeUnsigned, IntType Int16) -scalarToPrim "u32" = (TypeUnsigned, IntType Int32) -scalarToPrim "u64" = (TypeUnsigned, IntType Int64) -scalarToPrim "f16" = (TypeDirect, FloatType Float16) -scalarToPrim "f32" = (TypeDirect, FloatType Float32) -scalarToPrim "f64" = (TypeDirect, FloatType Float64) +scalarToPrim "bool" = (Signed, Bool) +scalarToPrim "i8" = (Signed, IntType Int8) +scalarToPrim "i16" = (Signed, IntType Int16) +scalarToPrim "i32" = (Signed, IntType Int32) +scalarToPrim "i64" = (Signed, IntType Int64) +scalarToPrim "u8" = (Unsigned, IntType Int8) +scalarToPrim "u16" = (Unsigned, IntType Int16) +scalarToPrim "u32" = (Unsigned, IntType Int32) +scalarToPrim "u64" = (Unsigned, IntType Int64) +scalarToPrim "f16" = (Signed, FloatType Float16) +scalarToPrim "f32" = (Signed, FloatType Float32) +scalarToPrim "f64" = (Signed, FloatType Float64) scalarToPrim tname = error $ "scalarToPrim: " <> T.unpack tname -- | Return an expression multiplying together the given expressions. @@ -251,14 +249,14 @@ (_, FloatType Float16) -> " f16" (_, FloatType Float32) -> " f32" (_, FloatType Float64) -> " f64" - (TypeDirect, IntType Int8) -> " i8" - (TypeDirect, IntType Int16) -> " i16" - (TypeDirect, IntType Int32) -> " i32" - (TypeDirect, IntType Int64) -> " i64" - (TypeUnsigned, IntType Int8) -> " u8" - (TypeUnsigned, IntType Int16) -> " u16" - (TypeUnsigned, IntType Int32) -> " u32" - (TypeUnsigned, IntType Int64) -> " u64" + (Signed, IntType Int8) -> " i8" + (Signed, IntType Int16) -> " i16" + (Signed, IntType Int32) -> " i32" + (Signed, IntType Int64) -> " i64" + (Unsigned, IntType Int8) -> " u8" + (Unsigned, IntType Int16) -> " u16" + (Unsigned, IntType Int32) -> " u32" + (Unsigned, IntType Int64) -> " u64" -- | Produce code for storing the header (everything besides the -- actual payload) for a value of this type. 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 @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} {-# LANGUAGE TupleSections #-} @@ -57,17 +58,14 @@ Functions (..), Function, FunctionT (..), + EntryPoint (..), Constants (..), ValueDesc (..), - Signedness (..), ExternalValue (..), Param (..), paramName, - SubExp (..), MemSize, DimSize, - Space (..), - SpaceId, Code (..), PrimValue (..), Exp, @@ -75,9 +73,6 @@ Volatility (..), Arg (..), var, - ErrorMsg (..), - ErrorMsgPart (..), - errorMsgArgTypes, ArrayContents (..), declaredIn, lexicalMemoryUsage, @@ -92,8 +87,9 @@ -- * Re-exports from other modules. pretty, + module Futhark.IR.Syntax.Core, module Language.Futhark.Core, - module Futhark.IR.Primitive, + module Language.Futhark.Primitive, module Futhark.Analysis.PrimExp, module Futhark.Analysis.PrimExp.Convert, module Futhark.IR.GPU.Sizes, @@ -109,18 +105,24 @@ import Futhark.Analysis.PrimExp.Convert import Futhark.IR.GPU.Sizes (Count (..)) import Futhark.IR.Pretty () -import Futhark.IR.Primitive import Futhark.IR.Prop.Names import Futhark.IR.Syntax.Core - ( ErrorMsg (..), + ( EntryPointType (..), + ErrorMsg (..), ErrorMsgPart (..), + OpaqueType (..), + OpaqueTypes (..), + Rank (..), + Signedness (..), Space (..), SpaceId, SubExp (..), + ValueType (..), errorMsgArgTypes, ) import Futhark.Util.Pretty hiding (space) import Language.Futhark.Core +import Language.Futhark.Primitive -- | The size of a memory block. type MemSize = SubExp @@ -141,13 +143,15 @@ -- | A collection of imperative functions and constants. data Definitions a = Definitions - { defConsts :: Constants a, + { defTypes :: OpaqueTypes, + defConsts :: Constants a, defFuns :: Functions a } deriving (Show) instance Functor Definitions where - fmap f (Definitions consts funs) = Definitions (fmap f consts) (fmap f funs) + fmap f (Definitions types consts funs) = + Definitions types (fmap f consts) (fmap f funs) -- | A collection of imperative functions. newtype Functions a = Functions [(Name, Function a)] @@ -172,15 +176,6 @@ 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 --- indicate whether they are really unsigned integers. -data Signedness - = TypeUnsigned - | TypeDirect - deriving (Eq, Ord, Show) - -- | A description of an externally meaningful value. data ValueDesc = -- | An array with memory block memory space, element type, @@ -197,22 +192,27 @@ data ExternalValue = -- | The string is a human-readable description with no other -- semantics. - -- not matter. - OpaqueValue Uniqueness String [ValueDesc] - | TransparentValue Uniqueness ValueDesc + OpaqueValue String [ValueDesc] + | TransparentValue ValueDesc deriving (Show) +-- | Information about how this function can be called from the outside world. +data EntryPoint = EntryPoint + { entryPointName :: Name, + entryPointResults :: [(Uniqueness, ExternalValue)], + entryPointArgs :: [((Name, Uniqueness), ExternalValue)] + } + deriving (Show) + -- | A imperative function, containing the body as well as its -- low-level inputs and outputs, as well as its high-level arguments --- and results. The latter are only used if the function is an entry +-- and results. The latter are only present if the function is an entry -- point. data FunctionT a = Function - { functionEntry :: Maybe Name, + { functionEntry :: Maybe EntryPoint, functionOutput :: [Param], functionInput :: [Param], - functionBody :: Code a, - functionResult :: [ExternalValue], - functionArgs :: [(Name, ExternalValue)] + functionBody :: Code a } deriving (Show) @@ -347,8 +347,9 @@ -- to 'SetMem' a memory block declared outside it. lexicalMemoryUsage :: Function a -> M.Map VName Space lexicalMemoryUsage func = - M.filterWithKey (const . not . (`nameIn` nonlexical)) $ - declared $ functionBody func + M.filterWithKey (const . (`notNameIn` nonlexical)) $ + declared $ + functionBody func where nonlexical = set (functionBody func) @@ -424,119 +425,139 @@ -- Prettyprinting definitions. instance Pretty op => Pretty (Definitions op) where - ppr (Definitions consts funs) = - ppr consts ppr funs + ppr (Definitions types consts funs) = + ppr types ppr consts ppr funs instance Pretty op => Pretty (Functions op) where ppr (Functions funs) = stack $ intersperse mempty $ map ppFun funs where ppFun (name, fun) = - text "Function " <> ppr name <> colon indent 2 (ppr fun) + "Function " <> ppr name <> colon indent 2 (ppr fun) instance Pretty op => Pretty (Constants op) where ppr (Constants decls code) = - text "Constants:" indent 2 (stack $ map ppr decls) + "Constants:" + indent 2 (stack $ map ppr decls) mempty - text "Initialisation:" + "Initialisation:" indent 2 (ppr code) +instance Pretty EntryPoint where + ppr (EntryPoint name results args) = + "Name:" + indent 2 (pquote (ppr name)) + "Arguments:" + indent 2 (stack $ map ppArg args) + "Results:" + indent 2 (stack $ map ppRes results) + where + ppArg ((p, u), t) = ppr p <+> ":" <+> ppRes (u, t) + ppRes (u, t) = ppr u <> ppr t + instance Pretty op => Pretty (FunctionT op) where - ppr (Function _ outs ins body results args) = - text "Inputs:" block ins - text "Outputs:" - block outs - text "Arguments:" - block args - text "Result:" - block results - text "Body:" + ppr (Function entry outs ins body) = + "Inputs:" + indent 2 (stack $ map ppr ins) + "Outputs:" + indent 2 (stack $ map ppr outs) + "Entry:" + indent 2 (ppr entry) + "Body:" indent 2 (ppr body) - where - block :: Pretty a => [a] -> Doc - block = indent 2 . stack . map ppr instance Pretty Param where ppr (ScalarParam name ptype) = ppr ptype <+> ppr name - ppr (MemParam name space) = text "mem" <> ppr space <> text " " <> ppr name + ppr (MemParam name space) = "mem" <> ppr space <> " " <> ppr name instance Pretty ValueDesc where ppr (ScalarValue t ept name) = ppr t <+> ppr name <> ept' where ept' = case ept of - TypeUnsigned -> text " (unsigned)" - TypeDirect -> mempty + Unsigned -> " (unsigned)" + Signed -> mempty ppr (ArrayValue mem space et ept shape) = - foldr f (ppr et) shape <+> text "at" <+> ppr mem <> ppr space <+> ept' + foldr f (ppr et) shape <+> "at" <+> ppr mem <> ppr space <+> ept' where f e s = brackets $ s <> comma <> ppr e ept' = case ept of - TypeUnsigned -> text " (unsigned)" - TypeDirect -> mempty + Unsigned -> " (unsigned)" + Signed -> mempty instance Pretty ExternalValue where - ppr (TransparentValue u v) = ppr u <> ppr v - ppr (OpaqueValue u desc vs) = - ppr u <> text "opaque" <+> text desc + ppr (TransparentValue v) = ppr v + ppr (OpaqueValue desc vs) = + "opaque" + <+> pquote (ppr desc) <+> nestedBlock "{" "}" (stack $ map ppr vs) instance Pretty ArrayContents where ppr (ArrayValues vs) = braces (commasep $ map ppr vs) - ppr (ArrayZeros n) = braces (text "0") <+> text "*" <+> ppr n + ppr (ArrayZeros n) = braces "0" <+> "*" <+> ppr n instance Pretty op => Pretty (Code op) where ppr (Op op) = ppr op - ppr Skip = text "skip" + ppr Skip = "skip" ppr (c1 :>>: c2) = ppr c1 ppr c2 ppr (For i limit body) = - text "for" <+> ppr i <+> langle <+> ppr limit <+> text "{" + "for" + <+> ppr i + <+> langle + <+> ppr limit + <+> "{" indent 2 (ppr body) - text "}" + "}" ppr (While cond body) = - text "while" <+> ppr cond <+> text "{" + "while" + <+> ppr cond + <+> "{" indent 2 (ppr body) - text "}" + "}" ppr (DeclareMem name space) = - text "var" <+> ppr name <> text ": mem" <> ppr space + "var" <+> ppr name <> ": mem" <> ppr space ppr (DeclareScalar name vol t) = - text "var" <+> ppr name <> text ":" <+> vol' <> ppr t + "var" <+> ppr name <> ":" <+> vol' <> ppr t where vol' = case vol of - Volatile -> text "volatile " + Volatile -> "volatile " Nonvolatile -> mempty ppr (DeclareArray name space t vs) = - text "array" <+> ppr name <> text "@" <> ppr space <+> text ":" <+> ppr t + "array" + <+> ppr name <> "@" <> ppr space + <+> ":" + <+> ppr t <+> equals <+> ppr vs ppr (Allocate name e space) = - ppr name <+> text "<-" <+> text "malloc" <> parens (ppr e) <> ppr space + ppr name <+> "<-" <+> "malloc" <> parens (ppr e) <> ppr space ppr (Free name space) = - text "free" <> parens (ppr name) <> ppr space + "free" <> parens (ppr name) <> ppr space ppr (Write name i bt space vol val) = ppr name <> langle <> vol' <> ppr bt <> ppr space <> rangle <> brackets (ppr i) - <+> text "<-" + <+> "<-" <+> ppr val where vol' = case vol of - Volatile -> text "volatile " + Volatile -> "volatile " Nonvolatile -> mempty ppr (Read name v is bt space vol) = - ppr name <+> text "<-" + ppr name + <+> "<-" <+> ppr v <> langle <> vol' <> ppr bt <> ppr space <> rangle <> brackets (ppr is) where vol' = case vol of - Volatile -> text "volatile " + Volatile -> "volatile " Nonvolatile -> mempty ppr (SetScalar name val) = - ppr name <+> text "<-" <+> ppr val + ppr name <+> "<-" <+> ppr val ppr (SetMem dest from DefaultSpace) = - ppr dest <+> text "<-" <+> ppr from + ppr dest <+> "<-" <+> ppr from ppr (SetMem dest from space) = - ppr dest <+> text "<-" <+> ppr from <+> text "@" <> ppr space + ppr dest <+> "<-" <+> ppr from <+> "@" <> ppr space ppr (Assert e msg _) = - text "assert" <> parens (commasep [ppr msg, ppr e]) + "assert" <> parens (commasep [ppr msg, ppr e]) ppr (Copy t dest destoffset destspace src srcoffset srcspace size) = - text "copy" + "copy" <> parens ( ppr t <> comma ppMemLoc dest destoffset <> ppr destspace <> comma @@ -545,24 +566,27 @@ ) where ppMemLoc base offset = - ppr base <+> text "+" <+> ppr offset + ppr base <+> "+" <+> ppr offset ppr (If cond tbranch fbranch) = - text "if" <+> ppr cond <+> text "then {" + "if" + <+> ppr cond + <+> "then {" indent 2 (ppr tbranch) - text "} else {" + "} else {" indent 2 (ppr fbranch) - text "}" + "}" ppr (Call dests fname args) = - commasep (map ppr dests) <+> text "<-" + commasep (map ppr dests) + <+> "<-" <+> ppr fname <> parens (commasep $ map ppr args) ppr (Comment s code) = - text "--" <+> text s ppr code + "--" <+> text s ppr code ppr (DebugPrint desc (Just e)) = - text "debug" <+> parens (commasep [text (show desc), ppr e]) + "debug" <+> parens (commasep [text (show desc), ppr e]) ppr (DebugPrint desc Nothing) = - text "debug" <+> parens (text (show desc)) + "debug" <+> parens (text (show desc)) ppr (TracePrint msg) = - text "trace" <+> parens (ppr msg) + "trace" <+> parens (ppr msg) instance Pretty Arg where ppr (MemArg m) = ppr m @@ -587,8 +611,8 @@ foldMap = foldMapDefault instance Traversable FunctionT where - traverse f (Function entry outs ins body results args) = - Function entry outs ins <$> traverse f body <*> pure results <*> pure args + traverse f (Function entry outs ins body) = + Function entry outs ins <$> traverse f body instance Functor Code where fmap = fmapDefault @@ -653,12 +677,15 @@ declaredIn (Comment _ body) = declaredIn body declaredIn _ = mempty +instance FreeIn EntryPoint where + freeIn' (EntryPoint _ res args) = + freeIn' (map snd res) <> freeIn' (map snd args) + instance FreeIn a => FreeIn (Functions a) where freeIn' (Functions fs) = foldMap (onFun . snd) fs where onFun f = - fvBind pnames $ - freeIn' (functionBody f) <> freeIn' (functionResult f <> map snd (functionArgs f)) + fvBind pnames $ freeIn' (functionBody f) <> freeIn' (functionEntry f) where pnames = namesFromList $ map paramName $ functionInput f <> functionOutput f @@ -668,8 +695,8 @@ freeIn' ScalarValue {} = mempty instance FreeIn ExternalValue where - freeIn' (TransparentValue _ vd) = freeIn' vd - freeIn' (OpaqueValue _ _ vds) = foldMap freeIn' vds + freeIn' (TransparentValue vd) = freeIn' vd + freeIn' (OpaqueValue _ vds) = foldMap freeIn' vds instance FreeIn a => FreeIn (Code a) where freeIn' (x :>>: y) = diff --git a/src/Futhark/CodeGen/ImpCode/GPU.hs b/src/Futhark/CodeGen/ImpCode/GPU.hs --- a/src/Futhark/CodeGen/ImpCode/GPU.hs +++ b/src/Futhark/CodeGen/ImpCode/GPU.hs @@ -95,12 +95,14 @@ instance Pretty HostOp where ppr (GetSize dest key size_class) = - ppr dest <+> text "<-" + ppr dest + <+> text "<-" <+> text "get_size" <> parens (commasep [ppr key, ppr size_class]) ppr (GetSizeMax dest size_class) = ppr dest <+> text "<-" <+> text "get_size_max" <> parens (ppr size_class) ppr (CmpSizeLe dest name size_class x) = - ppr dest <+> text "<-" + ppr dest + <+> text "<-" <+> text "get_size" <> parens (commasep [ppr name, ppr size_class]) <+> text "<" <+> ppr x @@ -126,12 +128,18 @@ ppr kernel = text "kernel" <+> brace - ( text "groups" <+> brace (ppr $ kernelNumGroups kernel) - text "group_size" <+> brace (ppr $ kernelGroupSize kernel) - text "uses" <+> brace (commasep $ map ppr $ kernelUses kernel) - text "failure_tolerant" <+> brace (ppr $ kernelFailureTolerant kernel) - text "check_local_memory" <+> brace (ppr $ kernelCheckLocalMemory kernel) - text "body" <+> brace (ppr $ kernelBody kernel) + ( text "groups" + <+> brace (ppr $ kernelNumGroups kernel) + text "group_size" + <+> brace (ppr $ kernelGroupSize kernel) + text "uses" + <+> brace (commasep $ map ppr $ kernelUses kernel) + text "failure_tolerant" + <+> brace (ppr $ kernelFailureTolerant kernel) + text "check_local_memory" + <+> brace (ppr $ kernelCheckLocalMemory kernel) + text "body" + <+> brace (ppr $ kernelBody kernel) ) -- | When we do a barrier or fence, is it at the local or global @@ -190,16 +198,20 @@ instance Pretty KernelOp where ppr (GetGroupId dest i) = - ppr dest <+> "<-" + ppr dest + <+> "<-" <+> "get_group_id" <> parens (ppr i) ppr (GetLocalId dest i) = - ppr dest <+> "<-" + ppr dest + <+> "<-" <+> "get_local_id" <> parens (ppr i) ppr (GetLocalSize dest i) = - ppr dest <+> "<-" + ppr dest + <+> "<-" <+> "get_local_size" <> parens (ppr i) ppr (GetLockstepWidth dest) = - ppr dest <+> "<-" + ppr dest + <+> "<-" <+> "get_lockstep_width()" ppr (Barrier FenceLocal) = "local_barrier()" @@ -216,38 +228,71 @@ ppr (ErrorSync FenceGlobal) = "error_sync_global()" ppr (Atomic _ (AtomicAdd t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_add_" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_add_" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicFAdd t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_fadd_" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_fadd_" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicSMax t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_smax" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_smax" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicSMin t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_smin" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_smin" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicUMax t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_umax" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_umax" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicUMin t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_umin" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_umin" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicAnd t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_and" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_and" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicOr t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_or" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_or" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicXor t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_xor" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_xor" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) ppr (Atomic _ (AtomicCmpXchg t old arr ind x y)) = - ppr old <+> "<-" <+> "atomic_cmp_xchg" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x, ppr y]) + ppr old + <+> "<-" + <+> "atomic_cmp_xchg" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x, ppr y]) ppr (Atomic _ (AtomicXchg t old arr ind x)) = - ppr old <+> "<-" <+> "atomic_xchg" <> ppr t - <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) + ppr old + <+> "<-" + <+> "atomic_xchg" + <> ppr t + <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x]) instance FreeIn KernelOp where freeIn' (Atomic _ op) = freeIn' op diff --git a/src/Futhark/CodeGen/ImpCode/Multicore.hs b/src/Futhark/CodeGen/ImpCode/Multicore.hs --- a/src/Futhark/CodeGen/ImpCode/Multicore.hs +++ b/src/Futhark/CodeGen/ImpCode/Multicore.hs @@ -26,6 +26,15 @@ data Multicore = SegOp String [Param] ParallelTask (Maybe ParallelTask) [Param] SchedulerInfo | ParLoop String MCCode [Param] + | -- | A kernel of ISPC code, or a scoped block in regular C. + ISPCKernel MCCode [Param] + | -- | A foreach loop in ISPC, or a regular for loop in C. + ForEach VName Exp Exp MCCode + | -- | A foreach_active loop in ISPC, or a single execution in C. + ForEachActive VName MCCode + | -- | Extract a value from a given lane and assign it to a variable. + -- This is just a regular assignment in C. + ExtractLane VName Exp Exp | -- | Retrieve inclusive start and exclusive end indexes of the -- chunk we are supposed to be executing. Only valid immediately -- inside a 'ParLoop' construct! @@ -123,6 +132,22 @@ ] ppr (Atomic _) = "AtomicOp" + ppr (ISPCKernel body _) = + "ispc" <+> nestedBlock "{" "}" (ppr body) + ppr (ForEach i from to body) = + "foreach" + <+> ppr i + <+> "=" + <+> ppr from + <+> "to" + <+> ppr to + <+> nestedBlock "{" "}" (ppr body) + ppr (ForEachActive i body) = + "foreach_active" + <+> ppr i + <+> nestedBlock "{" "}" (ppr body) + ppr (ExtractLane dest tar lane) = + ppr dest <+> "<-" <+> "extract" <+> parens (commasep $ map ppr [tar, lane]) instance FreeIn SchedulerInfo where freeIn' (SchedulerInfo iter _) = freeIn' iter @@ -143,14 +168,25 @@ freeIn' body freeIn' (Atomic aop) = freeIn' aop + freeIn' (ISPCKernel body _) = + freeIn' body + freeIn' (ForEach i from to body) = + fvBind (oneName i) (freeIn' body <> freeIn' from <> freeIn' to) + freeIn' (ForEachActive i body) = + fvBind (oneName i) (freeIn' body) + freeIn' (ExtractLane dest tar lane) = + freeIn' dest <> freeIn' tar <> freeIn' lane +-- | Whether 'lexicalMemoryUsageMC' should look inside nested kernels +-- or not. data KernelHandling = TraverseKernels | OpaqueKernels -- | Like @lexicalMemoryUsage@, but traverses some inner multicore ops. lexicalMemoryUsageMC :: KernelHandling -> Function Multicore -> M.Map VName Space lexicalMemoryUsageMC gokernel func = - M.filterWithKey (const . not . (`nameIn` nonlexical)) $ - declared $ functionBody func + M.filterWithKey (const . (`notNameIn` nonlexical)) $ + declared $ + functionBody func where nonlexical = set (functionBody func) @@ -161,7 +197,20 @@ go f (For _ _ x) = f x go f (While _ x) = f x go f (Comment _ x) = f x + go f (Op op) = goOp f op go _ _ = mempty + + -- We want SetMems and declarations to be visible through custom control flow + -- so we don't erroneously treat a memblock that could be lexical as needing + -- refcounting. Importantly, for ISPC, we do not look into kernels, since they + -- go into new functions. For the Multicore backend, we can do it, though. + goOp f (ForEach _ _ _ body) = go f body + goOp f (ForEachActive _ body) = go f body + goOp f (ISPCKernel body _) = + case gokernel of + TraverseKernels -> go f body + OpaqueKernels -> mempty + goOp _ _ = mempty declared (DeclareMem mem spc) = M.singleton mem spc 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 @@ -55,6 +55,7 @@ lookupArray, lookupMemory, lookupAcc, + askAttrs, -- * Building Blocks TV, @@ -441,7 +442,7 @@ Imp.Space -> Prog rep -> m (Warnings, Imp.Definitions op) -compileProg r ops space (Prog consts funs) = +compileProg r ops space (Prog types consts funs) = modifyNameSource $ \src -> let (_, ss) = unzip $ parMap rpar (compileFunDef' src) funs @@ -451,14 +452,14 @@ runImpM (compileConsts free_in_funs consts) r ops space $ combineStates ss in ( ( stateWarnings s', - Imp.Definitions consts' (stateFunctions s') + Imp.Definitions types consts' (stateFunctions s') ), stateNameSource s' ) where compileFunDef' src fdef = runImpM - (compileFunDef fdef) + (compileFunDef types fdef) r ops space @@ -496,6 +497,33 @@ extract s = (mempty, s) +lookupOpaqueType :: String -> OpaqueTypes -> OpaqueType +lookupOpaqueType v (OpaqueTypes types) = + case lookup v types of + Just t -> t + Nothing -> error $ "Unknown opaque type: " ++ show v + +valueTypeSign :: ValueType -> Signedness +valueTypeSign (ValueType sign _ _) = sign + +entryPointSignedness :: OpaqueTypes -> EntryPointType -> [Signedness] +entryPointSignedness _ (TypeTransparent vt) = [valueTypeSign vt] +entryPointSignedness types (TypeOpaque desc) = + case lookupOpaqueType desc types of + OpaqueType vts -> map valueTypeSign vts + OpaqueRecord fs -> foldMap (entryPointSignedness types . snd) fs + +-- | How many value parameters are accepted by this entry point? This +-- is used to determine which of the function parameters correspond to +-- the parameters of the original function (they must all come at the +-- end). +entryPointSize :: OpaqueTypes -> EntryPointType -> Int +entryPointSize _ (TypeTransparent _) = 1 +entryPointSize types (TypeOpaque desc) = + case lookupOpaqueType desc types of + OpaqueType vts -> length vts + OpaqueRecord fs -> sum $ map (entryPointSize types . snd) fs + compileInParam :: Mem rep inner => FParam rep -> @@ -516,13 +544,12 @@ compileInParams :: Mem rep inner => + OpaqueTypes -> [FParam rep] -> - [EntryParam] -> - ImpM rep r op ([Imp.Param], [ArrayDecl], [(Name, Imp.ExternalValue)]) -compileInParams params eparams = do - let (ctx_params, val_params) = - splitAt (length params - sum (map (entryPointSize . entryParamType) eparams)) params - (inparams, arrayds) <- partitionEithers <$> mapM compileInParam (ctx_params ++ val_params) + Maybe [EntryParam] -> + ImpM rep r op ([Imp.Param], [ArrayDecl], Maybe [((Name, Uniqueness), Imp.ExternalValue)]) +compileInParams types params eparams = do + (inparams, arrayds) <- partitionEithers <$> mapM compileInParam params let findArray x = find (isArrayDecl x) arrayds summaries = M.fromList $ mapMaybe memSummary params @@ -546,24 +573,31 @@ _ -> Nothing - mkExts (EntryParam v (TypeOpaque u desc n) : epts) fparams = - let (fparams', rest) = splitAt n fparams - in ( v, + mkExts (EntryParam v u et@(TypeOpaque desc) : epts) fparams = + let signs = entryPointSignedness types et + n = entryPointSize types et + (fparams', rest) = splitAt n fparams + in ( (v, u), Imp.OpaqueValue - u desc - (mapMaybe (`mkValueDesc` Imp.TypeDirect) fparams') - ) : - mkExts epts rest - mkExts (EntryParam v (TypeUnsigned u) : epts) (fparam : fparams) = - maybeToList ((v,) . Imp.TransparentValue u <$> mkValueDesc fparam Imp.TypeUnsigned) - ++ mkExts epts fparams - mkExts (EntryParam v (TypeDirect u) : epts) (fparam : fparams) = - maybeToList ((v,) . Imp.TransparentValue u <$> mkValueDesc fparam Imp.TypeDirect) + (catMaybes $ zipWith mkValueDesc fparams' signs) + ) + : mkExts epts rest + mkExts (EntryParam v u (TypeTransparent (ValueType s _ _)) : epts) (fparam : fparams) = + maybeToList (((v, u),) . Imp.TransparentValue <$> mkValueDesc fparam s) ++ mkExts epts fparams mkExts _ _ = [] - pure (inparams, arrayds, mkExts eparams val_params) + pure + ( inparams, + arrayds, + case eparams of + Just eparams' -> + let num_val_params = sum (map (entryPointSize types . entryParamType) eparams') + (_ctx_params, val_params) = splitAt (length params - num_val_params) params + in Just $ mkExts eparams' val_params + Nothing -> Nothing + ) where isArrayDecl x (ArrayDecl y _ _) = x == y @@ -582,13 +616,16 @@ compileExternalValues :: Mem rep inner => + OpaqueTypes -> [RetType rep] -> - [EntryPointType] -> + [EntryResult] -> [Maybe Imp.Param] -> - ImpM rep r op [Imp.ExternalValue] -compileExternalValues orig_rts orig_epts maybe_params = do + ImpM rep r op [(Uniqueness, Imp.ExternalValue)] +compileExternalValues types orig_rts orig_epts maybe_params = do let (ctx_rts, val_rts) = - splitAt (length orig_rts - sum (map entryPointSize orig_epts)) orig_rts + splitAt + (length orig_rts - sum (map (entryPointSize types . entryResultType) orig_epts)) + orig_rts let nthOut i = case maybeNth i maybe_params of Just (Just p) -> Imp.paramName p @@ -614,57 +651,61 @@ mkValueDesc _ _ MemMem {} = error "mkValueDesc: unexpected MemMem output." - 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 i (EntryResult u et@(TypeOpaque desc) : epts) rets = do + let signs = entryPointSignedness types et + n = entryPointSize types et + (rets', rest) = splitAt n rets + vds <- forM (zip3 [i ..] signs rets') $ \(j, s, r) -> mkValueDesc j s r + ((u, Imp.OpaqueValue desc vds) :) <$> mkExts (i + n) epts rest + mkExts i (EntryResult u (TypeTransparent (ValueType s _ _)) : epts) (ret : rets) = do + vd <- mkValueDesc i s ret + ((u, Imp.TransparentValue vd) :) <$> mkExts (i + 1) epts rets mkExts _ _ _ = pure [] mkExts (length ctx_rts) orig_epts val_rts compileOutParams :: Mem rep inner => + OpaqueTypes -> [RetType rep] -> - Maybe [EntryPointType] -> - ImpM rep r op ([Imp.ExternalValue], [Imp.Param], [ValueDestination]) -compileOutParams orig_rts maybe_orig_epts = do + Maybe [EntryResult] -> + ImpM rep r op (Maybe [(Uniqueness, Imp.ExternalValue)], [Imp.Param], [ValueDestination]) +compileOutParams types 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 [] + Just orig_epts -> + Just <$> compileExternalValues types orig_rts orig_epts maybe_params + Nothing -> pure Nothing pure (evs, catMaybes maybe_params, dests) compileFunDef :: Mem rep inner => + OpaqueTypes -> FunDef rep -> ImpM rep r op () -compileFunDef (FunDef entry _ fname rettype params body) = +compileFunDef types (FunDef entry _ fname rettype params body) = local (\env -> env {envFunction = name_entry `mplus` Just fname}) $ do ((outparams, inparams, results, args), body') <- collect' compile - emitFunction fname $ Imp.Function name_entry outparams inparams body' results args + let entry' = case (name_entry, results, args) of + (Just name_entry', Just results', Just args') -> + Just $ Imp.EntryPoint name_entry' results' args' + _ -> + Nothing + emitFunction fname $ Imp.Function entry' outparams inparams body' where (name_entry, params_entry, ret_entry) = case entry of - Nothing -> - ( Nothing, - replicate (length params) (EntryParam "" $ TypeDirect mempty), - Nothing - ) - Just (x, y, z) -> (Just x, y, Just z) + Nothing -> (Nothing, Nothing, Nothing) + Just (x, y, z) -> (Just x, Just y, Just z) compile = do - (inparams, arrayds, args) <- compileInParams params params_entry - (results, outparams, dests) <- compileOutParams rettype ret_entry + (inparams, arrayds, args) <- compileInParams types params params_entry + (results, outparams, dests) <- compileOutParams types rettype ret_entry addFParams params addArrays arrayds let Body _ stms ses = body compileStms (freeIn ses) stms $ - forM_ (zip dests ses) $ \(d, SubExpRes _ se) -> copyDWIMDest d [] se [] + forM_ (zip dests ses) $ + \(d, SubExpRes _ se) -> copyDWIMDest d [] se [] pure (outparams, inparams, results, args) @@ -672,12 +713,14 @@ compileBody pat (Body _ stms ses) = do dests <- destinationFromPat pat compileStms (freeIn ses) stms $ - forM_ (zip dests ses) $ \(d, SubExpRes _ 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 _ stms ses) = compileStms (freeIn ses) stms $ - forM_ (zip params ses) $ \(param, SubExpRes _ 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 _ stms ses) = do @@ -725,11 +768,11 @@ e_code <- localAttrs (stmAuxAttrs aux) $ - collect $ compileExp pat e + collect $ + compileExp pat e (live_after, bs_code) <- collect' $ compileStms' (patternAllocs pat <> allocs) bs let dies_here v = - not (v `nameIn` live_after) - && v `nameIn` freeIn e_code + (v `notNameIn` live_after) && (v `nameIn` freeIn e_code) to_free = S.filter (dies_here . fst) allocs emit e_code @@ -1018,7 +1061,9 @@ where addFParam fparam = addVar (paramName fparam) $ - memBoundToVarEntry Nothing $ noUniquenessReturns $ paramDec fparam + memBoundToVarEntry Nothing $ + noUniquenessReturns $ + paramDec fparam -- | Another hack. addLoopVar :: VName -> IntType -> ImpM rep r op () @@ -1144,7 +1189,6 @@ everythingVolatile :: ImpM rep r op a -> ImpM rep r op a everythingVolatile = local $ \env -> env {envVolatility = Imp.Volatile} --- | Remove the array targets. funcallTargets :: [ValueDestination] -> ImpM rep r op [VName] funcallTargets dests = concat <$> mapM funcallTarget dests @@ -1379,17 +1423,18 @@ src@(MemLoc src_name _ src_ixfn@(IxFun.IxFun src_lmads@(src_lmad :| _) _ _)) = do -- If we can statically determine that the two index-functions -- are equivalent, don't do anything - unless (dst_name == src_name && dst_ixfn `IxFun.equivalent` src_ixfn) $ + unless (dst_name == src_name && dst_ixfn `IxFun.equivalent` src_ixfn) + $ -- It's also possible that we can dynamically determine that the two -- index-functions are equivalent. sUnless ( fromBool (dst_name == src_name && length dst_lmads == 1 && length src_lmads == 1) .&&. IxFun.dynamicEqualsLMAD dst_lmad src_lmad ) - $ do - -- If none of the above is true, actually do the copy - cc <- asks envCopyCompiler - cc bt dst src + $ do + -- If none of the above is true, actually do the copy + cc <- asks envCopyCompiler + cc bt dst src -- | Is this copy really a mapping with transpose? isMapTransposeCopy :: @@ -1453,19 +1498,19 @@ | Just (destoffset, srcoffset, num_arrays, size_x, size_y) <- isMapTransposeCopy pt dest src = do fname <- mapTransposeForType pt - emit $ - Imp.Call + emit + $ Imp.Call [] fname - $ transposeArgs - pt - destmem - (bytes destoffset) - srcmem - (bytes srcoffset) - num_arrays - size_x - size_y + $ transposeArgs + pt + destmem + (bytes destoffset) + srcmem + (bytes srcoffset) + num_arrays + size_x + size_y | Just destoffset <- IxFun.linearWithOffset dest_ixfun pt_size, Just srcoffset <- @@ -1475,8 +1520,8 @@ if isScalarSpace srcspace || isScalarSpace destspace then copyElementWise pt dest src else - emit $ - Imp.Copy + emit + $ Imp.Copy pt destmem (bytes destoffset) @@ -1484,7 +1529,7 @@ srcmem (bytes srcoffset) srcspace - $ num_elems `withElemType` pt + $ num_elems `withElemType` pt | otherwise = copyElementWise pt dest src where @@ -1566,8 +1611,8 @@ 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. +-- Like 'copyDWIM', but the target is a 'ValueDestination' instead of +-- a variable name. copyDWIMDest :: ValueDestination -> [DimIndex (Imp.TExp Int64)] -> @@ -1744,7 +1789,11 @@ sFor i bound body = do i' <- newVName i sFor' i' (untyped bound) $ - body $ TPrimExp $ Imp.var i' $ primExpType $ untyped bound + body $ + TPrimExp $ + Imp.var i' $ + primExpType $ + untyped bound sWhile :: Imp.TExp Bool -> ImpM rep r op () -> ImpM rep r op () sWhile cond body = do @@ -1808,7 +1857,9 @@ sArrayInMem :: String -> PrimType -> ShapeBase SubExp -> VName -> ImpM rep r op VName sArrayInMem name pt shape mem = sArray name pt shape mem $ - IxFun.iota $ map (isInt64 . primExpFromSubExp int64) $ shapeDims shape + IxFun.iota $ + map (isInt64 . primExpFromSubExp int64) $ + shapeDims shape -- | Like 'sAllocArray', but permute the in-memory representation of the indices as specified. sAllocArrayPerm :: String -> PrimType -> ShapeBase SubExp -> Space -> [Int] -> ImpM rep r op VName @@ -1817,7 +1868,8 @@ mem <- sAlloc (name ++ "_mem") (typeSize (Array pt shape NoUniqueness)) space let iota_ixfun = IxFun.iota $ map (isInt64 . primExpFromSubExp int64) permuted_dims sArray name pt shape mem $ - IxFun.permute iota_ixfun $ rearrangeInverse perm + IxFun.permute iota_ixfun $ + rearrangeInverse perm -- | Uses linear/iota index function. sAllocArray :: String -> PrimType -> ShapeBase SubExp -> Space -> ImpM rep r op VName @@ -1887,7 +1939,7 @@ body <- collect $ do mapM_ addParam $ outputs ++ inputs m - emitFunction fname $ Imp.Function Nothing outputs inputs body [] [] + emitFunction fname $ Imp.Function Nothing outputs inputs body where addParam (Imp.MemParam name space) = addVar name $ MemVar Nothing $ MemEntry space 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,12 +83,11 @@ Prog GPUMem -> m (Warnings, Imp.Program) compileProg env prog = - second (fmap setOpSpace . setDefsSpace) + second (fmap setOpSpace . setDefaultSpace device_space) <$> 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 @@ -145,7 +144,8 @@ segOpCompiler dest op opCompiler (Pat pes) (Inner (GPUBody _ (Body _ stms res))) = do tid <- newVName "tid" - sKernelThread "gpuseq" tid (defKernelAttrs 1 1) $ + let one = Count (intConst Int64 1) + sKernelThread "gpuseq" tid (defKernelAttrs one one) $ compileStms (freeIn res) stms $ forM_ (zip pes res) $ \(pe, SubExpRes _ se) -> copyDWIM (patElemName pe) [DimFix 0] se [] @@ -296,8 +296,8 @@ let num_elems = Imp.elements $ product $ map toInt64Exp srcshape srcspace <- entryMemSpace <$> lookupMemory srcmem destspace <- entryMemSpace <$> lookupMemory destmem - emit $ - Imp.Copy + emit + $ Imp.Copy bt destmem (bytes $ sExt64 destoffset) @@ -305,7 +305,7 @@ srcmem (bytes $ sExt64 srcoffset) srcspace - $ num_elems `Imp.withElemType` bt + $ num_elems `Imp.withElemType` bt | otherwise = sCopy bt destloc srcloc mapTransposeForType :: PrimType -> CallKernelGen Name @@ -322,7 +322,7 @@ mapTransposeFunction :: PrimType -> Imp.Function Imp.HostOp mapTransposeFunction bt = - Imp.Function Nothing [] params transpose_code [] [] + Imp.Function Nothing [] params transpose_code where params = [ memparam destmem, @@ -421,7 +421,8 @@ (Imp.Count num_bytes) callTransposeKernel = - Imp.Op . Imp.CallKernel + Imp.Op + . Imp.CallKernel . mapTransposeKernel (mapTransposeName bt) block_dim_int 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 @@ -91,6 +91,8 @@ kernelGlobalThreadIdVar :: VName, kernelLocalThreadIdVar :: VName, kernelGroupIdVar :: VName, + kernelNumGroupsCount :: Count NumGroups SubExp, + kernelGroupSizeCount :: Count GroupSize SubExp, kernelNumGroups :: Imp.TExp Int64, kernelGroupSize :: Imp.TExp Int64, kernelNumThreads :: Imp.TExp Int32, @@ -444,7 +446,8 @@ locks_mem <- sAlloc "locks_mem" (typeSize locks_t) $ Space "local" dArray locks int32 (arrayShape locks_t) locks_mem $ - IxFun.iota $ map pe64 $ arrayDims locks_t + IxFun.iota . map pe64 . arrayDims $ + locks_t sComment "All locks start out unlocked" $ groupCoverSpace [kernelGroupSize constants] $ \is -> @@ -462,7 +465,8 @@ fenceForArrays = fmap (foldl' max Imp.FenceLocal) . mapM need where need arr = - fmap (fenceForSpace . entryMemSpace) . lookupMemory + fmap (fenceForSpace . entryMemSpace) + . lookupMemory . memLocName . entryArrayLoc =<< lookupArray arr @@ -507,7 +511,9 @@ ArrayEntry arr_loc pt <- lookupArray arr let flat_shape = Shape $ Var (tvVar flat) : drop k (memLocShape arr_loc) sArray (baseString arr ++ "_flat") pt flat_shape (memLocName arr_loc) $ - IxFun.reshape (memLocIxFun arr_loc) $ map (DimNew . pe64) $ shapeDims flat_shape + IxFun.reshape (memLocIxFun arr_loc) $ + map (DimNew . pe64) $ + shapeDims flat_shape -- | @applyLambda lam dests args@ emits code that: -- @@ -535,7 +541,7 @@ forM_ (zip dests res) $ \((dest, dest_slice), se) -> copyDWIM dest dest_slice se [] --- | As 'applyLambda', but first rename the names in the lambda. This +-- | As applyLambda, but first rename the names in the lambda. This -- makes it safe to apply it in multiple places. (It might be safe -- anyway, but you have to be more careful - use this if you are in -- doubt.) @@ -628,7 +634,8 @@ num_scan_results = length $ segBinOpNeutral scan arrs_flat <- mapM (flattenArray (length dims') dims_flat) $ - take num_scan_results $ patNames pat + take num_scan_results $ + patNames pat case segVirt lvl of SegVirt -> @@ -893,7 +900,8 @@ primBitSize t `elem` [32, 64] = AtomicCAS $ \space [arr] bucket -> do old <- dPrim "old" t atomicUpdateCAS space t arr (tvVar old) bucket (paramName xp) $ - compileBody' [xp] $ lambdaBody op + compileBody' [xp] $ + lambdaBody op atomicUpdateLocking _ op = AtomicLocking $ \locking space arrs bucket -> do old <- dPrim "old" int32 continue <- dPrimVol "continue" Bool true @@ -947,12 +955,14 @@ let op_body = sComment "execute operation" $ - compileBody' acc_params $ lambdaBody op + compileBody' acc_params $ + lambdaBody op do_hist = everythingVolatile $ sComment "update global result" $ - zipWithM_ (writeArray bucket) arrs $ map (Var . paramName) acc_params + zipWithM_ (writeArray bucket) arrs $ + map (Var . paramName) acc_params fence = sOp $ Imp.MemFence $ fenceForSpace space @@ -1121,33 +1131,39 @@ num_elements - Imp.elements thread_index * elements_per_thread is_last_thread = Imp.unCount num_elements - .<. (thread_index + 1) * Imp.unCount elements_per_thread + .<. (thread_index + 1) + * Imp.unCount elements_per_thread kernelInitialisationSimple :: - Count NumGroups (Imp.TExp Int64) -> - Count GroupSize (Imp.TExp Int64) -> + Count NumGroups SubExp -> + Count GroupSize SubExp -> CallKernelGen (KernelConstants, InKernelGen ()) -kernelInitialisationSimple (Count num_groups) (Count group_size) = do +kernelInitialisationSimple num_groups group_size = do global_tid <- newVName "global_tid" local_tid <- newVName "local_tid" group_id <- newVName "group_tid" wave_size <- newVName "wave_size" inner_group_size <- newVName "group_size" - let constants = + let num_groups' = Imp.pe64 (unCount num_groups) + group_size' = Imp.pe64 (unCount group_size) + constants = KernelConstants - (Imp.le32 global_tid) - (Imp.le32 local_tid) - (Imp.le32 group_id) - global_tid - local_tid - group_id - num_groups - group_size - (sExt32 (group_size * num_groups)) - (Imp.le32 wave_size) - true - mempty - mempty + { kernelGlobalThreadId = Imp.le32 global_tid, + kernelLocalThreadId = Imp.le32 local_tid, + kernelGroupId = Imp.le32 group_id, + kernelGlobalThreadIdVar = global_tid, + kernelLocalThreadIdVar = local_tid, + kernelNumGroupsCount = num_groups, + kernelGroupSizeCount = group_size, + kernelGroupIdVar = group_id, + kernelNumGroups = num_groups', + kernelGroupSize = group_size', + kernelNumThreads = sExt32 (group_size' * num_groups'), + kernelWaveSize = Imp.le32 wave_size, + kernelThreadActive = true, + kernelLocalIdMap = mempty, + kernelChunkItersMap = mempty + } let set_constants = do dPrim_ local_tid int32 @@ -1241,7 +1257,8 @@ comment "read array element" $ zipWithM_ readReduceArgument reduce_arr_params arrs comment "apply reduction operation" $ - compileBody' reduce_acc_params $ lambdaBody lam + compileBody' reduce_acc_params $ + lambdaBody lam comment "write result of operation" $ zipWithM_ writeReduceOpResult reduce_acc_params arrs in_wave_reduce = everythingVolatile do_reduce @@ -1470,7 +1487,8 @@ let op_to_x in_block_thread_active | Nothing <- seg_flag = sWhen in_block_thread_active $ - compileBody' x_params $ lambdaBody scan_lam + compileBody' x_params $ + lambdaBody scan_lam | Just flag_true <- seg_flag = do inactive <- dPrimVE "inactive" $ flag_true (ltid32 - tvExp skip_threads) ltid32 @@ -1481,7 +1499,8 @@ -- hit this barrier (if applicable). when array_scan barrier sWhen in_block_thread_active . sUnless inactive $ - compileBody' x_params $ lambdaBody scan_lam + compileBody' x_params $ + lambdaBody scan_lam maybeBarrier = sWhen @@ -1501,7 +1520,8 @@ maybeBarrier sWhen thread_active . sComment "write result" $ - sequence_ $ zipWith3 writeResult x_params y_params arrs + sequence_ $ + zipWith3 writeResult x_params y_params arrs maybeBarrier @@ -1533,14 +1553,16 @@ | otherwise = copyDWIM (paramName y) [] (Var $ paramName x) [] -computeMapKernelGroups :: Imp.TExp Int64 -> CallKernelGen (Imp.TExp Int64, Imp.TExp Int64) +computeMapKernelGroups :: + Imp.TExp Int64 -> + CallKernelGen (Count NumGroups SubExp, Count GroupSize SubExp) computeMapKernelGroups kernel_size = do group_size <- dPrim "group_size" int64 fname <- askFunction let group_size_key = keyWithEntryPoint fname $ nameFromString $ pretty $ tvVar group_size sOp $ Imp.GetSize (tvVar group_size) group_size_key Imp.SizeGroup num_groups <- dPrimV "num_groups" $ kernel_size `divUp` tvExp group_size - pure (tvExp num_groups, tvExp group_size) + pure (Count $ tvSize num_groups, Count $ tvSize group_size) simpleKernelConstants :: Imp.TExp Int64 -> @@ -1560,22 +1582,27 @@ sOp (Imp.GetLocalSize inner_group_size 0) sOp (Imp.GetGroupId group_id 0) dPrimV_ thread_gtid $ le32 group_id * le32 inner_group_size + le32 thread_ltid + group_size' = Imp.pe64 $ unCount group_size + num_groups' = Imp.pe64 $ unCount num_groups pure ( KernelConstants - (Imp.le32 thread_gtid) - (Imp.le32 thread_ltid) - (Imp.le32 group_id) - thread_gtid - thread_ltid - group_id - num_groups - group_size - (sExt32 (group_size * num_groups)) - 0 - (Imp.le64 thread_gtid .<. kernel_size) - mempty - mempty, + { kernelGlobalThreadId = Imp.le32 thread_gtid, + kernelLocalThreadId = Imp.le32 thread_ltid, + kernelGroupId = Imp.le32 group_id, + kernelGlobalThreadIdVar = thread_gtid, + kernelLocalThreadIdVar = thread_ltid, + kernelGroupIdVar = group_id, + kernelNumGroupsCount = num_groups, + kernelGroupSizeCount = group_size, + kernelNumGroups = num_groups', + kernelGroupSize = group_size', + kernelNumThreads = sExt32 (group_size' * num_groups'), + kernelWaveSize = 0, + kernelThreadActive = Imp.le64 thread_gtid .<. kernel_size, + kernelLocalIdMap = mempty, + kernelChunkItersMap = mempty + }, set_constants ) @@ -1618,15 +1645,15 @@ -- | Does whatever launch this kernel check for local memory capacity itself? kAttrCheckLocalMemory :: Bool, -- | Number of groups. - kAttrNumGroups :: Count NumGroups (Imp.TExp Int64), + kAttrNumGroups :: Count NumGroups SubExp, -- | Group size. - kAttrGroupSize :: Count GroupSize (Imp.TExp Int64) + kAttrGroupSize :: Count GroupSize SubExp } -- | The default kernel attributes. defKernelAttrs :: - Count NumGroups (Imp.TExp Int64) -> - Count GroupSize (Imp.TExp Int64) -> + Count NumGroups SubExp -> + Count GroupSize SubExp -> KernelAttrs defKernelAttrs num_groups group_size = KernelAttrs @@ -1703,8 +1730,8 @@ where attrs = ( defKernelAttrs - (Count (kernelNumGroups constants)) - (Count (kernelGroupSize constants)) + (kernelNumGroupsCount constants) + (kernelGroupSizeCount constants) ) { kAttrFailureTolerant = tol } @@ -1779,7 +1806,8 @@ set_constants is' <- dIndexSpace' "rep_i" dims $ sExt64 $ kernelGlobalThreadId constants sWhen (kernelThreadActive constants) $ - copyDWIMFix arr is' se $ drop (length ds) is' + copyDWIMFix arr is' se $ + drop (length ds) is' replicateName :: PrimType -> String replicateName bt = "replicate_" ++ pretty bt @@ -1803,7 +1831,9 @@ function fname [] params $ do arr <- sArray "arr" bt shape mem $ - IxFun.iota $ map pe64 $ shapeDims shape + IxFun.iota $ + map pe64 $ + shapeDims shape sReplicateKernel arr $ Var val pure fname @@ -1854,7 +1884,9 @@ let name = keyWithEntryPoint fname $ nameFromString $ - "iota_" ++ pretty et ++ "_" + "iota_" + ++ pretty et + ++ "_" ++ show (baseTag $ kernelGlobalThreadIdVar constants) sKernelFailureTolerant True threadOperations constants name $ do @@ -1898,7 +1930,9 @@ function fname [] params $ do arr <- sArray "arr" (IntType bt) shape mem $ - IxFun.iota $ map pe64 $ shapeDims shape + IxFun.iota $ + map pe64 $ + shapeDims shape sIotaKernel arr (sExt64 n') x' s' bt pure fname 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 @@ -72,7 +72,8 @@ Imp.Count Imp.Bytes (Imp.TExp Int64) histSpaceUsage op = sum . map (typeSize . (`arrayOfShape` (histShape op <> histOpShape op))) $ - lambdaReturnType $ histOp op + lambdaReturnType $ + histOp op histSize :: HistOp GPUMem -> Imp.TExp Int64 histSize = product . map toInt64Exp . shapeDims . histShape @@ -114,7 +115,9 @@ (elemType dest_t) subhistos_shape subhistos_mem - $ IxFun.iota $ map pe64 $ shapeDims subhistos_shape + $ IxFun.iota + $ map pe64 + $ shapeDims subhistos_shape pure $ SubhistosInfo subhistos $ do @@ -149,7 +152,8 @@ ( h, segmented_h, SegHistSlug op num_subhistos subhisto_infos $ - atomicUpdateLocking atomics $ histOp op + atomicUpdateLocking atomics $ + histOp op ) prepareAtomicUpdateGlobal :: @@ -228,11 +232,15 @@ hist_C_max <- dPrimVE "hist_C_max" $ - fMin64 (r64 hist_T) $ r64 hist_H / hist_k_ct_min + fMin64 (r64 hist_T) $ + r64 hist_H / hist_k_ct_min hist_M_min <- dPrimVE "hist_M_min" $ - sMax32 1 $ sExt32 $ t64 $ r64 hist_T / hist_C_max + sMax32 1 $ + sExt32 $ + t64 $ + r64 hist_T / hist_C_max -- Querying L2 cache size is not reliable. Instead we provide a -- tunable knob with a hopefully sane default. @@ -240,11 +248,11 @@ hist_L2 <- dPrim "L2_size" int32 entry <- askFunction -- Equivalent to F_L2*L2 in paper. - sOp $ - Imp.GetSize + sOp + $ Imp.GetSize (tvVar hist_L2) (keyWithEntryPoint entry $ nameFromString (pretty (tvVar hist_L2))) - $ Imp.SizeBespoke (nameFromString "L2_for_histogram") hist_L2_def + $ Imp.SizeBespoke (nameFromString "L2_for_histogram") hist_L2_def let hist_L2_ln_sz = 16 * 4 -- L2 cache line size approximation hist_RACE_exp <- @@ -334,7 +342,8 @@ hist_C <- dPrimVE "hist_C" $ - fMin64 (r64 hist_T) $ r64 (hist_u * hist_H_chk) / hist_k_max + fMin64 (r64 hist_T) $ + r64 (hist_u * hist_H_chk) / hist_k_max -- Number of subhistograms per result histogram. hist_M <- dPrimVE "hist_M" $ @@ -379,8 +388,8 @@ histKernelGlobalPass :: [PatElem LetDecMem] -> - Count NumGroups (Imp.TExp Int64) -> - Count GroupSize (Imp.TExp Int64) -> + Count NumGroups SubExp -> + Count GroupSize SubExp -> SegSpace -> [SegHistSlug] -> KernelBody GPUMem -> @@ -493,8 +502,8 @@ sFor "chk_i" hist_S $ \chk_i -> histKernelGlobalPass map_pes - num_groups' - group_size' + num_groups + group_size space slugs kbody @@ -525,7 +534,9 @@ emit $ Imp.DebugPrint "Number of subhistograms in global memory per segment" $ - Just $ untyped $ tvExp num_subhistos + Just $ + untyped $ + tvExp num_subhistos mk_op <- case do_op of @@ -534,8 +545,8 @@ AtomicLocking f -> pure $ \hist_H_chk -> do let lock_shape = Shape $ - tvSize num_subhistos_per_group : - shapeDims (histOpShape op) + tvSize num_subhistos_per_group + : shapeDims (histOpShape op) ++ [hist_H_chk] let dims = map toInt64Exp $ shapeDims lock_shape @@ -577,8 +588,8 @@ TV Int32 -> Count NumGroups (Imp.TExp Int64) -> [PatElem LetDecMem] -> - Count NumGroups (Imp.TExp Int64) -> - Count GroupSize (Imp.TExp Int64) -> + Count NumGroups SubExp -> + Count GroupSize SubExp -> SegSpace -> [SegHistSlug] -> KernelBody GPUMem -> @@ -607,21 +618,22 @@ num_segments <- dPrimVE "num_segments" $ - product $ map toInt64Exp segment_dims + product $ + map toInt64Exp segment_dims hist_H_chks <- forM (map slugOp slugs) $ \op -> dPrimV "hist_H_chk" $ histSize op `divUp` sExt64 hist_S histo_sizes <- forM (zip slugs hist_H_chks) $ \(slug, hist_H_chk) -> do let histo_dims = - tvExp hist_H_chk : - map toInt64Exp (shapeDims (histOpShape (slugOp slug))) + tvExp hist_H_chk + : map toInt64Exp (shapeDims (histOpShape (slugOp slug))) histo_size <- dPrimVE "histo_size" $ product histo_dims let group_hists_size = sExt64 num_subhistos_per_group * histo_size init_per_thread <- - dPrimVE "init_per_thread" $ sExt32 $ group_hists_size `divUp` unCount group_size + dPrimVE "init_per_thread" $ sExt32 $ group_hists_size `divUp` pe64 (unCount group_size) pure (histo_dims, histo_size, init_per_thread) let attrs = (defKernelAttrs num_groups group_size) {kAttrCheckLocalMemory = False} @@ -639,11 +651,13 @@ + kernelLocalThreadId constants threads_per_segment <- dPrimVE "threads_per_segment" $ - sExt32 $ unCount groups_per_segment * kernelGroupSize constants + sExt32 $ + unCount groups_per_segment * kernelGroupSize constants -- Set segment indices. zipWithM_ dPrimV_ segment_is $ - unflattenIndex (map toInt64Exp segment_dims) $ sExt64 flat_segment_id + unflattenIndex (map toInt64Exp segment_dims) $ + sExt64 flat_segment_id histograms <- forM (zip init_histograms hist_H_chks) $ \((glob_subhistos, init_local_subhistos), hist_H_chk) -> do @@ -724,7 +738,8 @@ compileStms mempty (kernelBodyStms kbody) $ do let (red_res, map_res) = splitFromEnd (length map_pes) $ - map kernelResultSubExp $ kernelBodyResult kbody + map kernelResultSubExp $ + kernelBodyResult kbody sWhen (chk_i .==. 0) $ sComment "save map-out results" $ @@ -769,8 +784,8 @@ dPrimV "trunc_H" . sMin64 hist_H_chk $ histSize (slugOp slug) - sExt64 chk_i * head histo_dims let trunc_histo_dims = - tvExp trunc_H : - map toInt64Exp (shapeDims (histOpShape (slugOp slug))) + tvExp trunc_H + : map toInt64Exp (shapeDims (histOpShape (slugOp slug))) trunc_histo_size <- dPrimVE "histo_size" $ sExt32 $ product trunc_histo_dims sFor "local_i" bins_per_thread $ \i -> do @@ -793,7 +808,9 @@ let (global_dests, local_dests) = unzip dests (xparams, yparams) = splitAt (length local_dests) $ - lambdaParams $ histOp $ slugOp slug + lambdaParams $ + histOp $ + slugOp slug sComment "Read values from subhistogram 0." $ forM_ (zip xparams local_dests) $ \(xp, subhisto) -> @@ -833,13 +850,12 @@ KernelBody GPUMem -> CallKernelGen () histKernelLocal num_subhistos_per_group_var groups_per_segment map_pes num_groups group_size space hist_S slugs kbody = do - let num_groups' = fmap toInt64Exp num_groups - group_size' = fmap toInt64Exp group_size - num_subhistos_per_group = tvExp num_subhistos_per_group_var + let num_subhistos_per_group = tvExp num_subhistos_per_group_var emit $ Imp.DebugPrint "Number of local subhistograms per group" $ - Just $ untyped num_subhistos_per_group + Just $ + untyped num_subhistos_per_group init_histograms <- prepareIntermediateArraysLocal num_subhistos_per_group_var groups_per_segment slugs @@ -849,8 +865,8 @@ num_subhistos_per_group_var groups_per_segment map_pes - num_groups' - group_size' + num_groups + group_size space slugs kbody @@ -914,7 +930,8 @@ -- M in the paper, but not adjusted for asymptotic efficiency. hist_M0 <- dPrimVE "hist_M0" $ - sMax64 1 $ sMin64 (t64 hist_m') hist_B + sMax64 1 $ + sMin64 (t64 hist_m') hist_B -- Minimal sequential chunking factor. let q_small = 2 @@ -965,7 +982,9 @@ emit $ Imp.DebugPrint "local M" $ Just $ untyped $ tvExp hist_M emit $ Imp.DebugPrint "local memory needed" $ - Just $ untyped $ hist_H * hist_el_size * sExt64 (tvExp hist_M) + Just $ + untyped $ + hist_H * hist_el_size * sExt64 (tvExp hist_M) -- local_mem_needed is what we need to keep a single bucket in local -- memory - this is an absolute minimum. We can fit anything else @@ -986,7 +1005,8 @@ if segmented then fmap Count $ - dPrimVE "groups_per_segment" $ unCount num_groups' `divUp` hist_Nout + dPrimVE "groups_per_segment" $ + unCount num_groups' `divUp` hist_Nout else pure num_groups' -- We only use local memory if the number of updates per histogram @@ -1007,7 +1027,11 @@ emit $ Imp.DebugPrint "Cooperation level (C)" $ Just $ untyped hist_C emit $ Imp.DebugPrint "Number of chunks (S)" $ Just $ untyped hist_S when segmented $ - emit $ Imp.DebugPrint "Groups per segment" $ Just $ untyped $ unCount groups_per_segment + emit $ + Imp.DebugPrint "Groups per segment" $ + Just $ + untyped $ + unCount groups_per_segment histKernelLocal hist_M groups_per_segment @@ -1084,7 +1108,10 @@ emit $ Imp.DebugPrint "Input elements per histogram (N)" $ Just $ untyped hist_N emit $ Imp.DebugPrint "Number of segments" $ - Just $ untyped $ product $ map (toInt64Exp . snd) segment_dims + Just $ + untyped $ + product $ + map (toInt64Exp . snd) segment_dims emit $ Imp.DebugPrint "Histogram element size (el_size)" $ Just $ untyped hist_el_size emit $ Imp.DebugPrint "Race factor (RF)" $ Just $ untyped hist_RF emit $ Imp.DebugPrint "Memory per set of subhistograms per segment" $ Just $ untyped h 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 @@ -25,14 +25,14 @@ compileSegMap pat lvl space kbody = do let (is, dims) = unzip $ unSegSpace space dims' = map toInt64Exp dims - num_groups' = toInt64Exp <$> segNumGroups lvl group_size' = toInt64Exp <$> segGroupSize lvl + attrs = defKernelAttrs (segNumGroups lvl) (segGroupSize lvl) emit $ Imp.DebugPrint "\n# SegMap" Nothing case lvl of SegThread {} -> do virt_num_groups <- dPrimVE "virt_num_groups" $ sExt32 $ product dims' `divUp` unCount group_size' - sKernelThread "segmap" (segFlat space) (defKernelAttrs num_groups' group_size') $ + sKernelThread "segmap" (segFlat space) attrs $ virtualiseGroups (segVirt lvl) virt_num_groups $ \group_id -> do local_tid <- kernelLocalThreadId . kernelConstants <$> askEnv @@ -50,7 +50,7 @@ SegGroup {} -> do pc <- precomputeConstants group_size' $ kernelBodyStms kbody virt_num_groups <- dPrimVE "virt_num_groups" $ sExt32 $ product dims' - sKernelGroup "segmap_intragroup" (segFlat space) (defKernelAttrs num_groups' group_size') $ do + sKernelGroup "segmap_intragroup" (segFlat space) attrs $ do precomputedConstants pc $ virtualiseGroups (segVirt lvl) virt_num_groups $ \group_id -> do dIndexSpace (zip is dims') $ sExt64 group_id 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 @@ -139,7 +139,9 @@ MemArray pt shape _ (ArrayIn mem _) -> do let shape' = Shape [num_threads] <> shape sArray "red_arr" pt shape' mem $ - IxFun.iota $ map pe64 $ shapeDims shape' + IxFun.iota $ + map pe64 $ + shapeDims shape' _ -> do let pt = elemType $ paramType p shape = Shape [group_size] @@ -188,7 +190,7 @@ counter <- sStaticArray "counter" (Space "device") int32 $ - Imp.ArrayValues $ replicate (fromIntegral maxNumOps) $ IntValue $ Int32Value 0 + Imp.ArrayZeros (fromIntegral maxNumOps) reds_group_res_arrs <- groupResultArrays num_groups group_size reds @@ -198,7 +200,7 @@ emit $ Imp.DebugPrint "\n# SegRed" Nothing - sKernelThread "segred_nonseg" (segFlat space) (defKernelAttrs num_groups' group_size') $ do + sKernelThread "segred_nonseg" (segFlat space) (defKernelAttrs num_groups group_size) $ do constants <- kernelConstants <$> askEnv sync_arr <- sAllocArray "sync_arr" Bool (Shape [intConst Int32 1]) $ Space "local" reds_arrs <- mapM (intermediateArrays group_size (tvSize num_threads)) reds @@ -284,7 +286,7 @@ emit $ Imp.DebugPrint "segments_per_group" $ Just $ untyped segments_per_group emit $ Imp.DebugPrint "required_groups" $ Just $ untyped required_groups - sKernelThread "segred_small" (segFlat space) (defKernelAttrs num_groups' group_size') $ do + sKernelThread "segred_small" (segFlat space) (defKernelAttrs num_groups group_size) $ do constants <- kernelConstants <$> askEnv reds_arrs <- mapM (intermediateArrays group_size (Var $ tvVar num_threads)) reds @@ -318,9 +320,12 @@ sComment "apply map function if in bounds" $ sIf - ( segment_size .>. 0 + ( segment_size + .>. 0 .&&. isActive (init $ zip gtids dims) - .&&. ltid .<. segment_size * segments_per_group + .&&. ltid + .<. segment_size + * segments_per_group ) in_bounds out_of_bounds @@ -340,22 +345,27 @@ sOp $ Imp.Barrier Imp.FenceLocal - sComment "save final values of segments" $ - sWhen - ( sExt64 group_id' * segments_per_group + sExt64 ltid .<. num_segments - .&&. ltid .<. segments_per_group + sComment "save final values of segments" + $ sWhen + ( sExt64 group_id' + * segments_per_group + + sExt64 ltid + .<. num_segments + .&&. ltid + .<. segments_per_group ) - $ forM_ (zip segred_pes (concat reds_arrs)) $ \(pe, arr) -> do - -- Figure out which segment result this thread should write... - let flat_segment_index = - sExt64 group_id' * segments_per_group + sExt64 ltid - gtids' = - unflattenIndex (init dims') flat_segment_index - copyDWIMFix - (patElemName pe) - gtids' - (Var arr) - [(ltid + 1) * segment_size_nonzero - 1] + $ forM_ (zip segred_pes (concat reds_arrs)) + $ \(pe, arr) -> do + -- Figure out which segment result this thread should write... + let flat_segment_index = + sExt64 group_id' * segments_per_group + sExt64 ltid + gtids' = + unflattenIndex (init dims') flat_segment_index + copyDWIMFix + (patElemName pe) + gtids' + (Var arr) + [(ltid + 1) * segment_size_nonzero - 1] -- Finally another barrier, because we will be writing to the -- local memory array first thing in the next iteration. @@ -423,7 +433,7 @@ sStaticArray "counter" (Space "device") int32 $ Imp.ArrayZeros num_counters - sKernelThread "segred_large" (segFlat space) (defKernelAttrs num_groups' group_size') $ do + sKernelThread "segred_large" (segFlat space) (defKernelAttrs num_groups group_size) $ do constants <- kernelConstants <$> askEnv reds_arrs <- mapM (intermediateArrays group_size (tvSize num_threads)) reds sync_arr <- sAllocArray "sync_arr" Bool (Shape [intConst Int32 1]) $ Space "local" @@ -640,7 +650,7 @@ let index_in_segment = global_tid `quot` kernelGroupSize constants in sExt64 local_tid + (index_in_segment * Imp.unCount elems_per_thread + i) - * kernelGroupSize constants + * kernelGroupSize constants check_bounds $ sComment "apply map function" $ @@ -655,16 +665,16 @@ sComment "load new values" $ forM_ (zip (nextParams slug) red_res) $ \(p, (res, res_is)) -> copyDWIMFix (paramName p) [] res (res_is ++ vec_is) - sComment "apply reduction operator" $ - compileStms mempty (bodyStms $ slugBody slug) $ - sComment "store in accumulator" $ - forM_ - ( zip - (slugAccs slug) - (map resSubExp $ bodyResult $ slugBody slug) - ) - $ \((acc, acc_is), se) -> - copyDWIMFix acc (acc_is ++ vec_is) se [] + sComment "apply reduction operator" + $ compileStms mempty (bodyStms $ slugBody slug) + $ sComment "store in accumulator" + $ forM_ + ( zip + (slugAccs slug) + (map resSubExp $ bodyResult $ slugBody slug) + ) + $ \((acc, acc_is), se) -> + copyDWIMFix acc (acc_is ++ vec_is) se [] case comm of Noncommutative -> do @@ -756,14 +766,14 @@ sOp $ Imp.MemFence Imp.FenceGlobal -- Increment the counter, thus stating that our result is -- available. - sOp $ - Imp.Atomic DefaultSpace $ - Imp.AtomicAdd - Int32 - (tvVar old_counter) - counter_mem - counter_offset - $ untyped (1 :: Imp.TExp Int32) + sOp + $ Imp.Atomic DefaultSpace + $ Imp.AtomicAdd + Int32 + (tvVar old_counter) + counter_mem + counter_offset + $ untyped (1 :: Imp.TExp Int32) -- Now check if we were the last group to write our result. If -- so, it is our responsibility to produce the final result. sWrite sync_arr [0] $ untyped $ tvExp old_counter .==. groups_per_segment - 1 @@ -783,7 +793,8 @@ sOp $ Imp.Atomic DefaultSpace $ Imp.AtomicAdd Int32 (tvVar old_counter) counter_mem counter_offset $ - untyped $ negate groups_per_segment + untyped $ + negate groups_per_segment sLoopNest (slugShape slug) $ \vec_is -> do -- There is no guarantee that the number of workgroups for the 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 @@ -217,52 +217,57 @@ CallKernelGen () compileSegScan pat lvl space scanOp kbody = do 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)) - num_threads = unCount num_groups * unCount group_size - (gtids, dims) = unzip $ unSegSpace space - dims' = map toInt64Exp dims - segmented = length dims' > 1 - not_segmented_e = if segmented then false else true - segment_size = last dims' scanOpNe = segBinOpNeutral scanOp tys = map (\(Prim pt) -> pt) $ lambdaReturnType $ segBinOpLambda scanOp - - statusX, statusA, statusP :: Num a => a - statusX = 0 - statusA = 1 - statusP = 2 + n = product $ map pe64 $ segSpaceDims space sumT :: Integer maxT :: Integer sumT = foldl (\bytes typ -> bytes + primByteSize typ) 0 tys primByteSize' = max 4 . primByteSize sumT' = foldl (\bytes typ -> bytes + primByteSize' typ) 0 tys `div` 4 maxT = maximum (map primByteSize tys) + m :: Num a => a + m = fromIntegral $ max 1 $ min mem_constraint reg_constraint -- TODO: Make these constants dynamic by querying device k_reg = 64 k_mem = 95 mem_constraint = max k_mem sumT `div` maxT reg_constraint = (k_reg - 1 - sumT') `div` (2 * sumT') - m :: Num a => a - m = fromIntegral $ max 1 $ min mem_constraint reg_constraint - emit $ Imp.DebugPrint "SegScan: number of elements processed sequentially per thread is m:" $ Just $ untyped (m :: Imp.TExp Int32) - emit $ Imp.DebugPrint "SegScan: memory constraints is: " $ Just $ untyped (fromIntegral mem_constraint :: Imp.TExp Int32) - emit $ Imp.DebugPrint "SegScan: register constraints is: " $ Just $ untyped (fromIntegral reg_constraint :: Imp.TExp Int32) - emit $ Imp.DebugPrint "SegScan: sumT' is: " $ Just $ untyped (fromIntegral sumT' :: Imp.TExp Int32) + group_size = segGroupSize lvl + group_size' = pe64 $ unCount group_size - -- Allocate the shared memory for output component - numThreads <- dPrimV "numThreads" num_threads - numGroups <- dPrimV "numGroups" $ unCount num_groups + num_groups <- + Count . tvSize <$> dPrimV "num_groups" (n `divUp` (group_size' * m)) + let num_groups' = pe64 (unCount num_groups) + num_threads <- + dPrimVE "num_threads" $ num_groups' * group_size' + + let (gtids, dims) = unzip $ unSegSpace space + dims' = map toInt64Exp dims + segmented = length dims' > 1 + not_segmented_e = if segmented then false else true + segment_size = last dims' + + statusX, statusA, statusP :: Num a => a + statusX = 0 + statusA = 1 + statusP = 2 + + emit $ Imp.DebugPrint "Sequential elements per thread (m):" $ Just $ untyped (m :: Imp.TExp Int32) + emit $ Imp.DebugPrint "Memory constraint " $ Just $ untyped (fromIntegral mem_constraint :: Imp.TExp Int32) + emit $ Imp.DebugPrint "Register constraint" $ Just $ untyped (fromIntegral reg_constraint :: Imp.TExp Int32) + emit $ Imp.DebugPrint "sumT'" $ Just $ untyped (fromIntegral sumT' :: Imp.TExp Int32) + globalId <- sStaticArray "id_counter" (Space "device") int32 $ Imp.ArrayZeros 1 - statusFlags <- sAllocArray "status_flags" int8 (Shape [tvSize numGroups]) (Space "device") + statusFlags <- sAllocArray "status_flags" int8 (Shape [unCount num_groups]) (Space "device") (aggregateArrays, incprefixArrays) <- fmap unzip $ forM tys $ \ty -> - (,) <$> sAllocArray "aggregates" ty (Shape [tvSize numGroups]) (Space "device") - <*> sAllocArray "incprefixes" ty (Shape [tvSize numGroups]) (Space "device") + (,) + <$> sAllocArray "aggregates" ty (Shape [unCount num_groups]) (Space "device") + <*> sAllocArray "incprefixes" ty (Shape [unCount num_groups]) (Space "device") sReplicate statusFlags $ intConst Int8 statusX @@ -299,10 +304,12 @@ sgmIdx <- dPrimVE "sgm_idx" $ tvExp blockOff `mod` segment_size boundary <- dPrimVE "boundary" $ - sExt32 $ sMin64 (m * unCount group_size) (segment_size - sgmIdx) + sExt32 $ + sMin64 (m * group_size') (segment_size - sgmIdx) segsize_compact <- dPrimVE "segsize_compact" $ - sExt32 $ sMin64 (m * unCount group_size) segment_size + sExt32 $ + sMin64 (m * group_size') segment_size privateArrays <- forM tys $ \ty -> sAllocArray @@ -316,7 +323,8 @@ -- The map's input index phys_tid <- dPrimVE "phys_tid" $ - tvExp blockOff + sExt64 (kernelLocalThreadId constants) + tvExp blockOff + + sExt64 (kernelLocalThreadId constants) + i * kernelGroupSize constants dIndexSpace (zip gtids dims') phys_tid -- Perform the map @@ -397,7 +405,7 @@ sComment "Scan results (with warp scan)" $ do groupScan crossesSegment - (tvExp numThreads) + num_threads (kernelGroupSize constants) scanOp' prefixArrays @@ -434,7 +442,7 @@ sWhen (bNot blockNewSgm .&&. kernelLocalThreadId constants .<. warpSize) $ do sWhen (kernelLocalThreadId constants .==. 0) $ do sIf - (not_segmented_e .||. boundary .==. sExt32 (unCount group_size * m)) + (not_segmented_e .||. boundary .==. sExt32 (group_size' * m)) ( do everythingVolatile $ forM_ (zip aggregateArrays accs) $ \(aggregateArray, acc) -> @@ -469,7 +477,8 @@ ( do readOffset <- dPrimV "readOffset" $ - sExt32 $ tvExp dynamicId - sExt64 (kernelWaveSize constants) + sExt32 $ + tvExp dynamicId - sExt64 (kernelWaveSize constants) let loopStop = warpSize * (-1) sameSegment readIdx | segmented = @@ -510,7 +519,7 @@ lam' <- renameLambda scanOp' inBlockScanLookback constants - (tvExp numThreads) + num_threads warpscan exchanges lam' @@ -544,7 +553,7 @@ scanOp'''' <- renameLambda scanOp' let xs = map paramName $ take (length tys) $ lambdaParams scanOp'''' ys = map paramName $ drop (length tys) $ lambdaParams scanOp'''' - sWhen (boundary .==. sExt32 (unCount group_size * m)) $ do + sWhen (boundary .==. sExt32 (group_size' * m)) $ do forM_ (zip xs prefixes) $ \(x, prefix) -> dPrimV_ x $ tvExp prefix forM_ (zip ys accs) $ \(y, acc) -> dPrimV_ y $ tvExp acc compileStms mempty (bodyStms $ lambdaBody scanOp'''') $ @@ -616,7 +625,8 @@ sFor "i" m $ \i -> do flat_idx <- dPrimVE "flat_idx" $ - tvExp blockOff + kernelGroupSize constants * i + tvExp blockOff + + kernelGroupSize constants * i + sExt64 (kernelLocalThreadId constants) dIndexSpace (zip gtids dims') flat_idx sWhen (flat_idx .<. n) $ do @@ -628,5 +638,5 @@ sOp localBarrier sComment "If this is the last block, reset the dynamicId" $ - sWhen (tvExp dynamicId .==. unCount num_groups - 1) $ + sWhen (tvExp dynamicId .==. num_groups' - 1) $ copyDWIMFix globalId [0] (constant (0 :: Int32)) [] 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 @@ -43,7 +43,9 @@ let shape' = Shape [num_threads] <> shape arr <- lift . sArray "scan_arr" pt shape' mem $ - IxFun.iota $ map pe64 $ shapeDims shape' + IxFun.iota $ + map pe64 $ + shapeDims shape' pure (arr, []) _ -> do let pt = elemType $ paramType p @@ -170,7 +172,7 @@ (to - from) .>. (to `rem` segment_size) _ -> Nothing - sKernelThread "scan_stage1" (segFlat space) (defKernelAttrs num_groups' group_size') $ do + sKernelThread "scan_stage1" (segFlat space) (defKernelAttrs num_groups group_size) $ do constants <- kernelConstants <$> askEnv all_local_arrs <- makeLocalArrays group_size (tvSize num_threads) scans @@ -219,7 +221,8 @@ sWhen in_bounds when_in_bounds unless (all (null . segBinOpShape) scans) $ - sOp $ Imp.Barrier Imp.FenceGlobal + sOp $ + Imp.Barrier Imp.FenceGlobal forM_ (zip3 per_scan_pes scans all_local_arrs) $ \(pes, scan@(SegBinOp _ scan_op nes vec_shape), local_arrs) -> @@ -287,7 +290,8 @@ then sExt64 (kernelGroupSize constants) - 1 else (sExt64 (kernelGroupId constants) + 1) - * sExt64 (kernelGroupSize constants) - 1 + * sExt64 (kernelGroupSize constants) + - 1 ] load_neutral = forM_ (zip nes scan_x_params) $ \(ne, p) -> @@ -300,7 +304,8 @@ Just f -> f ( tvExp chunk_offset - + sExt64 (kernelGroupSize constants) - 1 + + sExt64 (kernelGroupSize constants) + - 1 ) ( tvExp chunk_offset + sExt64 (kernelGroupSize constants) @@ -331,7 +336,6 @@ -- Our group size is the number of groups for the stage 1 kernel. let group_size = Count $ unCount num_groups - group_size' = fmap toInt64Exp group_size let crossesSegment' = do f <- crossesSegment @@ -340,7 +344,7 @@ ((sExt64 from + 1) * elems_per_group - 1) ((sExt64 to + 1) * elems_per_group - 1) - sKernelThread "scan_stage2" (segFlat space) (defKernelAttrs 1 group_size') $ do + sKernelThread "scan_stage2" (segFlat space) (defKernelAttrs (Count (intConst Int64 1)) group_size) $ do constants <- kernelConstants <$> askEnv per_scan_local_arrs <- makeLocalArrays group_size (tvSize stage1_num_threads) scans let per_scan_rets = map (lambdaReturnType . segBinOpLambda) scans @@ -403,15 +407,15 @@ [SegBinOp GPUMem] -> CallKernelGen () 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 + let group_size' = fmap toInt64Exp group_size (gtids, dims) = unzip $ unSegSpace space dims' = map toInt64Exp dims required_groups <- dPrimVE "required_groups" $ - sExt32 $ product dims' `divUp` sExt64 (unCount group_size') + sExt32 $ + product dims' `divUp` sExt64 (unCount group_size') - sKernelThread "scan_stage3" (segFlat space) (defKernelAttrs num_groups' group_size') $ + sKernelThread "scan_stage3" (segFlat space) (defKernelAttrs num_groups group_size) $ virtualiseGroups SegVirt required_groups $ \virt_group_id -> do constants <- kernelConstants <$> askEnv @@ -498,7 +502,9 @@ fmap (Imp.Count . tvSize) $ dPrimV "stage1_num_groups" $ sMin64 (tvExp stage1_max_num_groups) $ - toInt64Exp $ Imp.unCount $ segNumGroups lvl + toInt64Exp $ + Imp.unCount $ + segNumGroups lvl (stage1_num_threads, elems_per_group, crossesSegment) <- scanStage1 pat stage1_num_groups (segGroupSize lvl) space scans kbody 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 @@ -51,6 +51,7 @@ ) = (`runState` initialOpenCL) . (`runReaderT` defFuns prog) $ do let ImpGPU.Definitions + types (ImpGPU.Constants ps consts) (ImpGPU.Functions funs) = prog consts' <- traverse (onHostOp target) consts @@ -59,6 +60,7 @@ pure $ ImpOpenCL.Definitions + types (ImpOpenCL.Constants ps consts') (ImpOpenCL.Functions funs') @@ -248,7 +250,8 @@ (local_memory_args, local_memory_params, local_memory_init) = unzip3 . flip evalState (blankNameSource :: VNameSource) $ - mapM (prepareLocalMemory target) $ kernelLocalMemory kstate + mapM (prepareLocalMemory target) $ + kernelLocalMemory kstate -- CUDA has very strict restrictions on the number of blocks -- permitted along the 'y' and 'z' dimensions of the grid @@ -756,7 +759,7 @@ error "Cannot deallocate memory in kernel" copyInKernel :: GC.Copy KernelOp KernelState - copyInKernel _ _ _ _ _ _ _ = + copyInKernel _ _ _ _ _ _ _ _ = error "Cannot bulk copy in kernel." noStaticArrays :: GC.StaticArray KernelOp KernelState @@ -790,9 +793,10 @@ | otherwise = do let out_args = [[C.cexp|&$id:d|] | d <- dests] args' = - [C.cexp|global_failure|] : - [C.cexp|global_failure_args|] : - out_args ++ args + [C.cexp|global_failure|] + : [C.cexp|global_failure_args|] + : out_args + ++ args what_next <- whatNext diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Transpose.hs b/src/Futhark/CodeGen/ImpGen/GPU/Transpose.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/Transpose.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/Transpose.hs @@ -67,22 +67,26 @@ mkTranspose $ lowDimBody (le32 get_group_id_0 * block_dim + (le32 get_local_id_0 `quot` muly)) - ( le32 get_group_id_1 * block_dim * muly + le32 get_local_id_1 + ( le32 get_group_id_1 * block_dim * muly + + le32 get_local_id_1 + (le32 get_local_id_0 `rem` muly) * block_dim ) - ( le32 get_group_id_1 * block_dim * muly + le32 get_local_id_0 + ( le32 get_group_id_1 * block_dim * muly + + le32 get_local_id_0 + (le32 get_local_id_1 `rem` muly) * block_dim ) (le32 get_group_id_0 * block_dim + (le32 get_local_id_1 `quot` muly)) TransposeLowHeight -> mkTranspose $ lowDimBody - ( le32 get_group_id_0 * block_dim * mulx + le32 get_local_id_0 + ( le32 get_group_id_0 * block_dim * mulx + + le32 get_local_id_0 + (le32 get_local_id_1 `rem` mulx) * block_dim ) (le32 get_group_id_1 * block_dim + (le32 get_local_id_1 `quot` mulx)) (le32 get_group_id_1 * block_dim + (le32 get_local_id_0 `quot` mulx)) - ( le32 get_group_id_0 * block_dim * mulx + le32 get_local_id_1 + ( le32 get_group_id_0 * block_dim * mulx + + le32 get_local_id_1 + (le32 get_local_id_0 `rem` mulx) * block_dim ) TransposeNormal -> 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 @@ -5,7 +5,6 @@ module Futhark.CodeGen.ImpGen.Multicore ( Futhark.CodeGen.ImpGen.Multicore.compileProg, Warnings, - SchedulingMode (..), ) where @@ -41,22 +40,19 @@ (Or Int64, Imp.AtomicOr Int64) ] -data SchedulingMode = AllowDynamicScheduling | NoDynamicScheduling - -- | Compile the program. compileProg :: MonadFreshNames m => - SchedulingMode -> Prog MCMem -> m (Warnings, Imp.Definitions Imp.Multicore) -compileProg sched = Futhark.CodeGen.ImpGen.compileProg (HostEnv gccAtomics mempty) ops Imp.DefaultSpace +compileProg = Futhark.CodeGen.ImpGen.compileProg (HostEnv gccAtomics mempty) ops Imp.DefaultSpace where ops = (defaultOperations opCompiler) { opsExpCompiler = compileMCExp } opCompiler dest (Alloc e space) = compileAlloc dest e space - opCompiler dest (Inner op) = compileMCOp sched dest op + opCompiler dest (Inner op) = compileMCOp dest op updateAcc :: VName -> [SubExp] -> [SubExp] -> MulticoreGen () updateAcc acc is vs = sComment "UpdateAcc" $ do @@ -121,12 +117,11 @@ defCompileExp dest e compileMCOp :: - SchedulingMode -> Pat LetDecMem -> MCOp MCMem () -> ImpM MCMem HostEnv Imp.Multicore () -compileMCOp _ _ (OtherOp ()) = pure () -compileMCOp sched pat (ParOp par_op op) = do +compileMCOp _ (OtherOp ()) = pure () +compileMCOp pat (ParOp par_op op) = do let space = getSpace op dPrimV_ (segFlat space) (0 :: Imp.TExp Int64) iterations <- getIterationDomain op space @@ -154,9 +149,7 @@ free_params <- filter (`notElem` retvals) <$> freeParams (par_task, seq_task) emit . Imp.Op $ Imp.SegOp s free_params seq_task par_task retvals $ - case sched of - AllowDynamicScheduling -> scheduling_info (decideScheduling' op seq_code) - NoDynamicScheduling -> scheduling_info Imp.Static + scheduling_info (decideScheduling' op seq_code) compileSegOp :: Pat LetDecMem -> diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs @@ -20,7 +20,13 @@ getIterationDomain, getReturnParams, segOpString, + ChunkLoopVectorization (..), generateChunkLoop, + generateUniformizeLoop, + extractVectorLane, + inISPC, + toParam, + sLoopNestVectorized, ) where @@ -164,6 +170,9 @@ isLoadBalanced (Imp.Comment _ a) = isLoadBalanced a isLoadBalanced Imp.While {} = False isLoadBalanced (Imp.Op (Imp.ParLoop _ code _)) = isLoadBalanced code +isLoadBalanced (Imp.Op (Imp.ForEachActive _ a)) = isLoadBalanced a +isLoadBalanced (Imp.Op (Imp.ForEach _ _ _ a)) = isLoadBalanced a +isLoadBalanced (Imp.Op (Imp.ISPCKernel a _)) = isLoadBalanced a isLoadBalanced _ = True segBinOpComm' :: [SegBinOp rep] -> Commutativity @@ -215,9 +224,7 @@ (free_allocs, here_allocs) = f body_allocs free' = filter - ( not - . (`nameIn` Imp.declaredIn body_allocs) - . Imp.paramName + ( (`notNameIn` Imp.declaredIn body_allocs) . Imp.paramName ) free in ( free_allocs, @@ -226,6 +233,11 @@ f code = (mempty, code) +-- | Indicates whether to vectorize a chunk loop or keep it sequential. +-- We use this to allow falling back to sequential chunk loops in cases +-- we don't care about trying to vectorize. +data ChunkLoopVectorization = Vectorized | Scalar + -- | Emit code for the chunk loop, given an action that generates code -- for a single iteration. -- @@ -233,10 +245,10 @@ -- iteration. generateChunkLoop :: String -> + ChunkLoopVectorization -> (Imp.TExp Int64 -> MulticoreGen ()) -> MulticoreGen () -generateChunkLoop desc m = do - emit $ Imp.DebugPrint (desc <> " " <> "fbody") Nothing +generateChunkLoop desc Scalar m = do (start, end) <- getLoopBounds n <- dPrimVE "n" $ end - start i <- newVName (desc <> "_i") @@ -245,9 +257,100 @@ addLoopVar i Int64 m $ start + Imp.le64 i emit body_allocs - emit $ Imp.For i (untyped n) body + -- Emit either foreach or normal for loop + let bound = untyped n + emit $ Imp.For i bound body +generateChunkLoop desc Vectorized m = do + (start, end) <- getLoopBounds + n <- dPrimVE "n" $ end - start + i <- newVName (desc <> "_i") + (body_allocs, body) <- fmap extractAllocations $ + collect $ do + addLoopVar i Int64 + m $ Imp.le64 i + emit body_allocs + -- Emit either foreach or normal for loop + let from = untyped start + let bound = untyped (start + n) + emit $ Imp.Op $ Imp.ForEach i from bound body +-- | Emit code for a sequential loop over each vector lane, given +-- and action that generates code for a single iteration. The action +-- is called with the symbolic index of the current iteration. +generateUniformizeLoop :: (Imp.TExp Int64 -> MulticoreGen ()) -> MulticoreGen () +generateUniformizeLoop m = do + i <- newVName "uni_i" + body <- collect $ do + addLoopVar i Int64 + m $ Imp.le64 i + emit $ Imp.Op $ Imp.ForEachActive i body + +-- | Given a piece of code, if that code performs an assignment, turn +-- that assignment into an extraction of element from a vector on the +-- right hand side, using a passed index for the extraction. Other code +-- is left as is. +extractVectorLane :: Imp.TExp Int64 -> MulticoreGen Imp.MCCode -> MulticoreGen () +extractVectorLane j code = do + let ut_exp = untyped j + code' <- code + case code' of + Imp.SetScalar vname e -> do + typ <- lookupType vname + case typ of + -- ISPC v1.17 does not support extract on f16 yet.. + -- Thus we do this stupid conversion to f32 + Prim (FloatType Float16) -> do + tv <- dPrim "hack_extract_f16" (FloatType Float32) + emit $ Imp.SetScalar (tvVar tv) e + emit $ Imp.Op $ Imp.ExtractLane vname (untyped $ tvExp tv) ut_exp + _ -> emit $ Imp.Op $ Imp.ExtractLane vname e ut_exp + _ -> + emit code' + +-- | Given an action that may generate some code, put that code +-- into an ISPC kernel. +inISPC :: MulticoreGen () -> MulticoreGen () +inISPC code = do + code' <- collect code + free <- freeParams code' + emit $ Imp.Op $ Imp.ISPCKernel code' free + ------------------------------- +------- SegRed helpers ------- +------------------------------- +sForVectorized' :: VName -> Imp.Exp -> MulticoreGen () -> MulticoreGen () +sForVectorized' i bound body = do + let it = case primExpType bound of + IntType bound_t -> bound_t + t -> error $ "sFor': bound " ++ pretty bound ++ " is of type " ++ pretty t + addLoopVar i it + body' <- collect body + emit $ Imp.Op $ Imp.ForEach i (Imp.ValueExp $ blankPrimValue $ Imp.IntType Imp.Int64) bound body' + +sForVectorized :: String -> Imp.TExp t -> (Imp.TExp t -> MulticoreGen ()) -> MulticoreGen () +sForVectorized i bound body = do + i' <- newVName i + sForVectorized' i' (untyped bound) $ + body $ + TPrimExp $ + Imp.var i' $ + primExpType $ + untyped bound + +-- | Like sLoopNest, but puts a vectorized loop at the innermost layer. +sLoopNestVectorized :: + Shape -> + ([Imp.TExp Int64] -> MulticoreGen ()) -> + MulticoreGen () +sLoopNestVectorized = sLoopNest' [] . shapeDims + where + sLoopNest' is [] f = f $ reverse is + sLoopNest' is [d] f = + sForVectorized "nest_i" (toInt64Exp d) $ \i -> sLoopNest' (i : is) [] f + sLoopNest' is (d : ds) f = + sFor "nest_i" (toInt64Exp d) $ \i -> sLoopNest' (i : is) ds f + +------------------------------- ------- SegHist helpers ------- ------------------------------- renameHistOpLambda :: [HistOp MCMem] -> MulticoreGen [HistOp MCMem] @@ -327,7 +430,8 @@ supportedPrims (primBitSize t) = AtomicCAS $ \[arr] bucket -> do old <- dPrim "old" t atomicUpdateCAS t arr (tvVar old) bucket (paramName xp) $ - compileBody' [xp] $ lambdaBody op + compileBody' [xp] $ + lambdaBody op atomicUpdateLocking _ op = AtomicLocking $ \locking arrs bucket -> do old <- dPrim "old" int32 continue <- dPrimVol "continue" int32 (0 :: Imp.TExp Int32) @@ -373,12 +477,14 @@ let op_body = sComment "execute operation" $ - compileBody' acc_params $ lambdaBody op + compileBody' acc_params $ + lambdaBody op do_hist = everythingVolatile $ sComment "update global result" $ - zipWithM_ (writeArray bucket) arrs $ map (Var . paramName) acc_params + zipWithM_ (writeArray bucket) arrs $ + map (Var . paramName) acc_params -- While-loop: Try to insert your value sWhile (tvExp continue .==. 0) $ do 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 @@ -11,6 +11,7 @@ import Futhark.CodeGen.ImpGen.Multicore.SegRed (compileSegRed') import Futhark.IR.MCMem import Futhark.MonadFreshNames +import Futhark.Transform.Rename (renameLambda) import Futhark.Util (chunks, splitFromEnd, takeLast) import Futhark.Util.IntegralExp (rem) import Prelude hiding (quot, rem) @@ -36,6 +37,16 @@ histSize :: HistOp MCMem -> Imp.TExp Int64 histSize = product . map toInt64Exp . shapeDims . histShape +genHistOpParams :: HistOp MCMem -> MulticoreGen () +genHistOpParams histops = + dScope Nothing $ scopeOfLParams $ lambdaParams $ histOp histops + +renameHistop :: HistOp MCMem -> MulticoreGen (HistOp MCMem) +renameHistop histop = do + let op = histOp histop + lambda' <- renameLambda op + pure histop {histOp = lambda'} + nonsegmentedHist :: Pat LetDecMem -> SegSpace -> @@ -107,7 +118,7 @@ body <- collect $ do dPrim_ (segFlat space) int64 sOp $ Imp.GetTaskId (segFlat space) - generateChunkLoop "SegHist" $ \flat_idx -> do + generateChunkLoop "SegHist" Scalar $ \flat_idx -> do zipWithM_ dPrimV_ is $ unflattenIndex ns_64 flat_idx compileStms mempty (kernelBodyStms kbody) $ do let (red_res, map_res) = @@ -138,18 +149,23 @@ free_params <- freeParams body emit $ Imp.Op $ Imp.ParLoop "atomic_seg_hist" body free_params -updateHisto :: HistOp MCMem -> [VName] -> [Imp.TExp Int64] -> MulticoreGen () -updateHisto op arrs bucket = do - let acc_params = take (length arrs) $ lambdaParams $ histOp op - bind_acc_params = - forM_ (zip acc_params arrs) $ \(acc_p, arr) -> - copyDWIMFix (paramName acc_p) [] (Var arr) bucket +updateHisto :: + HistOp MCMem -> + [VName] -> + [Imp.TExp Int64] -> + Imp.TExp Int64 -> + [Param LParamMem] -> + MulticoreGen () +updateHisto op arrs bucket j uni_acc = do + let bind_acc_params = + forM_ (zip uni_acc arrs) $ \(acc_u, arr) -> do + copyDWIMFix (paramName acc_u) [] (Var arr) bucket + op_body = compileBody' [] $ lambdaBody $ histOp op - writeArray arr val = copyDWIMFix arr bucket val [] + writeArray arr val = extractVectorLane j $ collect $ copyDWIMFix arr bucket val [] do_hist = zipWithM_ writeArray arrs $ map resSubExp $ bodyResult $ lambdaBody $ histOp op sComment "Start of body" $ do - dLParams acc_params bind_acc_params op_body do_hist @@ -211,36 +227,55 @@ pure op_local_subhistograms - generateChunkLoop "SegRed" $ \i -> do - zipWithM_ dPrimV_ is $ unflattenIndex ns_64 i - compileStms mempty (kernelBodyStms kbody) $ do - let (red_res, map_res) = - splitFromEnd (length map_pes) $ - map kernelResultSubExp $ kernelBodyResult kbody + inISPC $ + generateChunkLoop "SegRed" Vectorized $ \i -> do + zipWithM_ dPrimV_ is $ unflattenIndex ns_64 i + compileStms mempty (kernelBodyStms kbody) $ do + let (red_res, map_res) = + splitFromEnd (length map_pes) $ + map kernelResultSubExp $ + kernelBodyResult kbody - sComment "save map-out results" $ - forM_ (zip map_pes map_res) $ \(pe, res) -> - copyDWIMFix (patElemName pe) (map Imp.le64 is) res [] + sComment "save map-out results" $ + forM_ (zip map_pes map_res) $ \(pe, res) -> + copyDWIMFix (patElemName pe) (map Imp.le64 is) res [] - forM_ (zip3 histops local_subhistograms (splitHistResults histops red_res)) $ - \( histop@(HistOp dest_shape _ _ _ shape lam), - histop_subhistograms, - (bucket, vs') - ) -> do - let bucket' = map toInt64Exp bucket - dest_shape' = map toInt64Exp $ shapeDims dest_shape - bucket_in_bounds = - inBounds (Slice (map DimFix bucket')) dest_shape' - vs_params = takeLast (length vs') $ lambdaParams lam + forM_ (zip3 histops local_subhistograms (splitHistResults histops red_res)) $ + \( histop@(HistOp dest_shape _ _ _ shape _), + histop_subhistograms, + (bucket, vs') + ) -> do + histop' <- renameHistop histop - sComment "perform updates" $ - sWhen bucket_in_bounds $ do - dLParams $ lambdaParams lam - sLoopNest shape $ \is' -> do - forM_ (zip vs_params vs') $ \(p, res) -> - copyDWIMFix (paramName p) [] res is' - updateHisto histop histop_subhistograms (bucket' ++ is') + let bucket' = map toInt64Exp bucket + dest_shape' = map toInt64Exp $ shapeDims dest_shape + acc_params' = (lambdaParams . histOp) histop' + vs_params' = takeLast (length vs') $ lambdaParams $ histOp histop' + generateUniformizeLoop $ \j -> + sComment "perform updates" $ do + -- Create new set of uniform buckets + -- That is extract each bucket from a SIMD vector lane + extract_buckets <- mapM (dPrim "extract_bucket" . (primExpType . untyped)) bucket' + forM_ (zip extract_buckets bucket') $ \(x, y) -> + emit $ Imp.Op $ Imp.ExtractLane (tvVar x) (untyped y) (untyped j) + let bucket'' = map tvExp extract_buckets + bucket_in_bounds = + inBounds (Slice (map DimFix bucket'')) dest_shape' + sWhen bucket_in_bounds $ do + genHistOpParams histop' + sLoopNest shape $ \is' -> do + -- read values vs and perform lambda writing result back to is + forM_ (zip vs_params' vs') $ \(p, res) -> + ifPrimType (paramType p) $ \pt -> do + -- Hack to copy varying load into uniform result variable + tmp <- dPrim "tmp" pt + copyDWIMFix (tvVar tmp) [] res is' + extractVectorLane j $ + pure $ + Imp.SetScalar (paramName p) (Imp.LeafExp (tvVar tmp) pt) + updateHisto histop' histop_subhistograms (bucket'' ++ is') j acc_params' + -- Copy the task-local subhistograms to the global subhistograms, -- where they will be combined. forM_ (zip (concat global_subhistograms) (concat local_subhistograms)) $ @@ -268,11 +303,12 @@ sOp $ Imp.GetNumTasks $ tvVar nsubtasks emit <=< compileSegRed' (Pat red_pes) segred_space [segred_op] nsubtasks $ \red_cont -> red_cont $ - flip map hists $ \subhisto -> - ( Var subhisto, - map Imp.le64 $ - map fst segment_dims ++ [subhistogram_id] ++ bucket_ids - ) + segBinOpChunks [segred_op] $ + flip map hists $ \subhisto -> + ( Var subhisto, + map Imp.le64 $ + map fst segment_dims ++ [subhistogram_id] ++ bucket_ids + ) let ns_red = map (toInt64Exp . snd) $ unSegSpace segred_space iterations = product $ init ns_red -- The segmented reduction is sequential over the inner most dimension @@ -282,7 +318,10 @@ emit $ Imp.Op $ Imp.SegOp "seghist_red" free_params_red red_task Nothing mempty scheduler_info where segment_dims = init $ unSegSpace space + ifPrimType (Prim pt) f = f pt + ifPrimType _ _ = pure () +-- Note: This isn't currently used anywhere. -- This implementation for a Segmented Hist only -- parallelize over the segments, -- where each segment is updated sequentially. @@ -316,7 +355,7 @@ dPrim_ (segFlat space) int64 sOp $ Imp.GetTaskId (segFlat space) - generateChunkLoop "SegHist" $ \idx -> do + generateChunkLoop "SegHist" Scalar $ \idx -> do let inner_bound = last ns_64 sFor "i" inner_bound $ \i -> do zipWithM_ dPrimV_ (init is) $ unflattenIndex (init ns_64) idx @@ -325,7 +364,8 @@ compileStms mempty (kernelBodyStms kbody) $ do let (red_res, map_res) = splitFromEnd (length map_pes) $ - map kernelResultSubExp $ kernelBodyResult kbody + map kernelResultSubExp $ + kernelBodyResult kbody forM_ (zip3 per_red_pes histops (splitHistResults histops red_res)) $ \(red_pes, HistOp dest_shape _ _ _ shape lam, (bucket, vs')) -> do let (is_params, vs_params) = splitAt (length vs') $ lambdaParams lam 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 @@ -39,10 +39,11 @@ dPrim_ (segFlat space) int64 sOp $ Imp.GetTaskId (segFlat space) kstms' <- mapM renameStm kstms - generateChunkLoop "SegMap" $ \i -> do - dIndexSpace (zip is ns') i - compileStms (freeIn kres) kstms' $ - zipWithM_ (writeResult is) (patElems pat) kres + inISPC $ + generateChunkLoop "SegMap" Vectorized $ \i -> do + dIndexSpace (zip is ns') i + compileStms (freeIn kres) kstms' $ + zipWithM_ (writeResult is) (patElems pat) kres compileSegMap :: Pat LetDecMem -> 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 @@ -10,10 +10,10 @@ import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.Multicore.Base import Futhark.IR.MCMem -import Futhark.Util (chunks) +import Futhark.Transform.Rename (renameLambda) import Prelude hiding (quot, rem) -type DoSegBody = (([(SubExp, [Imp.TExp Int64])] -> MulticoreGen ()) -> MulticoreGen ()) +type DoSegBody = (([[(SubExp, [Imp.TExp Int64])]] -> MulticoreGen ()) -> MulticoreGen ()) -- | Generate code for a SegRed construct compileSegRed :: @@ -32,7 +32,7 @@ let map_arrs = drop (segBinOpResults reds) $ patElems pat zipWithM_ (compileThreadResult space) map_arrs map_res - red_cont $ zip (map kernelResultSubExp red_res) $ repeat [] + red_cont $ segBinOpChunks reds $ zip (map kernelResultSubExp red_res) $ repeat [] -- | Like 'compileSegRed', but where the body is a monadic action. compileSegRed' :: @@ -72,6 +72,14 @@ accParams slug = take (length (slugNeutral slug)) $ slugParams slug nextParams slug = drop (length (slugNeutral slug)) $ slugParams slug +renameSlug :: SegBinOpSlug -> MulticoreGen SegBinOpSlug +renameSlug slug = do + let op = slugOp slug + let lambda = segBinOpLambda op + lambda' <- renameLambda lambda + let op' = op {segBinOpLambda = lambda'} + pure slug {slugOp = op'} + nonsegmentedReduction :: Pat LetDecMem -> SegSpace -> @@ -84,82 +92,242 @@ let slugs1 = zipWith SegBinOpSlug reds thread_res_arrs nsubtasks' = tvExp nsubtasks - reductionStage1 space slugs1 kbody + -- Are all the operators commutative? + let comm = all ((== Commutative) . segBinOpComm) reds + let dims = map (shapeDims . slugShape) slugs1 + let isScalar x = case x of MemPrim _ -> True; _ -> False + -- Are we only working on scalar arrays? + let scalars = all (all (isScalar . paramDec) . slugParams) slugs1 && all (== []) dims + -- Are we working with vectorized inner maps? + let inner_map = [] `notElem` dims + + let path + | comm && scalars = reductionStage1CommScalar + | inner_map = reductionStage1Array + | scalars = reductionStage1NonCommScalar + | otherwise = reductionStage1Fallback + path space slugs1 kbody + reds2 <- renameSegBinOp reds let slugs2 = zipWith SegBinOpSlug reds2 thread_res_arrs reductionStage2 pat space nsubtasks' slugs2 -reductionStage1 :: - SegSpace -> +-- Generate code that declares the params for the binop +genBinOpParams :: [SegBinOpSlug] -> MulticoreGen () +genBinOpParams slugs = + dScope Nothing $ scopeOfLParams $ concatMap slugParams slugs + +-- Generate code that declares accumulators, return a list of these +genAccumulators :: [SegBinOpSlug] -> MulticoreGen [[VName]] +genAccumulators slugs = + forM slugs $ \slug -> do + let shape = segBinOpShape $ slugOp slug + forM (zip (accParams slug) (slugNeutral slug)) $ \(p, ne) -> do + -- Declare accumulator variable. + acc <- + case paramType p of + Prim pt + | shape == mempty -> + tvVar <$> dPrim "local_acc" pt + | otherwise -> + sAllocArray "local_acc" pt shape DefaultSpace + _ -> + pure $ paramName p + + -- Now neutral-initialise the accumulator. + sLoopNest (slugShape slug) $ \vec_is -> + copyDWIMFix acc vec_is ne [] + + pure acc + +-- Datatype to represent all the different ways we can generate +-- code for a reduction. +data RedLoopType + = RedSeq -- Fully sequential + | RedComm -- Commutative scalar + | RedNonComm -- Noncommutative scalar + | RedNested -- Nested vectorized operator + | RedUniformize -- Uniformize over scalar acc + +-- Given a type of reduction and the loop index, should we wrap +-- the loop body in some extra code? +getRedLoop :: + RedLoopType -> + Imp.TExp Int64 -> + (Imp.TExp Int64 -> MulticoreGen ()) -> + MulticoreGen () +getRedLoop RedNonComm _ = generateUniformizeLoop +getRedLoop RedUniformize uni = \body -> body uni +getRedLoop _ _ = \body -> body 0 + +-- Given a type of reduction, should we perform extracts on +-- the accumulator? +getExtract :: + RedLoopType -> + Imp.TExp Int64 -> + MulticoreGen Imp.MCCode -> + MulticoreGen () +getExtract RedNonComm = extractVectorLane +getExtract RedUniformize = extractVectorLane +getExtract _ = \_ body -> body >>= emit + +-- Given a type of reduction, should we vectorize the inner +-- map, if it exists? +getNestLoop :: + RedLoopType -> + Shape -> + ([Imp.TExp Int64] -> MulticoreGen ()) -> + MulticoreGen () +getNestLoop RedNested = sLoopNestVectorized +getNestLoop _ = sLoopNest + +-- Given a list of accumulators, use them as the source +-- data for reduction. +redSourceAccs :: [[VName]] -> DoSegBody +redSourceAccs slug_local_accs m = + m $ map (map (\x -> (Var x, []))) slug_local_accs + +-- Generate a reduction loop for uniformizing vectors +genPostbodyReductionLoop :: + [[VName]] -> [SegBinOpSlug] -> + [[VName]] -> + SegSpace -> + Imp.TExp Int64 -> + MulticoreGen () +genPostbodyReductionLoop accs = + genReductionLoop RedUniformize (redSourceAccs accs) + +-- Generate a potentially vectorized body of code that performs reduction +-- when put inside a chunked loop. +genReductionLoop :: + RedLoopType -> DoSegBody -> + [SegBinOpSlug] -> + [[VName]] -> + SegSpace -> + Imp.TExp Int64 -> MulticoreGen () -reductionStage1 space slugs kbody = do +genReductionLoop typ kbodymap slugs slug_local_accs space i = do let (is, ns) = unzip $ unSegSpace space ns' = map toInt64Exp ns - -- Create local accumulator variables in which we carry out the - -- sequential reduction of this function. If we are dealing with - -- vectorised operators, then this implies a private allocation. If - -- the original operand type of the reduction is a memory block, - -- then our hands are unfortunately tied, and we have to use exactly - -- that memory. This is likely to be slow. - - fbody <- collect $ do - dPrim_ (segFlat space) int64 - sOp $ Imp.GetTaskId (segFlat space) - - slug_local_accs <- do - dScope Nothing $ scopeOfLParams $ concatMap slugParams slugs - - forM slugs $ \slug -> do - let shape = segBinOpShape $ slugOp slug + zipWithM_ dPrimV_ is $ unflattenIndex ns' i + kbodymap $ \all_red_res' -> do + forM_ (zip3 all_red_res' slugs slug_local_accs) $ \(red_res, slug, local_accs) -> + getNestLoop typ (slugShape slug) $ \vec_is -> do + let lamtypes = lambdaReturnType $ segBinOpLambda $ slugOp slug + -- Load accum params + getRedLoop typ i $ \uni -> do + sComment "Load accum params" $ + forM_ (zip3 (accParams slug) local_accs lamtypes) $ + \(p, local_acc, t) -> + when (primType t) $ do + copyDWIMFix (paramName p) [] (Var local_acc) vec_is - forM (zip (accParams slug) (slugNeutral slug)) $ \(p, ne) -> do - -- Declare accumulator variable. - acc <- - case paramType p of - Prim pt - | shape == mempty -> - tvVar <$> dPrim "local_acc" pt - | otherwise -> - sAllocArray "local_acc" pt shape DefaultSpace - _ -> - pure $ paramName p + sComment "Load next params" $ + forM_ (zip (nextParams slug) red_res) $ \(p, (res, res_is)) -> do + getExtract typ uni $ + collect $ + copyDWIMFix (paramName p) [] res (res_is ++ vec_is) - -- Now neutral-initialise the accumulator. - sLoopNest (slugShape slug) $ \vec_is -> - copyDWIMFix acc vec_is ne [] + sComment "SegRed body" $ + compileStms mempty (bodyStms $ slugBody slug) $ + forM_ (zip local_accs $ map resSubExp $ bodyResult $ slugBody slug) $ + \(local_acc, se) -> + copyDWIMFix local_acc vec_is se [] - pure acc +-- Generate code to write back results from the accumulators +genWriteBack :: [SegBinOpSlug] -> [[VName]] -> SegSpace -> MulticoreGen () +genWriteBack slugs slug_local_accs space = + forM_ (zip slugs slug_local_accs) $ \(slug, local_accs) -> + forM (zip (slugResArrs slug) local_accs) $ \(acc, local_acc) -> + copyDWIMFix acc [Imp.le64 $ segFlat space] (Var local_acc) [] - generateChunkLoop "SegRed" $ \i -> do - zipWithM_ dPrimV_ is $ unflattenIndex ns' i - kbody $ \all_red_res -> do - let all_red_res' = segBinOpChunks (map slugOp slugs) all_red_res - forM_ (zip3 all_red_res' slugs slug_local_accs) $ \(red_res, slug, local_accs) -> - sLoopNest (slugShape slug) $ \vec_is -> do - let lamtypes = lambdaReturnType $ segBinOpLambda $ slugOp slug - -- Load accum params - sComment "Load accum params" $ - forM_ (zip3 (accParams slug) local_accs lamtypes) $ - \(p, local_acc, t) -> - when (primType t) $ - copyDWIMFix (paramName p) [] (Var local_acc) vec_is +type ReductionStage1 = SegSpace -> [SegBinOpSlug] -> DoSegBody -> MulticoreGen () - sComment "Load next params" $ - forM_ (zip (nextParams slug) red_res) $ \(p, (res, res_is)) -> - copyDWIMFix (paramName p) [] res (res_is ++ vec_is) +-- Pure sequential codegen with no fancy vectorization +reductionStage1Fallback :: ReductionStage1 +reductionStage1Fallback space slugs kbody = do + fbody <- collect $ do + dPrim_ (segFlat space) int64 + sOp $ Imp.GetTaskId (segFlat space) + -- Declare params + genBinOpParams slugs + slug_local_accs <- genAccumulators slugs + -- Generate main reduction loop + generateChunkLoop "SegRed" Scalar $ + genReductionLoop RedSeq kbody slugs slug_local_accs space + -- Write back results + genWriteBack slugs slug_local_accs space + free_params <- freeParams fbody + emit $ Imp.Op $ Imp.ParLoop "segred_stage_1" fbody free_params - sComment "SegRed body" $ - compileStms mempty (bodyStms $ slugBody slug) $ - forM_ (zip local_accs $ map resSubExp $ bodyResult $ slugBody slug) $ - \(local_acc, se) -> - copyDWIMFix local_acc vec_is se [] +-- Codegen for noncommutative scalar reduction. We vectorize the +-- kernel body, and do the reduction sequentially. +reductionStage1NonCommScalar :: ReductionStage1 +reductionStage1NonCommScalar space slugs kbody = do + fbody <- collect $ do + dPrim_ (segFlat space) int64 + sOp $ Imp.GetTaskId (segFlat space) + inISPC $ do + -- Declare params + genBinOpParams slugs + slug_local_accs <- genAccumulators slugs + -- Generate main reduction loop + generateChunkLoop "SegRed" Vectorized $ + genReductionLoop RedNonComm kbody slugs slug_local_accs space + -- Write back results + genWriteBack slugs slug_local_accs space + free_params <- freeParams fbody + emit $ Imp.Op $ Imp.ParLoop "segred_stage_1" fbody free_params - forM_ (zip slugs slug_local_accs) $ \(slug, local_accs) -> - forM (zip (slugResArrs slug) local_accs) $ \(acc, local_acc) -> - copyDWIMFix acc [Imp.le64 $ segFlat space] (Var local_acc) [] +-- Codegen for a commutative reduction on scalar arrays +-- In this case, we can generate an efficient interleaved reduction +reductionStage1CommScalar :: ReductionStage1 +reductionStage1CommScalar space slugs kbody = do + fbody <- collect $ do + dPrim_ (segFlat space) int64 + sOp $ Imp.GetTaskId (segFlat space) + -- Rename lambda params in slugs to get a new set of them + slugs' <- mapM renameSlug slugs + inISPC $ do + -- Declare one set of params uniform + genBinOpParams slugs' + slug_local_accs_uni <- genAccumulators slugs' + -- Declare the other varying + genBinOpParams slugs + slug_local_accs <- genAccumulators slugs + -- Generate the main reduction loop over vectors + generateChunkLoop "SegRed" Vectorized $ + genReductionLoop RedComm kbody slugs slug_local_accs space + -- Now reduce over those vector accumulators to get scalar results + generateUniformizeLoop $ + genPostbodyReductionLoop slug_local_accs slugs' slug_local_accs_uni space + -- And write back the results + genWriteBack slugs slug_local_accs_uni space + free_params <- freeParams fbody + emit $ Imp.Op $ Imp.ParLoop "segred_stage_1" fbody free_params +-- Codegen for a reduction on arrays, where the body is a perfect nested map. +-- We vectorize just the inner map. +reductionStage1Array :: ReductionStage1 +reductionStage1Array space slugs kbody = do + fbody <- collect $ do + dPrim_ (segFlat space) int64 + sOp $ Imp.GetTaskId (segFlat space) + -- Declare params + lparams <- collect $ genBinOpParams slugs + (slug_local_accs, uniform_prebody) <- collect' $ genAccumulators slugs + -- Put the accumulators outside of the kernel, so they are forced uniform + emit uniform_prebody + inISPC $ do + -- Put the lambda params inside the kernel so they are varying + emit lparams + -- Generate the main reduction loop + generateChunkLoop "SegRed" Scalar $ + genReductionLoop RedNested kbody slugs slug_local_accs space + -- Write back results + genWriteBack slugs slug_local_accs space free_params <- freeParams fbody emit $ Imp.Op $ Imp.ParLoop "segred_stage_1" fbody free_params @@ -212,6 +380,7 @@ free_params <- freeParams body emit $ Imp.Op $ Imp.ParLoop "segmented_segred" body free_params +-- Currently, this is only used as part of SegHist calculations, never alone. compileSegRedBody :: Pat LetDecMem -> SegSpace -> @@ -227,40 +396,40 @@ let per_red_pes = segBinOpChunks reds $ patElems pat -- Perform sequential reduce on inner most dimension - collect . generateChunkLoop "SegRed" $ \n_segments -> do - flat_idx <- dPrimVE "flat_idx" $ n_segments * inner_bound - zipWithM_ dPrimV_ is $ unflattenIndex ns_64 flat_idx - sComment "neutral-initialise the accumulators" $ - forM_ (zip per_red_pes reds) $ \(pes, red) -> - forM_ (zip pes (segBinOpNeutral red)) $ \(pe, ne) -> - sLoopNest (segBinOpShape red) $ \vec_is -> - copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ vec_is) ne [] + collect . inISPC $ + generateChunkLoop "SegRed" Vectorized $ \n_segments -> do + flat_idx <- dPrimVE "flat_idx" $ n_segments * inner_bound + zipWithM_ dPrimV_ is $ unflattenIndex ns_64 flat_idx + sComment "neutral-initialise the accumulators" $ + forM_ (zip per_red_pes reds) $ \(pes, red) -> + forM_ (zip pes (segBinOpNeutral red)) $ \(pe, ne) -> + sLoopNest (segBinOpShape red) $ \vec_is -> + copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ vec_is) ne [] - sComment "main body" $ do - dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) reds - sFor "i" inner_bound $ \i -> do - zipWithM_ - (<--) - (map (`mkTV` int64) $ init is) - (unflattenIndex (init ns_64) (sExt64 n_segments)) - dPrimV_ (last is) i - kbody $ \all_red_res -> do - let red_res' = chunks (map (length . segBinOpNeutral) reds) all_red_res - forM_ (zip3 per_red_pes reds red_res') $ \(pes, red, res') -> - sLoopNest (segBinOpShape red) $ \vec_is -> do - sComment "load accum" $ do - let acc_params = take (length (segBinOpNeutral red)) $ (lambdaParams . segBinOpLambda) red - forM_ (zip acc_params pes) $ \(p, pe) -> - copyDWIMFix (paramName p) [] (Var $ patElemName pe) (map Imp.le64 (init is) ++ vec_is) + sComment "main body" $ do + dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) reds + sFor "i" inner_bound $ \i -> do + zipWithM_ + (<--) + (map (`mkTV` int64) $ init is) + (unflattenIndex (init ns_64) (sExt64 n_segments)) + dPrimV_ (last is) i + kbody $ \red_res' -> do + forM_ (zip3 per_red_pes reds red_res') $ \(pes, red, res') -> + sLoopNest (segBinOpShape red) $ \vec_is -> do + sComment "load accum" $ do + let acc_params = take (length (segBinOpNeutral red)) $ (lambdaParams . segBinOpLambda) red + forM_ (zip acc_params pes) $ \(p, pe) -> + copyDWIMFix (paramName p) [] (Var $ patElemName pe) (map Imp.le64 (init is) ++ vec_is) - sComment "load new val" $ do - let next_params = drop (length (segBinOpNeutral red)) $ (lambdaParams . segBinOpLambda) red - forM_ (zip next_params res') $ \(p, (res, res_is)) -> - copyDWIMFix (paramName p) [] res (res_is ++ vec_is) + sComment "load new val" $ do + let next_params = drop (length (segBinOpNeutral red)) $ (lambdaParams . segBinOpLambda) red + forM_ (zip next_params res') $ \(p, (res, res_is)) -> + copyDWIMFix (paramName p) [] res (res_is ++ vec_is) - sComment "apply reduction" $ do - let lbody = (lambdaBody . segBinOpLambda) red - compileStms mempty (bodyStms lbody) $ - sComment "write back to res" $ - forM_ (zip pes $ map resSubExp $ bodyResult lbody) $ - \(pe, se') -> copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ vec_is) se' [] + sComment "apply reduction" $ do + let lbody = (lambdaBody . segBinOpLambda) red + compileStms mempty (bodyStms lbody) $ + sComment "write back to res" $ + forM_ (zip pes $ map resSubExp $ bodyResult lbody) $ + \(pe, se') -> copyDWIMFix (patElemName pe) (map Imp.le64 (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 @@ -54,79 +54,183 @@ nonsegmentedScan pat space scan_ops kbody nsubtasks = do emit $ Imp.DebugPrint "nonsegmented segScan" Nothing collect $ do - scanStage1 pat space scan_ops kbody + -- Are we working with nested arrays + let dims = map (shapeDims . segBinOpShape) scan_ops + -- Are we only working on scalars + let scalars = all (all (primType . typeOf . paramDec) . (lambdaParams . segBinOpLambda)) scan_ops && all null dims + -- Do we have nested vector operations + let vectorize = [] `notElem` dims + let param_types = concatMap (map paramType . (lambdaParams . segBinOpLambda)) scan_ops + let no_array_param = all primType param_types + + let (scanStage1, scanStage3) + | scalars = (scanStage1Scalar, scanStage3Scalar) + | vectorize && no_array_param = (scanStage1Nested, scanStage3Nested) + | otherwise = (scanStage1Fallback, scanStage3Fallback) + + scanStage1 pat space kbody scan_ops + let nsubtasks' = tvExp nsubtasks sWhen (nsubtasks' .>. 1) $ do scan_ops2 <- renameSegBinOp scan_ops scanStage2 pat nsubtasks space scan_ops2 kbody scan_ops3 <- renameSegBinOp scan_ops - scanStage3 pat space scan_ops3 kbody + scanStage3 pat space kbody scan_ops3 -scanStage1 :: +-- Different ways to generate code for a scan loop +data ScanLoopType + = ScanSeq -- Fully sequential + | ScanNested -- Nested vectorized map + | ScanScalar -- Vectorized scan over scalars + +-- Given a scan type, return a function to inject into the loop body +getScanLoop :: + ScanLoopType -> + (Imp.TExp Int64 -> MulticoreGen ()) -> + MulticoreGen () +getScanLoop ScanScalar = generateUniformizeLoop +getScanLoop _ = \body -> body 0 + +-- Given a scan type, return a function to extract a scalar from a vector +getExtract :: ScanLoopType -> Imp.TExp Int64 -> MulticoreGen Imp.MCCode -> MulticoreGen () +getExtract ScanSeq = \_ body -> body >>= emit +getExtract _ = extractVectorLane + +genBinOpParams :: [SegBinOp MCMem] -> MulticoreGen () +genBinOpParams scan_ops = dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) scan_ops + +genLocalAccsStage1 :: [SegBinOp MCMem] -> MulticoreGen [[VName]] +genLocalAccsStage1 scan_ops = do + forM scan_ops $ \scan_op -> do + let shape = segBinOpShape scan_op + ts = lambdaReturnType $ segBinOpLambda scan_op + forM (zip3 (xParams scan_op) (segBinOpNeutral scan_op) ts) $ \(p, ne, t) -> do + acc <- -- update accumulator to have type decoration + case shapeDims shape of + [] -> pure $ paramName p + _ -> do + let pt = elemType t + sAllocArray "local_acc" pt (shape <> arrayShape t) DefaultSpace + + -- Now neutral-initialise the accumulator. + sLoopNest (segBinOpShape scan_op) $ \vec_is -> + copyDWIMFix acc vec_is ne [] + + pure acc + +getNestLoop :: + ScanLoopType -> + Shape -> + ([Imp.TExp Int64] -> MulticoreGen ()) -> + MulticoreGen () +getNestLoop ScanNested = sLoopNestVectorized +getNestLoop _ = sLoopNest + +-- Generate a loop which performs a potentially vectorized scan. +genScanLoop :: + ScanLoopType -> Pat LetDecMem -> SegSpace -> - [SegBinOp MCMem] -> KernelBody MCMem -> - MulticoreGen () -scanStage1 pat space scan_ops kbody = do + [SegBinOp MCMem] -> + [[VName]] -> + Imp.TExp Int64 -> + ImpM MCMem HostEnv Imp.Multicore () +genScanLoop typ pat space kbody scan_ops local_accs i = 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 $ patElems pat let (is, ns) = unzip $ unSegSpace space ns' = map toInt64Exp ns - -- Stage 1 : each thread partially scans a chunk of the input - -- Writes directly to the resulting array + zipWithM_ dPrimV_ is $ unflattenIndex ns' i + compileStms mempty (kernelBodyStms kbody) $ do + -- Potential vector load and then do sequential scan + getScanLoop typ $ \j -> do + sComment "write mapped values results to memory" $ do + 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) -> + getNestLoop typ (segBinOpShape scan_op) $ \vec_is -> do + -- Read accum value + forM_ (zip (xParams scan_op) acc) $ \(p, acc') -> do + copyDWIMFix (paramName p) [] (Var acc') vec_is + -- Read next value + sComment "Read next values" $ + forM_ (zip (yParams scan_op) scan_res) $ \(p, se) -> + getExtract typ j $ + collect $ + copyDWIMFix (paramName p) [] (kernelResultSubExp se) vec_is + -- Scan body + sComment "Scan body" $ + compileStms mempty (bodyStms $ lamBody scan_op) $ + forM_ (zip3 acc pes $ map resSubExp $ bodyResult $ lamBody scan_op) $ + \(acc', pe, se) -> do + copyDWIMFix (patElemName pe) (map Imp.le64 is ++ vec_is) se [] + copyDWIMFix acc' vec_is se [] - body <- collect $ do +scanStage1Scalar :: + Pat LetDecMem -> + SegSpace -> + KernelBody MCMem -> + [SegBinOp MCMem] -> + MulticoreGen () +scanStage1Scalar pat space kbody scan_ops = do + fbody <- collect $ do dPrim_ (segFlat space) int64 sOp $ Imp.GetTaskId (segFlat space) - dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) scan_ops - local_accs <- forM scan_ops $ \scan_op -> do - let shape = segBinOpShape scan_op - ts = lambdaReturnType $ segBinOpLambda scan_op - forM (zip3 (xParams scan_op) (segBinOpNeutral scan_op) ts) $ \(p, ne, t) -> do - acc <- - case shapeDims shape of - [] -> pure $ paramName p - _ -> do - let pt = elemType t - sAllocArray "local_acc" pt (shape <> arrayShape t) DefaultSpace + genBinOpParams scan_ops + local_accs <- genLocalAccsStage1 scan_ops + inISPC $ + generateChunkLoop "SegScan" Vectorized $ + genScanLoop ScanScalar pat space kbody scan_ops local_accs + free_params <- freeParams fbody + emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" fbody free_params - -- Now neutral-initialise the accumulator. - sLoopNest (segBinOpShape scan_op) $ \vec_is -> - copyDWIMFix acc vec_is ne [] +scanStage1Nested :: + Pat LetDecMem -> + SegSpace -> + KernelBody MCMem -> + [SegBinOp MCMem] -> + MulticoreGen () +scanStage1Nested pat space kbody scan_ops = do + fbody <- collect $ do + dPrim_ (segFlat space) int64 + sOp $ Imp.GetTaskId (segFlat space) - pure acc + lparams <- collect $ genBinOpParams scan_ops + local_accs <- genLocalAccsStage1 scan_ops - generateChunkLoop "SegScan" $ \i -> do - zipWithM_ dPrimV_ is $ unflattenIndex ns' i - compileStms mempty (kernelBodyStms kbody) $ do - sComment "write mapped values results to memory" $ do - let map_arrs = drop (segBinOpResults scan_ops) $ patElems pat - zipWithM_ (compileThreadResult space) map_arrs map_res + inISPC $ do + emit lparams + generateChunkLoop "SegScan" Scalar $ \i -> do + genScanLoop ScanNested pat space kbody scan_ops local_accs i - forM_ (zip4 per_scan_pes scan_ops per_scan_res local_accs) $ \(pes, scan_op, scan_res, acc) -> - sLoopNest (segBinOpShape scan_op) $ \vec_is -> do - -- Read accum value - forM_ (zip (xParams scan_op) acc) $ \(p, acc') -> - copyDWIMFix (paramName p) [] (Var acc') vec_is + free_params <- freeParams fbody + emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" fbody free_params - -- Read next value - sComment "Read next values" $ - forM_ (zip (yParams scan_op) scan_res) $ \(p, se) -> - copyDWIMFix (paramName p) [] (kernelResultSubExp se) vec_is +scanStage1Fallback :: + Pat LetDecMem -> + SegSpace -> + KernelBody MCMem -> + [SegBinOp MCMem] -> + MulticoreGen () +scanStage1Fallback pat space kbody scan_ops = do + -- Stage 1 : each thread partially scans a chunk of the input + -- Writes directly to the resulting array + fbody <- collect $ do + dPrim_ (segFlat space) int64 + sOp $ Imp.GetTaskId (segFlat space) - compileStms mempty (bodyStms $ lamBody scan_op) $ - forM_ (zip3 acc pes $ map resSubExp $ bodyResult $ lamBody scan_op) $ - \(acc', pe, se) -> do - copyDWIMFix (patElemName pe) (map Imp.le64 is ++ vec_is) se [] - copyDWIMFix acc' vec_is se [] + genBinOpParams scan_ops + local_accs <- genLocalAccsStage1 scan_ops - free_params <- freeParams body - emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" body free_params + generateChunkLoop "SegScan" Scalar $ + genScanLoop ScanSeq pat space kbody scan_ops local_accs + free_params <- freeParams fbody + emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" fbody free_params scanStage2 :: Pat LetDecMem -> @@ -184,70 +288,95 @@ copyDWIMFix (patElemName pe) ((offset_index' - 1) : vec_is) se [] copyDWIMFix acc' vec_is se [] --- Stage 3 : Finally each thread partially scans a chunk of the input --- reading its corresponding carry-in -scanStage3 :: +genLocalAccsStage3 :: [SegBinOp MCMem] -> [[PatElem LetDecMem]] -> MulticoreGen [[VName]] +genLocalAccsStage3 scan_ops per_scan_pes = + forM (zip scan_ops per_scan_pes) $ \(scan_op, pes) -> do + let shape = segBinOpShape scan_op + ts = lambdaReturnType $ segBinOpLambda scan_op + forM (zip4 (xParams scan_op) pes ts $ segBinOpNeutral scan_op) $ \(p, pe, t, ne) -> do + acc <- + case shapeDims shape of + [] -> pure $ paramName p + _ -> do + let pt = elemType t + sAllocArray "local_acc" pt (shape <> arrayShape t) DefaultSpace + + -- Initialise the accumulator with neutral from previous chunk. + -- or read neutral if first ``iter`` + (start, _end) <- getLoopBounds + sLoopNest (segBinOpShape scan_op) $ \vec_is -> do + let read_carry_in = + copyDWIMFix acc vec_is (Var $ patElemName pe) (start - 1 : vec_is) + read_neutral = + copyDWIMFix acc vec_is ne [] + sIf (start .==. 0) read_neutral read_carry_in + pure acc + +scanStage3Scalar :: Pat LetDecMem -> SegSpace -> - [SegBinOp MCMem] -> KernelBody MCMem -> + [SegBinOp MCMem] -> MulticoreGen () -scanStage3 pat space scan_ops kbody = do - 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 $ patElems pat - ns' = map toInt64Exp ns +scanStage3Scalar pat space kbody scan_ops = do + let per_scan_pes = segBinOpChunks scan_ops $ patElems pat + body <- collect $ do + dPrim_ (segFlat space) int64 + sOp $ Imp.GetTaskId (segFlat space) + genBinOpParams scan_ops + local_accs <- genLocalAccsStage3 scan_ops per_scan_pes + + inISPC $ + generateChunkLoop "SegScan" Vectorized $ + genScanLoop ScanScalar pat space kbody scan_ops local_accs + free_params <- freeParams body + emit $ Imp.Op $ Imp.ParLoop "scan_stage_3" body free_params + +scanStage3Nested :: + Pat LetDecMem -> + SegSpace -> + KernelBody MCMem -> + [SegBinOp MCMem] -> + MulticoreGen () +scanStage3Nested pat space kbody scan_ops = do + let per_scan_pes = segBinOpChunks scan_ops $ patElems pat body <- collect $ do dPrim_ (segFlat space) int64 sOp $ Imp.GetTaskId (segFlat space) - dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) scan_ops - local_accs <- forM (zip scan_ops per_scan_pes) $ \(scan_op, pes) -> do - let shape = segBinOpShape scan_op - ts = lambdaReturnType $ segBinOpLambda scan_op - forM (zip4 (xParams scan_op) pes ts $ segBinOpNeutral scan_op) $ \(p, pe, t, ne) -> do - acc <- - case shapeDims shape of - [] -> pure $ paramName p - _ -> do - let pt = elemType t - sAllocArray "local_acc" pt (shape <> arrayShape t) DefaultSpace + lparams <- collect $ genBinOpParams scan_ops + local_accs <- genLocalAccsStage3 scan_ops per_scan_pes - -- Initialise the accumulator with neutral from previous chunk. - -- or read neutral if first ``iter`` - (start, _end) <- getLoopBounds - sLoopNest (segBinOpShape scan_op) $ \vec_is -> do - let read_carry_in = - copyDWIMFix acc vec_is (Var $ patElemName pe) (start - 1 : vec_is) - read_neutral = - copyDWIMFix acc vec_is ne [] - sIf (start .==. 0) read_neutral read_carry_in - pure acc + inISPC $ do + emit lparams + generateChunkLoop "SegScan" Scalar $ \i -> do + genScanLoop ScanNested pat space kbody scan_ops local_accs i - generateChunkLoop "SegScan" $ \i -> do - zipWithM_ dPrimV_ is $ unflattenIndex ns' i - sComment "stage 3 scan body" $ - compileStms mempty (kernelBodyStms kbody) $ - forM_ (zip4 per_scan_pes scan_ops per_scan_res local_accs) $ \(pes, scan_op, scan_res, acc) -> - sLoopNest (segBinOpShape scan_op) $ \vec_is -> do - forM_ (zip (xParams scan_op) acc) $ \(p, acc') -> - copyDWIMFix (paramName p) [] (Var acc') vec_is + free_params <- freeParams body + emit $ Imp.Op $ Imp.ParLoop "scan_stage_3" body free_params - -- Read next value - forM_ (zip (yParams scan_op) scan_res) $ \(p, se) -> - copyDWIMFix (paramName p) [] (kernelResultSubExp se) vec_is +scanStage3Fallback :: + Pat LetDecMem -> + SegSpace -> + KernelBody MCMem -> + [SegBinOp MCMem] -> + MulticoreGen () +scanStage3Fallback pat space kbody scan_ops = do + let per_scan_pes = segBinOpChunks scan_ops $ patElems pat + body <- collect $ do + dPrim_ (segFlat space) int64 + sOp $ Imp.GetTaskId (segFlat space) - compileStms mempty (bodyStms $ lamBody scan_op) $ - forM_ (zip3 pes (map resSubExp $ bodyResult $ lamBody scan_op) acc) $ - \(pe, se, acc') -> do - copyDWIMFix (patElemName pe) (map Imp.le64 is ++ vec_is) se [] - copyDWIMFix acc' vec_is se [] + genBinOpParams scan_ops + local_accs <- genLocalAccsStage3 scan_ops per_scan_pes - free_params' <- freeParams body - emit $ Imp.Op $ Imp.ParLoop "scan_stage_3" body free_params' + generateChunkLoop "SegScan" Scalar $ + genScanLoop ScanSeq pat space kbody scan_ops local_accs + free_params <- freeParams body + emit $ Imp.Op $ Imp.ParLoop "scan_stage_3" body free_params +-- Note: This isn't currently used anywhere. -- This implementation for a Segmented scan only -- parallelize over the segments and each segment is -- scanned sequentially. @@ -278,7 +407,7 @@ sOp $ Imp.GetTaskId (segFlat space) let per_scan_pes = segBinOpChunks scan_ops $ patElems pat - generateChunkLoop "SegScan" $ \segment_i -> do + generateChunkLoop "SegScan" Scalar $ \segment_i -> do forM_ (zip scan_ops per_scan_pes) $ \(scan_op, scan_pes) -> do dScope Nothing $ scopeOfLParams $ lambdaParams $ segBinOpLambda scan_op let (scan_x_params, scan_y_params) = splitAt (length $ segBinOpNeutral scan_op) $ (lambdaParams . segBinOpLambda) scan_op diff --git a/src/Futhark/CodeGen/ImpGen/Transpose.hs b/src/Futhark/CodeGen/ImpGen/Transpose.hs --- a/src/Futhark/CodeGen/ImpGen/Transpose.hs +++ b/src/Futhark/CodeGen/ImpGen/Transpose.hs @@ -51,8 +51,6 @@ If (le64 num_arrays .==. 1) doTranspose doMapTranspose ] ) - [] - [] where params = [ memparam destmem, diff --git a/src/Futhark/CodeGen/RTS/C.hs b/src/Futhark/CodeGen/RTS/C.hs --- a/src/Futhark/CodeGen/RTS/C.hs +++ b/src/Futhark/CodeGen/RTS/C.hs @@ -18,6 +18,8 @@ valuesH, errorsH, cacheH, + uniformH, + ispcUtilH, ) where @@ -32,6 +34,11 @@ atomicsH = $(embedStringFile "rts/c/atomics.h") {-# NOINLINE atomicsH #-} +-- | @rts/c/uniform.h@ +uniformH :: T.Text +uniformH = $(embedStringFile "rts/c/uniform.h") +{-# NOINLINE uniformH #-} + -- | @rts/c/cuda.h@ cudaH :: T.Text cudaH = $(embedStringFile "rts/c/cuda.h") @@ -101,6 +108,11 @@ errorsH :: T.Text errorsH = $(embedStringFile "rts/c/errors.h") {-# NOINLINE errorsH #-} + +-- | @rts/c/ispc_util.h@ +ispcUtilH :: T.Text +ispcUtilH = $(embedStringFile "rts/c/ispc_util.h") +{-# NOINLINE ispcUtilH #-} -- | @rts/c/cache.h@ cacheH :: T.Text 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 @@ -13,8 +13,9 @@ -- | Set all uses of 'DefaultSpace' in the given definitions to another -- memory space. setDefaultSpace :: Space -> Definitions op -> Definitions op -setDefaultSpace space (Definitions (Constants ps consts) (Functions fundecs)) = +setDefaultSpace space (Definitions types (Constants ps consts) (Functions fundecs)) = Definitions + types (Constants (map (setParamSpace space) ps) (setCodeSpace space consts)) ( Functions [ (fname, setFunctionSpace space func) @@ -27,13 +28,18 @@ setDefaultCodeSpace = setCodeSpace setFunctionSpace :: Space -> Function op -> Function op -setFunctionSpace space (Function entry outputs inputs body results args) = +setFunctionSpace space (Function entry outputs inputs body) = Function - entry + (setEntrySpace space <$> entry) (map (setParamSpace space) outputs) (map (setParamSpace space) inputs) (setCodeSpace space body) - (map (setExtValueSpace space) results) + +setEntrySpace :: Space -> EntryPoint -> EntryPoint +setEntrySpace space (EntryPoint name results args) = + EntryPoint + name + (map (fmap $ setExtValueSpace space) results) (map (fmap $ setExtValueSpace space) args) setParamSpace :: Space -> Param -> Param @@ -43,10 +49,10 @@ param setExtValueSpace :: Space -> ExternalValue -> ExternalValue -setExtValueSpace space (OpaqueValue u desc vs) = - OpaqueValue u desc $ map (setValueSpace space) vs -setExtValueSpace space (TransparentValue u v) = - TransparentValue u $ setValueSpace space v +setExtValueSpace space (OpaqueValue desc vs) = + OpaqueValue desc $ map (setValueSpace space) vs +setExtValueSpace space (TransparentValue v) = + TransparentValue $ setValueSpace space v setValueSpace :: Space -> ValueDesc -> ValueDesc setValueSpace space (ArrayValue mem _ bt ept shape) = diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs --- a/src/Futhark/Compiler.hs +++ b/src/Futhark/Compiler.hs @@ -66,12 +66,12 @@ where report s info = do T.hPutStrLn stderr s - when (fst (futharkVerbose config) > NotVerbose) $ - maybe + when (fst (futharkVerbose config) > NotVerbose) + $ maybe (T.hPutStr stderr) T.writeFile (snd (futharkVerbose config)) - $ info <> "\n" + $ info <> "\n" -- | Read a program from the given 'FilePath', run the given -- 'Pipeline', and finish up with the given 'Action'. @@ -93,7 +93,8 @@ compile = do prog <- runPipelineOnProgram config pipeline file when ((> NotVerbose) . fst $ futharkVerbose config) $ - logMsg $ "Running action " ++ actionName action + logMsg $ + "Running action " ++ actionName action actionProcedure action prog when ((> NotVerbose) . fst $ futharkVerbose config) $ logMsg ("Done." :: String) diff --git a/src/Futhark/Compiler/Program.hs b/src/Futhark/Compiler/Program.hs --- a/src/Futhark/Compiler/Program.hs +++ b/src/Futhark/Compiler/Program.hs @@ -248,10 +248,14 @@ } Just (Left e) -> pure . UncheckedImport . Left . singleError $ - ProgError NoLoc $ text $ show e + ProgError NoLoc $ + text $ + show e Nothing -> pure . UncheckedImport . Left . singleError $ - ProgError NoLoc $ text $ fp <> ": file not found." + ProgError NoLoc $ + text $ + fp <> ": file not found." pure (M.insert include prog_mvar state, (include, prog_mvar)) where include = mkInitialImport fp_name diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -397,12 +397,15 @@ let checkDim w i = do less_than_zero <- letSubExp "less_than_zero" $ - BasicOp $ CmpOp (CmpSlt Int64) i (constant (0 :: Int64)) + BasicOp $ + CmpOp (CmpSlt Int64) i (constant (0 :: Int64)) greater_than_size <- letSubExp "greater_than_size" $ - BasicOp $ CmpOp (CmpSle Int64) w i + BasicOp $ + CmpOp (CmpSle Int64) w i letSubExp "outside_bounds_dim" $ - BasicOp $ BinOp LogOr less_than_zero greater_than_size + BasicOp $ + BinOp LogOr less_than_zero greater_than_size foldBinOp LogOr (constant False) =<< zipWithM checkDim ws is' -- | Construct an unspecified value of the given type. @@ -484,7 +487,9 @@ y <- newVName "y" body <- buildBody_ . fmap (pure . subExpRes) $ - letSubExp "binlam_res" $ BasicOp $ bop (Var x) (Var y) + letSubExp "binlam_res" $ + BasicOp $ + bop (Var x) (Var y) pure Lambda { lambdaParams = 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 @@ -141,7 +141,7 @@ forM imports $ \(current, fm) -> let ctx = Context - { ctxCurrent = current, + { ctxCurrent = makeRelative "/" current, ctxFileMod = fm, ctxImports = imports, ctxNoLink = mempty, @@ -208,20 +208,23 @@ H.docTypeHtml $ addBoilerplate "index.html" "Futhark Library Documentation" $ H.main $ - H.h2 "Main libraries" - <> fileList important_pages - <> if null unimportant_pages + ( if null important_pages then mempty - else - H.h2 "Supporting libraries" - <> fileList unimportant_pages + else H.h2 "Main libraries" <> fileList important_pages + ) + <> ( if null unimportant_pages + then mempty + else H.h2 "Supporting libraries" <> fileList unimportant_pages + ) where (important_pages, unimportant_pages) = partition ((`elem` important_imports) . fst) pages fileList pages' = H.dl ! A.class_ "file_list" $ - mconcat $ map linkTo $ sortOn fst pages' + mconcat $ + map linkTo $ + sortOn fst pages' linkTo (name, maybe_abstract) = H.div ! A.class_ "file_desc" $ @@ -251,7 +254,8 @@ (letter_names, sym_names) = partition (isLetterName . baseString . fst) $ sortOn (map toUpper . baseString . fst) $ - mapMaybe isDocumented $ M.toList fm + mapMaybe isDocumented $ + M.toList fm isDocumented (k, (file, _)) = do what <- M.lookup k documented @@ -280,11 +284,12 @@ ) where initial' = - H.tr $ - H.td ! A.colspan "2" ! A.class_ "doc_index_initial" $ - H.a ! A.id (fromString initial) - ! A.href (fromString $ '#' : initial) - $ fromString initial + H.tr + $ H.td ! A.colspan "2" ! A.class_ "doc_index_initial" + $ H.a + ! A.id (fromString initial) + ! A.href (fromString $ '#' : initial) + $ fromString initial initialListEntry initial = H.li $ H.a ! A.href (fromString $ '#' : initial) $ fromString initial @@ -293,7 +298,8 @@ let file' = makeRelative "/" file link = (H.a ! A.href (fromString (makeRelative "/" $ "doc" vnameLink' name "" file'))) $ - fromString $ baseString name + fromString $ + baseString name what' = case what of IndexValue -> "value" IxFun -> "function" @@ -314,11 +320,11 @@ H.head $ H.meta ! A.charset "utf-8" - <> H.title (fromString titleText) - <> H.link - ! A.href (fromString $ relativise "style.css" current) - ! A.rel "stylesheet" - ! A.type_ "text/css" + <> H.title (fromString titleText) + <> H.link + ! A.href (fromString $ relativise "style.css" current) + ! A.rel "stylesheet" + ! A.type_ "text/css" navigation = H.ul ! A.id "navigation" $ @@ -326,7 +332,8 @@ <> H.li (H.a ! A.href (fromString $ relativise "doc-index.html" current) $ "Index") madeByHtml = - "Generated by " <> (H.a ! A.href futhark_doc_url) "futhark-doc" + "Generated by " + <> (H.a ! A.href futhark_doc_url) "futhark-doc" <> " " <> fromString (showVersion version) in headHtml @@ -474,7 +481,8 @@ let tps' = map typeParamHtml tps t' <- typeHtml t pure $ - keyword "val " <> vnameHtml name + keyword "val " + <> vnameHtml name <> mconcat (map (" " <>) tps') <> ": " <> t' @@ -482,7 +490,7 @@ typeHtml :: StructType -> DocM Html typeHtml t = case t of Array _ u shape et -> do - shape' <- prettyShapeDecl shape + shape' <- prettyShape shape et' <- typeHtml $ Scalar et pure $ prettyU u <> shape' <> et' Scalar (Prim et) -> pure $ primTypeHtml et @@ -497,7 +505,7 @@ pure $ toHtml (nameToString name) <> ": " <> tp' Scalar (TypeVar _ u et targs) -> do targs' <- mapM typeArgHtml targs - et' <- typeNameHtml et + et' <- qualNameHtml et pure $ prettyU u <> et' <> mconcat (map (" " <>) targs') Scalar (Arrow _ pname t1 t2) -> do t1' <- typeHtml t1 @@ -518,11 +526,11 @@ t' <- typeHtml t pure $ "?" <> mconcat (map (brackets . vnameHtml) dims) <> "." <> t' -prettyShapeDecl :: ShapeDecl (DimDecl VName) -> DocM Html -prettyShapeDecl (ShapeDecl ds) = +prettyShape :: Shape Size -> DocM Html +prettyShape (Shape ds) = mconcat <$> mapM dimDeclHtml ds -typeArgHtml :: TypeArg (DimDecl VName) -> DocM Html +typeArgHtml :: TypeArg Size -> DocM Html typeArgHtml (TypeArgDim d _) = dimDeclHtml d typeArgHtml (TypeArgType t _) = typeHtml t @@ -532,7 +540,8 @@ liftM2 f (synopsisSigExp psig) (modParamHtml mps) where f se params = - "(" <> vnameHtml pname + "(" + <> vnameHtml pname <> ": " <> se <> ") -> " @@ -575,11 +584,13 @@ vnameSynopsisDef :: VName -> Html vnameSynopsisDef (VName name tag) = H.span ! A.id (fromString (show tag ++ "s")) $ - H.a ! A.href (fromString ("#" ++ show tag)) $ renderName name + H.a ! A.href (fromString ("#" ++ show tag)) $ + renderName name vnameSynopsisRef :: VName -> Html vnameSynopsisRef v = - H.a ! A.class_ "synopsis_link" + H.a + ! A.class_ "synopsis_link" ! A.href (fromString ("#" ++ show (baseTag v) ++ "s")) $ "↑" @@ -671,9 +682,6 @@ then "#" ++ show tag else relativise file current ++ ".html#" ++ show tag -typeNameHtml :: TypeName -> DocM Html -typeNameHtml = qualNameHtml . qualNameFromTypeName - patternHtml :: Pat -> DocM Html patternHtml pat = do let (pat_param, t) = patternParam pat @@ -686,15 +694,15 @@ relativise dest src = concat (replicate (length (splitPath src) - 1) "../") ++ dest -dimDeclHtml :: DimDecl VName -> DocM Html -dimDeclHtml (NamedDim v) = brackets <$> qualNameHtml v -dimDeclHtml (ConstDim n) = pure $ brackets $ toHtml (show n) -dimDeclHtml AnyDim {} = pure $ brackets mempty +dimDeclHtml :: Size -> DocM Html +dimDeclHtml (NamedSize v) = brackets <$> qualNameHtml v +dimDeclHtml (ConstSize n) = pure $ brackets $ toHtml (show n) +dimDeclHtml AnySize {} = pure $ brackets mempty -dimExpHtml :: DimExp VName -> DocM Html -dimExpHtml DimExpAny = pure $ brackets mempty -dimExpHtml (DimExpNamed v _) = brackets <$> qualNameHtml v -dimExpHtml (DimExpConst n _) = pure $ brackets $ toHtml (show n) +dimExpHtml :: SizeExp VName -> DocM Html +dimExpHtml SizeExpAny = pure $ brackets mempty +dimExpHtml (SizeExpNamed v _) = brackets <$> qualNameHtml v +dimExpHtml (SizeExpConst n _) = pure $ brackets $ toHtml (show n) typeArgExpHtml :: TypeArgExp VName -> DocM Html typeArgExpHtml (TypeArgExpDim d _) = dimExpHtml d @@ -732,7 +740,9 @@ case maybe_v of Nothing -> do warn loc $ - "Identifier '" <> fromString name <> "' not found in namespace '" + "Identifier '" + <> fromString name + <> "' not found in namespace '" <> fromString namespace <> "'" <> fromString (maybe "" (" in file " <>) file) 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 @@ -175,7 +175,9 @@ als' -> Just $ PP.oneLine $ - PP.text "-- Result for " <> PP.ppr name <> PP.text " aliases " + PP.text "-- Result for " + <> PP.ppr name + <> PP.text " aliases " <> PP.commasep (map PP.ppr als') removeAliases :: CanBeAliased (Op rep) => Rephraser Identity (Aliases rep) rep diff --git a/src/Futhark/IR/GPU/Op.hs b/src/Futhark/IR/GPU/Op.hs --- a/src/Futhark/IR/GPU/Op.hs +++ b/src/Futhark/IR/GPU/Op.hs @@ -81,11 +81,13 @@ instance Engine.Simplifiable SegLevel where simplify (SegThread num_groups group_size virt) = - SegThread <$> traverse Engine.simplify num_groups + 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 + SegGroup + <$> traverse Engine.simplify num_groups <*> traverse Engine.simplify group_size <*> pure virt 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 @@ -15,6 +15,7 @@ ) where +import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Analysis.UsageTable as UT import Futhark.IR.GPU import qualified Futhark.IR.SOACS.Simplify as SOAC @@ -26,6 +27,7 @@ import Futhark.Optimise.Simplify.Rules import Futhark.Pass import Futhark.Tools +import Futhark.Util (focusNth) simpleGPU :: Simplify.SimpleOps GPU simpleGPU = Simplify.bindableSimpleOps $ simplifyKernelOp SOAC.simplifySOAC @@ -57,7 +59,9 @@ simplifyKernelOp _ (SizeOp (SplitSpace o w i elems_per_thread)) = (,) <$> ( SizeOp - <$> ( SplitSpace <$> Engine.simplify o <*> Engine.simplify w + <$> ( SplitSpace + <$> Engine.simplify o + <*> Engine.simplify w <*> Engine.simplify i <*> Engine.simplify elems_per_thread ) @@ -103,13 +107,15 @@ kernelRules :: RuleBook (Wise GPU) kernelRules = - standardRules <> segOpRules + standardRules + <> segOpRules <> ruleBook [ RuleOp SOAC.simplifyKnownIterationSOAC, RuleOp SOAC.removeReplicateMapping, RuleOp SOAC.liftIdentityMapping, RuleOp SOAC.simplifyMapIota, - RuleOp SOAC.removeUnusedSOACInput + RuleOp SOAC.removeUnusedSOACInput, + RuleBasicOp removeScalarCopy ] [ RuleBasicOp removeUnnecessaryCopy, RuleOp removeDeadGPUBodyResult @@ -133,3 +139,27 @@ in Simplify $ auxing aux $ letBind (Pat pat') $ Op $ GPUBody types' body' | otherwise = Skip removeDeadGPUBodyResult _ _ _ _ = Skip + +-- If we see an Update with a scalar where the value to be written is +-- the result of indexing some other array, then we convert it into an +-- Update with a slice of that array. This matters when the arrays +-- are far away (on the GPU, say), because it avoids a copy of the +-- scalar to and from the host. +removeScalarCopy :: BuilderOps rep => TopDownRuleBasicOp rep +removeScalarCopy 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, + not $ ST.aliases arr_x arr_y vtable, + 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 $ 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 safety arr_x slice_x' $ + Var v' +removeScalarCopy _ _ _ _ = + Skip diff --git a/src/Futhark/IR/MC/Op.hs b/src/Futhark/IR/MC/Op.hs --- a/src/Futhark/IR/MC/Op.hs +++ b/src/Futhark/IR/MC/Op.hs @@ -131,8 +131,10 @@ instance (PrettyRep rep, Pretty op) => Pretty (MCOp rep op) where ppr (ParOp Nothing op) = ppr op ppr (ParOp (Just par_op) op) = - "par" <+> nestedBlock "{" "}" (ppr par_op) - "seq" <+> nestedBlock "{" "}" (ppr op) + "par" + <+> nestedBlock "{" "}" (ppr par_op) + "seq" + <+> nestedBlock "{" "}" (ppr op) ppr (OtherOp op) = ppr op instance (OpMetrics (Op rep), OpMetrics op) => OpMetrics (MCOp rep op) where 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 @@ -548,7 +548,9 @@ 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 + 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 @@ -586,7 +588,8 @@ | otherwise -> TC.bad $ TC.TypeError $ - "Array " ++ pretty v + "Array " + ++ pretty v ++ " returned by function, but has nontrivial index function " ++ pretty ixfun @@ -775,11 +778,12 @@ ( length val_ts == length rt && and (zipWith (matches ctx_map_ids ctx_map_exts) val_ts rt) ) - $ TC.bad $ - TC.TypeError $ - "Expression type:\n " ++ prettyTuple rt - ++ "\ncannot match pattern type:\n " - ++ prettyTuple val_ts + $ TC.bad + $ TC.TypeError + $ "Expression type:\n " + ++ prettyTuple rt + ++ "\ncannot match pattern type:\n " + ++ prettyTuple val_ts where matches _ _ (MemPrim x) (MemPrim y) = x == y matches _ _ (MemMem x_space) (MemMem y_space) = @@ -787,7 +791,8 @@ matches _ _ (MemAcc x_accs x_ispace x_ts _) (MemAcc y_accs y_ispace y_ts _) = (x_accs, x_ispace, x_ts) == (y_accs, y_ispace, y_ts) matches ctxids ctxexts (MemArray x_pt x_shape _ x_ret) (MemArray y_pt y_shape _ y_ret) = - x_pt == y_pt && x_shape == y_shape + x_pt == y_pt + && x_shape == y_shape && case (x_ret, y_ret) of (ReturnsInBlock _ x_ixfun, Just (ReturnsInBlock _ y_ixfun)) -> let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun @@ -854,7 +859,9 @@ pure (mem, ixfun) _ -> error $ - "Expected " ++ pretty name ++ " to be array but bound to:\n" + "Expected " + ++ pretty name + ++ " to be array but bound to:\n" ++ pretty summary checkMemInfo :: @@ -875,7 +882,8 @@ _ -> TC.bad $ TC.TypeError $ - "Variable " ++ pretty v + "Variable " + ++ pretty v ++ " used as memory block, but is of type " ++ pretty t ++ "." @@ -887,7 +895,8 @@ unless (ixfun_rank == ident_rank) $ TC.bad $ TC.TypeError $ - "Arity of index function (" ++ pretty ixfun_rank + "Arity of index function (" + ++ pretty ixfun_rank ++ ") does not match rank of array " ++ pretty name ++ " (" @@ -936,7 +945,9 @@ MemArray bt shape u $ Just $ ReturnsNewBlock DefaultSpace i $ - IxFun.iota $ map convert $ shapeDims shape + IxFun.iota $ + map convert $ + shapeDims shape | otherwise = pure $ MemArray bt shape u Nothing addDec (Acc acc ispace ts u) = @@ -968,7 +979,9 @@ MemArray et shape _ (ArrayIn mem ixfun) -> pure $ MemArray et (fmap Free shape) NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun + Just $ + ReturnsInBlock mem $ + existentialiseIxFun [] ixfun MemMem space -> pure $ MemMem space MemAcc acc ispace ts u -> @@ -1000,7 +1013,8 @@ Just $ ReturnsInBlock mem $ existentialiseIxFun [] $ - IxFun.reshape ixfun $ map (fmap pe64) newshape + IxFun.reshape ixfun $ + map (fmap pe64) newshape ] expReturns (BasicOp (Rearrange perm v)) = do (et, Shape dims, mem, ixfun) <- arrayVarReturns v @@ -1008,7 +1022,9 @@ dims' = rearrangeShape perm dims pure [ MemArray et (Shape $ map Free dims') NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun' + Just $ + ReturnsInBlock mem $ + existentialiseIxFun [] ixfun' ] expReturns (BasicOp (Rotate offsets v)) = do (et, Shape dims, mem, ixfun) <- arrayVarReturns v @@ -1016,7 +1032,9 @@ ixfun' = IxFun.rotate ixfun offsets' pure [ MemArray et (Shape $ map Free dims) NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun' + Just $ + ReturnsInBlock mem $ + existentialiseIxFun [] ixfun' ] expReturns (BasicOp (Index v slice)) = do pure . varInfoToExpReturns <$> sliceInfo v slice 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 @@ -469,7 +469,8 @@ let (dims', slc') = unzip $ filter ((/= 0) . ldStride . fst) $ - zip dims $ map normIndex slc + zip dims $ + map normIndex slc -- Check that: -- 1. a clean split point exists between Fixed and Sliced dims -- 2. the outermost sliced dim has +/- 1 stride AND is unrotated or full. @@ -658,7 +659,8 @@ _ -> error "reshape: reached impossible case" ) ([], []) - $ reverse $ zip3 iota_shape newshape perm' + $ reverse + $ zip3 iota_shape newshape perm' (sup_inds, support) = unzip $ sortBy (compare `on` fst) support_inds (rpt_inds, repeats) = unzip repeat_inds @@ -1051,7 +1053,7 @@ closeEnoughLMADs (lmad1, lmad2) = length (lmadDims lmad1) == length (lmadDims lmad2) && map ldPerm (lmadDims lmad1) - == map ldPerm (lmadDims lmad2) + == map ldPerm (lmadDims lmad2) -- | Returns true if two 'IxFun's are equivalent. -- @@ -1065,13 +1067,13 @@ equivalentLMADs (lmad1, lmad2) = length (lmadDims lmad1) == length (lmadDims lmad2) && map ldPerm (lmadDims lmad1) - == map ldPerm (lmadDims lmad2) + == map ldPerm (lmadDims lmad2) && lmadOffset lmad1 - == lmadOffset lmad2 + == lmadOffset lmad2 && map ldStride (lmadDims lmad1) - == map ldStride (lmadDims lmad2) + == map ldStride (lmadDims lmad2) && map ldRotate (lmadDims lmad1) - == map ldRotate (lmadDims lmad2) + == map ldRotate (lmadDims lmad2) -- | Dynamically determine if two 'LMADDim' are equal. -- 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 @@ -203,7 +203,9 @@ Just (BasicOp (Copy v2), v1_cs) <- ST.lookupExp v1 vtable = Simplify $ do v0' <- certifying (v0_cs <> v1_cs) $ - letExp "rearrange_v0" $ BasicOp $ Rearrange perm v2 + letExp "rearrange_v0" $ + BasicOp $ + Rearrange perm v2 letBind pat $ BasicOp $ Copy v0' copyCopyToCopy _ _ _ _ = 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 @@ -32,13 +32,13 @@ import Futhark.IR.MCMem (MCMem) import Futhark.IR.Mem import qualified Futhark.IR.Mem.IxFun as IxFun -import Futhark.IR.Primitive.Parse import Futhark.IR.SOACS (SOACS) import qualified Futhark.IR.SOACS.SOAC as SOAC import qualified Futhark.IR.SegOp as SegOp import Futhark.IR.Seq (Seq) import Futhark.IR.SeqMem (SeqMem) import Futhark.Util.Pretty (prettyText) +import Language.Futhark.Primitive.Parse import Text.Megaparsec import Text.Megaparsec.Char hiding (space) import qualified Text.Megaparsec.Char.Lexer as L @@ -46,7 +46,7 @@ type Parser = Parsec Void T.Text pStringLiteral :: Parser String -pStringLiteral = char '"' >> manyTill L.charLiteral (char '"') +pStringLiteral = lexeme $ char '"' >> manyTill L.charLiteral (char '"') pName :: Parser Name pName = @@ -58,7 +58,8 @@ pVName :: Parser VName pVName = lexeme $ do (s, tag) <- - satisfy constituent `manyTill_` try pTag + satisfy constituent + `manyTill_` try pTag "variable name" pure $ VName (nameFromString s) tag where @@ -95,8 +96,10 @@ "acc" *> parens ( Acc - <$> pVName <* pComma - <*> pShape <* pComma + <$> pVName + <* pComma + <*> pShape + <* pComma <*> pTypes <*> pure NoUniqueness ) @@ -137,6 +140,9 @@ pExtType :: Parser ExtType pExtType = pTypeBase pExtShape (pure NoUniqueness) +pRank :: Parser Rank +pRank = Rank . length <$> many "[]" + pUniqueness :: Parser Uniqueness pUniqueness = choice [pAsterisk $> Unique, pure Nonunique] @@ -190,8 +196,11 @@ pDimIndex = choice [ try $ - DimSlice <$> pSubExp <* lexeme ":+" - <*> pSubExp <* lexeme "*" + DimSlice + <$> pSubExp + <* lexeme ":+" + <*> pSubExp + <* lexeme "*" <*> pSubExp, DimFix <$> pSubExp ] @@ -246,9 +255,11 @@ keyword ("iota" <> prettyText (primBitSize (IntType t))) *> parens ( Iota - <$> pSubExp <* pComma - <*> pSubExp <* pComma + <$> pSubExp + <* pComma <*> pSubExp + <* pComma + <*> pSubExp <*> pure t ) @@ -256,13 +267,17 @@ pBasicOp = choice [ keyword "opaque" $> Opaque OpaqueNil <*> parens pSubExp, - keyword "trace" $> uncurry (Opaque . OpaqueTrace) - <*> parens ((,) <$> lexeme pStringLiteral <* pComma <*> pSubExp), + keyword "trace" + $> uncurry (Opaque . OpaqueTrace) + <*> parens ((,) <$> pStringLiteral <* pComma <*> pSubExp), keyword "copy" $> Copy <*> parens pVName, keyword "assert" *> parens - ( Assert <$> pSubExp <* pComma - <*> pErrorMsg <* pComma + ( Assert + <$> pSubExp + <* pComma + <*> pErrorMsg + <* pComma <*> pErrorLoc ), keyword "rotate" @@ -290,14 +305,18 @@ pIota, try $ flip Update - <$> pVName <* keyword "with" + <$> pVName + <* keyword "with" <*> choice [lexeme "?" $> Safe, pure Unsafe] - <*> pSlice <* lexeme "=" + <*> pSlice + <* lexeme "=" <*> pSubExp, try $ FlatUpdate - <$> pVName <* keyword "with" - <*> pFlatSlice <* lexeme "=" + <$> pVName + <* keyword "with" + <*> pFlatSlice + <* lexeme "=" <*> pVName, ArrayLit <$> brackets (pSubExp `sepBy` pComma) @@ -398,7 +417,10 @@ pIf :: PR rep -> Parser (Exp rep) pIf pr = - keyword "if" $> f <*> pSort <*> pSubExp + keyword "if" + $> f + <*> pSort + <*> pSubExp <*> (keyword "then" *> pBranchBody) <*> (keyword "else" *> pBranchBody) <*> (lexeme ":" *> pBranchTypes pr) @@ -424,7 +446,8 @@ p safety = Apply <$> pName - <*> parens (pArg `sepBy` pComma) <* pColon + <*> parens (pArg `sepBy` pComma) + <* pColon <*> pRetTypes pr <*> pure (safety, mempty, mempty) @@ -436,9 +459,11 @@ pLoop :: PR rep -> Parser (Exp rep) pLoop pr = - keyword "loop" $> DoLoop + keyword "loop" + $> DoLoop <*> pLoopParams - <*> pLoopForm <* keyword "do" + <*> pLoopForm + <* keyword "do" <*> braces (pBody pr) where pLoopParams = do @@ -449,9 +474,12 @@ pLoopForm = choice - [ keyword "for" $> ForLoop - <*> pVName <* lexeme ":" - <*> pIntType <* lexeme "<" + [ keyword "for" + $> ForLoop + <*> pVName + <* lexeme ":" + <*> pIntType + <* lexeme "<" <*> pSubExp <*> many ((,) <$> pLParam pr <* keyword "in" <*> pVName), keyword "while" $> WhileLoop <*> pVName @@ -462,8 +490,10 @@ choice [ lexeme "\\" $> lam - <*> pLParams pr <* pColon - <*> pTypes <* pArrow + <*> pLParams pr + <* pColon + <*> pTypes + <* pArrow <*> pBody pr, keyword "nilFn" $> Lambda mempty (Body (pBodyDec pr) mempty []) [] ] @@ -474,13 +504,15 @@ pReduce pr = SOAC.Reduce <$> pComm - <*> pLambda pr <* pComma + <*> pLambda pr + <* pComma <*> braces (pSubExp `sepBy` pComma) pScan :: PR rep -> Parser (SOAC.Scan rep) pScan pr = SOAC.Scan - <$> pLambda pr <* pComma + <$> pLambda pr + <* pComma <*> braces (pSubExp `sepBy` pComma) pWithAcc :: PR rep -> Parser (Exp rep) @@ -491,7 +523,8 @@ pInput = parens ( (,,) - <$> pShape <* pComma + <$> pShape + <* pComma <*> pVNames <*> optional (pComma *> pCombFun) ) @@ -511,7 +544,8 @@ pCerts :: Parser Certs pCerts = choice - [ lexeme "#" *> braces (Certs <$> pVName `sepBy` pComma) + [ lexeme "#" + *> braces (Certs <$> pVName `sepBy` pComma) "certificates", pure mempty ] @@ -535,24 +569,42 @@ Body (pBodyDec pr) mempty <$> pResult ] +pValueType :: Parser ValueType +pValueType = comb <$> pRank <*> pSignedType + where + comb r (s, t) = ValueType s r t + pSignedType = + choice + [ keyword "u8" $> (Unsigned, IntType Int8), + keyword "u16" $> (Unsigned, IntType Int16), + keyword "u32" $> (Unsigned, IntType Int32), + keyword "u64" $> (Unsigned, IntType Int64), + (Signed,) <$> pPrimType + ] + +pEntryPointType :: Parser EntryPointType +pEntryPointType = + choice + [ keyword "opaque" $> TypeOpaque <*> pStringLiteral, + TypeTransparent <$> pValueType + ] + pEntry :: Parser EntryPoint pEntry = parens $ - (,,) <$> (nameFromString <$> pStringLiteral) - <* pComma <*> pEntryPointInputs - <* pComma <*> pEntryPointTypes + (,,) + <$> (nameFromString <$> pStringLiteral) + <* pComma + <*> pEntryPointInputs + <* pComma + <*> pEntryPointResults where - pEntryPointTypes = braces (pEntryPointType `sepBy` pComma) pEntryPointInputs = braces (pEntryPointInput `sepBy` pComma) - pEntryPointType = do - u <- pUniqueness - choice - [ "direct" $> TypeDirect u, - "unsigned" $> TypeUnsigned u, - "opaque" *> parens (TypeOpaque u <$> pStringLiteral <* pComma <*> pInt) - ] + pEntryPointResults = braces (pEntryPointResult `sepBy` pComma) pEntryPointInput = - EntryParam <$> pName <* pColon <*> pEntryPointType + EntryParam <$> pName <* pColon <*> pUniqueness <*> pEntryPointType + pEntryPointResult = + EntryResult <$> pUniqueness <*> pEntryPointType pFunDef :: PR rep -> Parser (FunDef rep) pFunDef pr = do @@ -568,8 +620,22 @@ FunDef entry attrs fname ret fparams <$> (pEqual *> braces (pBody pr)) +pOpaqueType :: Parser (String, OpaqueType) +pOpaqueType = + (,) + <$> (keyword "type" *> pStringLiteral <* pEqual) + <*> choice [pRecord, pOpaque] + where + pFieldName = choice [pName, nameFromString . show <$> pInt] + pField = (,) <$> pFieldName <* pColon <*> pEntryPointType + pRecord = keyword "record" $> OpaqueRecord <*> braces (many pField) + pOpaque = keyword "opaque" $> OpaqueType <*> braces (many pValueType) + +pOpaqueTypes :: Parser OpaqueTypes +pOpaqueTypes = keyword "types" $> OpaqueTypes <*> braces (many pOpaqueType) + pProg :: PR rep -> Parser (Prog rep) -pProg pr = Prog <$> pStms pr <*> many (pFunDef pr) +pProg pr = Prog <$> pOpaqueTypes <*> pStms pr <*> many (pFunDef pr) pSOAC :: PR rep -> Parser (SOAC.SOAC rep) pSOAC pr = @@ -588,21 +654,27 @@ pScrema p = parens $ SOAC.Screma - <$> pSubExp <* pComma - <*> braces (pVName `sepBy` pComma) <* pComma + <$> pSubExp + <* pComma + <*> braces (pVName `sepBy` pComma) + <* pComma <*> p pScremaForm = SOAC.ScremaForm - <$> braces (pScan pr `sepBy` pComma) <* pComma - <*> braces (pReduce pr `sepBy` pComma) <* pComma + <$> braces (pScan pr `sepBy` pComma) + <* pComma + <*> braces (pReduce pr `sepBy` pComma) + <* pComma <*> pLambda pr pRedomapForm = SOAC.ScremaForm mempty - <$> braces (pReduce pr `sepBy` pComma) <* pComma + <$> braces (pReduce pr `sepBy` pComma) + <* pComma <*> pLambda pr pScanomapForm = SOAC.ScremaForm - <$> braces (pScan pr `sepBy` pComma) <* pComma + <$> braces (pScan pr `sepBy` pComma) + <* pComma <*> pure mempty <*> pLambda pr pMapForm = @@ -610,8 +682,11 @@ pScatter = keyword "scatter" *> parens - ( SOAC.Scatter <$> pSubExp <* pComma - <*> braces (pVName `sepBy` pComma) <* pComma + ( SOAC.Scatter + <$> pSubExp + <* pComma + <*> braces (pVName `sepBy` pComma) + <* pComma <*> pLambda pr <*> many (pComma *> pDest) ) @@ -622,18 +697,25 @@ keyword "hist" *> parens ( SOAC.Hist - <$> pSubExp <* pComma - <*> braces (pVName `sepBy` pComma) <* pComma - <*> braces (pHistOp `sepBy` pComma) <* pComma + <$> pSubExp + <* pComma + <*> braces (pVName `sepBy` pComma) + <* pComma + <*> braces (pHistOp `sepBy` pComma) + <* pComma <*> pLambda pr ) where pHistOp = SOAC.HistOp - <$> pShape <* pComma - <*> pSubExp <* pComma - <*> braces (pVName `sepBy` pComma) <* pComma - <*> braces (pSubExp `sepBy` pComma) <* pComma + <$> pShape + <* pComma + <*> pSubExp + <* pComma + <*> braces (pVName `sepBy` pComma) + <* pComma + <*> braces (pSubExp `sepBy` pComma) + <* pComma <*> pLambda pr pStream = choice @@ -646,33 +728,44 @@ pStreamPar order comm = parens $ SOAC.Stream - <$> pSubExp <* pComma - <*> braces (pVName `sepBy` pComma) <* pComma - <*> pParForm order comm <* pComma - <*> braces (pSubExp `sepBy` pComma) <* pComma + <$> pSubExp + <* pComma + <*> braces (pVName `sepBy` pComma) + <* pComma + <*> pParForm order comm + <* pComma + <*> braces (pSubExp `sepBy` pComma) + <* pComma <*> pLambda pr pParForm order comm = SOAC.Parallel order comm <$> pLambda pr pStreamSeq = parens $ SOAC.Stream - <$> pSubExp <* pComma - <*> braces (pVName `sepBy` pComma) <* pComma + <$> pSubExp + <* pComma + <*> braces (pVName `sepBy` pComma) + <* pComma <*> pure SOAC.Sequential - <*> braces (pSubExp `sepBy` pComma) <* pComma + <*> braces (pSubExp `sepBy` pComma) + <* pComma <*> pLambda pr pVJP = parens $ SOAC.VJP - <$> pLambda pr <* pComma - <*> braces (pSubExp `sepBy` pComma) <* pComma + <$> pLambda pr + <* pComma <*> braces (pSubExp `sepBy` pComma) + <* pComma + <*> braces (pSubExp `sepBy` pComma) pJVP = parens $ SOAC.JVP - <$> pLambda pr <* pComma - <*> braces (pSubExp `sepBy` pComma) <* pComma + <$> pLambda pr + <* pComma <*> braces (pSubExp `sepBy` pComma) + <* pComma + <*> braces (pSubExp `sepBy` pComma) pSizeClass :: Parser GPU.SizeClass pSizeClass = @@ -686,7 +779,8 @@ keyword "threshold" *> parens ( flip GPU.SizeThreshold - <$> choice [Just <$> pInt64, "def" $> Nothing] <* pComma + <$> choice [Just <$> pInt64, "def" $> Nothing] + <* pComma <*> pKernelPath ), keyword "bespoke" @@ -714,22 +808,31 @@ keyword "calc_num_groups" *> parens ( GPU.CalcNumGroups - <$> pSubExp <* pComma <*> pName <* pComma <*> pSubExp + <$> pSubExp + <* pComma + <*> pName + <* pComma + <*> pSubExp ), keyword "split_space" *> parens ( GPU.SplitSpace GPU.SplitContiguous - <$> pSubExp <* pComma - <*> pSubExp <* pComma + <$> pSubExp + <* pComma <*> pSubExp + <* pComma + <*> pSubExp ), keyword "split_space_strided" *> parens ( GPU.SplitSpace - <$> (GPU.SplitStrided <$> pSubExp) <* pComma - <*> pSubExp <* pComma - <*> pSubExp <* pComma + <$> (GPU.SplitStrided <$> pSubExp) + <* pComma <*> pSubExp + <* pComma + <*> pSubExp + <* pComma + <*> pSubExp ) ] @@ -745,7 +848,8 @@ pKernelResult = do cs <- pCerts choice - [ keyword "returns" $> SegOp.Returns + [ keyword "returns" + $> SegOp.Returns <*> choice [ keyword "(manifest)" $> SegOp.ResultNoSimplify, keyword "(private)" $> SegOp.ResultPrivate, @@ -755,26 +859,33 @@ <*> pSubExp, try $ flip (SegOp.WriteReturns cs) - <$> pVName <* pColon - <*> pShape <* keyword "with" + <$> pVName + <* pColon + <*> pShape + <* keyword "with" <*> parens (pWrite `sepBy` pComma), try "tile" - *> parens (SegOp.TileReturns cs <$> (pTile `sepBy` pComma)) <*> pVName, + *> parens (SegOp.TileReturns cs <$> (pTile `sepBy` pComma)) + <*> pVName, try "blkreg_tile" - *> parens (SegOp.RegTileReturns cs <$> (pRegTile `sepBy` pComma)) <*> pVName, + *> parens (SegOp.RegTileReturns cs <$> (pRegTile `sepBy` pComma)) + <*> pVName, keyword "concat" *> parens ( SegOp.ConcatReturns cs SegOp.SplitContiguous - <$> pSubExp <* pComma + <$> pSubExp + <* pComma <*> pSubExp ) <*> pVName, keyword "concat_strided" *> parens ( SegOp.ConcatReturns cs - <$> (SegOp.SplitStrided <$> pSubExp) <* pComma - <*> pSubExp <* pComma + <$> (SegOp.SplitStrided <$> pSubExp) + <* pComma <*> pSubExp + <* pComma + <*> pSubExp ) <*> pVName ] @@ -791,7 +902,8 @@ pKernelBody :: PR rep -> Parser (SegOp.KernelBody rep) pKernelBody pr = SegOp.KernelBody (pBodyDec pr) - <$> pStms pr <* keyword "return" + <$> pStms pr + <* keyword "return" <*> braces (pKernelResult `sepBy` pComma) pSegOp :: PR rep -> Parser lvl -> Parser (SegOp.SegOp lvl rep) @@ -806,13 +918,16 @@ pSegMap = SegOp.SegMap <$> pLvl - <*> pSegSpace <* pColon + <*> pSegSpace + <* pColon <*> pTypes <*> braces (pKernelBody pr) pSegOp' f p = - f <$> pLvl + f + <$> pLvl <*> pSegSpace - <*> parens (p `sepBy` pComma) <* pColon + <*> parens (p `sepBy` pComma) + <* pColon <*> pTypes <*> braces (pKernelBody pr) pSegBinOp = do @@ -823,11 +938,16 @@ pure $ SegOp.SegBinOp comm lam nes shape pHistOp = SegOp.HistOp - <$> pShape <* pComma - <*> pSubExp <* pComma - <*> braces (pVName `sepBy` pComma) <* pComma - <*> braces (pSubExp `sepBy` pComma) <* pComma - <*> pShape <* pComma + <$> pShape + <* pComma + <*> pSubExp + <* pComma + <*> braces (pVName `sepBy` pComma) + <* pComma + <*> braces (pSubExp `sepBy` pComma) + <* pComma + <*> pShape + <* pComma <*> pLambda pr pSegRed = pSegOp' SegOp.SegRed pSegBinOp pSegScan = pSegOp' SegOp.SegScan pSegBinOp @@ -845,7 +965,8 @@ <*> choice [ pSemi *> choice - [ keyword "full" $> SegOp.SegNoVirtFull + [ keyword "full" + $> SegOp.SegNoVirtFull <*> (SegOp.SegSeqDims <$> brackets (pInt `sepBy` pComma)), keyword "virtualise" $> SegOp.SegVirt ], @@ -927,8 +1048,11 @@ pAcc u = keyword "acc" *> parens - ( MemAcc <$> pVName <* pComma - <*> pShape <* pComma + ( MemAcc + <$> pVName + <* pComma + <*> pShape + <* pComma <*> pTypes <*> pure u ) 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 @@ -51,6 +51,9 @@ instance Pretty Shape where ppr = mconcat . map (brackets . ppr) . shapeDims +instance Pretty Rank where + ppr (Rank r) = mconcat $ replicate r "[]" + instance Pretty a => Pretty (Ext a) where ppr (Free e) = ppr e ppr (Ext x) = text "?" <> text (show x) @@ -109,7 +112,8 @@ | null stms = braces (commasep $ map ppr res) | otherwise = stack (map ppr $ stmsToList stms) - text "in" <+> braces (commasep $ map ppr res) + text "in" + <+> braces (commasep $ map ppr res) instance Pretty Attr where ppr (AttrName v) = ppr v @@ -148,7 +152,8 @@ instance PrettyRep rep => Pretty (Stm rep) where ppr stm@(Let pat aux e) = align . hang 2 $ - text "let" <+> align (ppr pat) + text "let" + <+> align (ppr pat) <+> case (linebreak, stmannot) of (True, []) -> equals ppr e (False, []) -> equals <+/> ppr e @@ -235,7 +240,9 @@ instance PrettyRep rep => Pretty (Exp rep) where ppr (If c t f (IfDec ret ifsort)) = - text "if" <+> info' <+> ppr c + text "if" + <+> info' + <+> ppr c text "then" <+> maybeNest t <+> text "else" @@ -254,7 +261,7 @@ ppr (Apply fname args ret (safety, _, _)) = applykw <+> text (nameToString fname) - <> apply (map (align . pprArg) args) + <> apply (map (align . pprArg) args) colon <+> braces (commasep $ map ppr ret) where @@ -265,7 +272,8 @@ Safe -> text "apply" ppr (Op op) = ppr op ppr (DoLoop merge form loopbody) = - text "loop" <+> braces (commastack $ map ppr params) + text "loop" + <+> braces (commastack $ map ppr params) <+> equals <+> ppTuple' args ( case form of @@ -298,28 +306,40 @@ where ppInput (shape, arrs, op) = parens - ( ppr shape <> comma <+> ppTuple' arrs - <> case op of - Nothing -> mempty - Just (op', nes) -> - comma parens (ppr op' <> comma ppTuple' (map ppr nes)) + ( ppr shape <> comma + <+> ppTuple' arrs + <> case op of + Nothing -> mempty + Just (op', nes) -> + comma parens (ppr op' <> comma ppTuple' (map ppr nes)) ) instance PrettyRep rep => Pretty (Lambda rep) where ppr (Lambda [] (Body _ stms []) []) | stms == mempty = text "nilFn" ppr (Lambda params body rettype) = - text "\\" <+> ppTuple' params + text "\\" + <+> ppTuple' params indent 2 (colon <+> ppTupleLines' rettype <+> text "->") indent 2 (ppr body) +instance Pretty Signedness where + ppr Signed = "signed" + ppr Unsigned = "unsigned" + +instance Pretty ValueType where + ppr (ValueType s (Rank r) t) = + mconcat (replicate r "[]") <> text (prettySigned (s == Unsigned) t) + instance Pretty EntryPointType where - ppr (TypeDirect u) = ppr u <> "direct" - ppr (TypeUnsigned u) = ppr u <> "unsigned" - ppr (TypeOpaque u desc n) = ppr u <> "opaque" <> apply [ppr (show desc), ppr n] + ppr (TypeTransparent t) = ppr t + ppr (TypeOpaque desc) = "opaque" <+> pquote (text desc) instance Pretty EntryParam where - ppr (EntryParam name t) = ppr name <> colon <+> ppr t + ppr (EntryParam name u t) = ppr name <> colon <+> ppr u <> ppr t +instance Pretty EntryResult where + ppr (EntryResult u t) = ppr u <> ppr t + instance PrettyRep rep => Pretty (FunDef rep) where ppr (FunDef entry attrs name rettype fparams body) = annot (attrAnnots attrs) $ @@ -336,13 +356,26 @@ "entry" <> parens ( "\"" <> ppr p_name <> "\"" <> comma - ppTuple' p_entry <> comma - ppTuple' ret_entry + ppTupleLines' p_entry <> comma + ppTupleLines' ret_entry ) +instance Pretty OpaqueType where + ppr (OpaqueType ts) = + "opaque" <+> nestedBlock "{" "}" (stack $ map ppr ts) + ppr (OpaqueRecord fs) = + "record" <+> nestedBlock "{" "}" (stack $ map p fs) + where + p (f, et) = ppr f <> ":" <+> ppr et + +instance Pretty OpaqueTypes where + ppr (OpaqueTypes ts) = "types" <+> nestedBlock "{" "}" (stack $ map p ts) + where + p (name, t) = "type" <+> pquote (ppr name) <+> equals <+> ppr t + instance PrettyRep rep => Pretty (Prog rep) where - ppr (Prog consts funs) = - stack $ punctuate line $ ppr consts : map ppr funs + ppr (Prog types consts funs) = + stack $ punctuate line $ ppr types : ppr consts : map ppr funs instance Pretty d => Pretty (DimChange d) where ppr (DimCoercion se) = text "~" <> ppr se diff --git a/src/Futhark/IR/Primitive.hs b/src/Futhark/IR/Primitive.hs deleted file mode 100644 --- a/src/Futhark/IR/Primitive.hs +++ /dev/null @@ -1,1873 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - --- | Definitions of primitive types, the values that inhabit these --- types, and operations on these values. A primitive value can also --- be called a scalar. --- --- Essentially, this module describes the subset of the (internal) --- Futhark language that operates on primitive types. -module Futhark.IR.Primitive - ( -- * Types - IntType (..), - allIntTypes, - FloatType (..), - allFloatTypes, - PrimType (..), - allPrimTypes, - module Data.Int, - Half, - - -- * Values - IntValue (..), - intValue, - intValueType, - valueIntegral, - FloatValue (..), - floatValue, - floatValueType, - PrimValue (..), - primValueType, - blankPrimValue, - - -- * Operations - Overflow (..), - Safety (..), - UnOp (..), - allUnOps, - BinOp (..), - allBinOps, - ConvOp (..), - allConvOps, - CmpOp (..), - allCmpOps, - - -- ** Unary Operations - doUnOp, - doComplement, - doAbs, - doFAbs, - doSSignum, - doUSignum, - - -- ** Binary Operations - doBinOp, - doAdd, - doMul, - doSDiv, - doSMod, - doPow, - - -- ** Conversion Operations - doConvOp, - doZExt, - doSExt, - doFPConv, - doFPToUI, - doFPToSI, - doUIToFP, - doSIToFP, - intToInt64, - intToWord64, - flipConvOp, - - -- * Comparison Operations - doCmpOp, - doCmpEq, - doCmpUlt, - doCmpUle, - doCmpSlt, - doCmpSle, - doFCmpLt, - doFCmpLe, - - -- * Type Of - binOpType, - unOpType, - cmpOpType, - convOpType, - - -- * Primitive functions - primFuns, - - -- * Utility - zeroIsh, - zeroIshInt, - oneIsh, - oneIshInt, - negativeIsh, - primBitSize, - primByteSize, - intByteSize, - floatByteSize, - commutativeBinOp, - associativeBinOp, - - -- * Prettyprinting - convOpFun, - prettySigned, - ) -where - -import Control.Category -import qualified Data.Binary.Get as G -import qualified Data.Binary.Put as P -import Data.Bits - ( complement, - countLeadingZeros, - countTrailingZeros, - popCount, - shift, - shiftR, - xor, - (.&.), - (.|.), - ) -import Data.Fixed (mod') -- Weird location. -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Map as M -import Data.Word -import Foreign.C.Types (CUShort (..)) -import Futhark.Util - ( cbrt, - cbrtf, - ceilDouble, - ceilFloat, - convFloat, - erf, - erfc, - erfcf, - erff, - floorDouble, - floorFloat, - hypot, - hypotf, - lgamma, - lgammaf, - roundDouble, - roundFloat, - tgamma, - tgammaf, - ) -import Futhark.Util.Pretty -import Numeric.Half -import Prelude hiding (id, (.)) - --- | An integer type, ordered by size. Note that signedness is not a --- property of the type, but a property of the operations performed on --- values of these types. -data IntType - = Int8 - | Int16 - | Int32 - | Int64 - deriving (Eq, Ord, Show, Enum, Bounded) - -instance Pretty IntType where - ppr Int8 = text "i8" - ppr Int16 = text "i16" - ppr Int32 = text "i32" - ppr Int64 = text "i64" - --- | A list of all integer types. -allIntTypes :: [IntType] -allIntTypes = [minBound .. maxBound] - --- | A floating point type. -data FloatType - = 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" - --- | A list of all floating-point types. -allFloatTypes :: [FloatType] -allFloatTypes = [minBound .. maxBound] - --- | Low-level primitive types. -data PrimType - = IntType IntType - | FloatType FloatType - | Bool - | -- | An informationless type - An array of this type takes up no space. - Unit - deriving (Eq, Ord, Show) - -instance Enum PrimType where - toEnum 0 = IntType Int8 - toEnum 1 = IntType Int16 - toEnum 2 = IntType Int32 - toEnum 3 = IntType Int64 - 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 Float16) = 4 - fromEnum (FloatType Float32) = 5 - fromEnum (FloatType Float64) = 6 - fromEnum Bool = 7 - fromEnum Unit = 8 - -instance Bounded PrimType where - minBound = IntType Int8 - maxBound = Unit - -instance Pretty PrimType where - ppr (IntType t) = ppr t - ppr (FloatType t) = ppr t - ppr Bool = text "bool" - ppr Unit = text "unit" - --- | A list of all primitive types. -allPrimTypes :: [PrimType] -allPrimTypes = - map IntType allIntTypes - ++ map FloatType allFloatTypes - ++ [Bool, Unit] - --- | An integer value. -data IntValue - = Int8Value !Int8 - | Int16Value !Int16 - | Int32Value !Int32 - | Int64Value !Int64 - deriving (Eq, Ord, Show) - -instance Pretty IntValue where - ppr (Int8Value v) = text $ show v ++ "i8" - ppr (Int16Value v) = text $ show v ++ "i16" - ppr (Int32Value v) = text $ show v ++ "i32" - ppr (Int64Value v) = text $ show v ++ "i64" - --- | Create an t'IntValue' from a type and an 'Integer'. -intValue :: Integral int => IntType -> int -> IntValue -intValue Int8 = Int8Value . fromIntegral -intValue Int16 = Int16Value . fromIntegral -intValue Int32 = Int32Value . fromIntegral -intValue Int64 = Int64Value . fromIntegral - --- | The type of an integer value. -intValueType :: IntValue -> IntType -intValueType Int8Value {} = Int8 -intValueType Int16Value {} = Int16 -intValueType Int32Value {} = Int32 -intValueType Int64Value {} = Int64 - --- | Convert an t'IntValue' to any 'Integral' type. -valueIntegral :: Integral int => IntValue -> int -valueIntegral (Int8Value v) = fromIntegral v -valueIntegral (Int16Value v) = fromIntegral v -valueIntegral (Int32Value v) = fromIntegral v -valueIntegral (Int64Value v) = fromIntegral v - --- | A floating-point value. -data FloatValue - = 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 - _ == _ = 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" - | isNaN v = text "f32.nan" - | otherwise = text $ show v ++ "f32" - ppr (Float64Value v) - | isInfinite v, v >= 0 = text "f64.inf" - | isInfinite v, v < 0 = text "-f64.inf" - | isNaN v = text "f64.nan" - | otherwise = text $ show v ++ "f64" - --- | 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 - --- | Non-array values. -data PrimValue - = IntValue !IntValue - | FloatValue !FloatValue - | BoolValue !Bool - | -- | The only value of type 'Unit'. - UnitValue - deriving (Eq, Ord, Show) - -instance Pretty PrimValue where - ppr (IntValue v) = ppr v - ppr (BoolValue True) = text "true" - ppr (BoolValue False) = text "false" - ppr (FloatValue v) = ppr v - ppr UnitValue = text "()" - --- | The type of a basic value. -primValueType :: PrimValue -> PrimType -primValueType (IntValue v) = IntType $ intValueType v -primValueType (FloatValue v) = FloatType $ floatValueType v -primValueType BoolValue {} = Bool -primValueType UnitValue = Unit - --- | A "blank" value of the given primitive type - this is zero, or --- whatever is close to it. Don't depend on this value, but use it --- for e.g. creating arrays to be populated by do-loops. -blankPrimValue :: PrimType -> PrimValue -blankPrimValue (IntType Int8) = IntValue $ Int8Value 0 -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 -blankPrimValue Unit = UnitValue - --- | Various unary operators. It is a bit ad-hoc what is a unary --- operator and what is a built-in function. Perhaps these should all --- go away eventually. -data UnOp - = -- | E.g., @! True == False@. - Not - | -- | E.g., @~(~1) = 1@. - Complement IntType - | -- | @abs(-2) = 2@. - Abs IntType - | -- | @fabs(-2.0) = 2.0@. - FAbs FloatType - | -- | Signed sign function: @ssignum(-2)@ = -1. - SSignum IntType - | -- | Unsigned sign function: @usignum(2)@ = 1. - USignum IntType - | -- | Floating-point sign function. - FSignum FloatType - deriving (Eq, Ord, Show) - --- | What to do in case of arithmetic overflow. Futhark's semantics --- are that overflow does wraparound, but for generated code (like --- address arithmetic), it can be beneficial for overflow to be --- undefined behaviour, as it allows better optimisation of things --- such as GPU kernels. --- --- Note that all values of this type are considered equal for 'Eq' and --- 'Ord'. -data Overflow = OverflowWrap | OverflowUndef - deriving (Show) - -instance Eq Overflow where - _ == _ = True - -instance Ord Overflow where - _ `compare` _ = EQ - --- | Whether something is safe or unsafe (mostly function calls, and --- in the context of whether operations are dynamically checked). --- When we inline an 'Unsafe' function, we remove all safety checks in --- its body. The 'Ord' instance picks 'Unsafe' as being less than --- 'Safe'. --- --- For operations like integer division, a safe division will not --- explode the computer in case of division by zero, but instead --- return some unspecified value. This always involves a run-time --- check, so generally the unsafe variant is what the compiler will --- insert, but guarded by an explicit assertion elsewhere. Safe --- operations are useful when the optimiser wants to move e.g. a --- division to a location where the divisor may be zero, but where the --- result will only be used when it is non-zero (so it doesn't matter --- what result is provided with a zero divisor, as long as the program --- keeps running). -data Safety = Unsafe | Safe deriving (Eq, Ord, Show) - --- | Binary operators. These correspond closely to the binary operators in --- LLVM. Most are parametrised by their expected input and output --- types. -data BinOp - = -- | Integer addition. - Add IntType Overflow - | -- | Floating-point addition. - FAdd FloatType - | -- | Integer subtraction. - Sub IntType Overflow - | -- | Floating-point subtraction. - FSub FloatType - | -- | Integer multiplication. - Mul IntType Overflow - | -- | Floating-point multiplication. - FMul FloatType - | -- | Unsigned integer division. Rounds towards - -- negativity infinity. Note: this is different - -- from LLVM. - UDiv IntType Safety - | -- | Unsigned integer division. Rounds towards positive - -- infinity. - UDivUp IntType Safety - | -- | Signed integer division. Rounds towards - -- negativity infinity. Note: this is different - -- from LLVM. - SDiv IntType Safety - | -- | Signed integer division. Rounds towards positive - -- infinity. - SDivUp IntType Safety - | -- | Floating-point division. - FDiv FloatType - | -- | Floating-point modulus. - FMod FloatType - | -- | Unsigned integer modulus; the countepart to 'UDiv'. - UMod IntType Safety - | -- | Signed integer modulus; the countepart to 'SDiv'. - SMod IntType Safety - | -- | Signed integer division. Rounds towards zero. This - -- corresponds to the @sdiv@ instruction in LLVM and - -- integer division in C. - SQuot IntType Safety - | -- | Signed integer division. Rounds towards zero. This - -- corresponds to the @srem@ instruction in LLVM and - -- integer modulo in C. - SRem IntType Safety - | -- | Returns the smallest of two signed integers. - SMin IntType - | -- | Returns the smallest of two unsigned integers. - UMin IntType - | -- | Returns the smallest of two floating-point numbers. - FMin FloatType - | -- | Returns the greatest of two signed integers. - SMax IntType - | -- | Returns the greatest of two unsigned integers. - UMax IntType - | -- | Returns the greatest of two floating-point numbers. - FMax FloatType - | -- | Left-shift. - Shl IntType - | -- | Logical right-shift, zero-extended. - LShr IntType - | -- | Arithmetic right-shift, sign-extended. - AShr IntType - | -- | Bitwise and. - And IntType - | -- | Bitwise or. - Or IntType - | -- | Bitwise exclusive-or. - Xor IntType - | -- | Integer exponentiation. - Pow IntType - | -- | Floating-point exponentiation. - FPow FloatType - | -- | Boolean and - not short-circuiting. - LogAnd - | -- | Boolean or - not short-circuiting. - LogOr - deriving (Eq, Ord, Show) - --- | Comparison operators are like 'BinOp's, but they always return a --- boolean value. The somewhat ugly constructor names are straight --- out of LLVM. -data CmpOp - = -- | All types equality. - CmpEq PrimType - | -- | Unsigned less than. - CmpUlt IntType - | -- | Unsigned less than or equal. - CmpUle IntType - | -- | Signed less than. - CmpSlt IntType - | -- | Signed less than or equal. - CmpSle IntType - | -- Comparison operators for floating-point values. TODO: extend - -- this to handle NaNs and such, like the LLVM fcmp instruction. - - -- | Floating-point less than. - FCmpLt FloatType - | -- | Floating-point less than or equal. - FCmpLe FloatType - | -- Boolean comparison. - - -- | Boolean less than. - CmpLlt - | -- | Boolean less than or equal. - CmpLle - deriving (Eq, Ord, Show) - --- | Conversion operators try to generalise the @from t0 x to t1@ --- instructions from LLVM. -data ConvOp - = -- | Zero-extend the former integer type to the latter. - -- If the new type is smaller, the result is a - -- truncation. - ZExt IntType IntType - | -- | Sign-extend the former integer type to the latter. - -- If the new type is smaller, the result is a - -- truncation. - SExt IntType IntType - | -- | Convert value of the former floating-point type to - -- the latter. If the new type is smaller, the result - -- is a truncation. - FPConv FloatType FloatType - | -- | Convert a floating-point value to the nearest - -- unsigned integer (rounding towards zero). - FPToUI FloatType IntType - | -- | Convert a floating-point value to the nearest - -- signed integer (rounding towards zero). - FPToSI FloatType IntType - | -- | Convert an unsigned integer to a floating-point value. - UIToFP IntType FloatType - | -- | Convert a signed integer to a floating-point value. - SIToFP IntType FloatType - | -- | Convert an integer to a boolean value. Zero - -- becomes false; anything else is true. - IToB IntType - | -- | Convert a boolean to an integer. True is converted - -- to 1 and False to 0. - BToI IntType - | -- | Convert a float to a boolean value. Zero becomes false; - -- | anything else is true. - FToB FloatType - | -- | Convert a boolean to a float. True is converted - -- to 1 and False to 0. - BToF FloatType - deriving (Eq, Ord, Show) - --- | A list of all unary operators for all types. -allUnOps :: [UnOp] -allUnOps = - Not : - map Complement [minBound .. maxBound] - ++ map Abs [minBound .. maxBound] - ++ map FAbs [minBound .. maxBound] - ++ map SSignum [minBound .. maxBound] - ++ map USignum [minBound .. maxBound] - ++ map FSignum [minBound .. maxBound] - --- | A list of all binary operators for all types. -allBinOps :: [BinOp] -allBinOps = - concat - [ Add <$> allIntTypes <*> [OverflowWrap, OverflowUndef], - map FAdd allFloatTypes, - Sub <$> allIntTypes <*> [OverflowWrap, OverflowUndef], - map FSub allFloatTypes, - Mul <$> allIntTypes <*> [OverflowWrap, OverflowUndef], - map FMul allFloatTypes, - UDiv <$> allIntTypes <*> [Unsafe, Safe], - UDivUp <$> allIntTypes <*> [Unsafe, Safe], - SDiv <$> allIntTypes <*> [Unsafe, Safe], - SDivUp <$> allIntTypes <*> [Unsafe, Safe], - map FDiv allFloatTypes, - map FMod allFloatTypes, - UMod <$> allIntTypes <*> [Unsafe, Safe], - SMod <$> allIntTypes <*> [Unsafe, Safe], - SQuot <$> allIntTypes <*> [Unsafe, Safe], - SRem <$> allIntTypes <*> [Unsafe, Safe], - map SMin allIntTypes, - map UMin allIntTypes, - map FMin allFloatTypes, - map SMax allIntTypes, - map UMax allIntTypes, - map FMax allFloatTypes, - map Shl allIntTypes, - map LShr allIntTypes, - map AShr allIntTypes, - map And allIntTypes, - map Or allIntTypes, - map Xor allIntTypes, - map Pow allIntTypes, - map FPow allFloatTypes, - [LogAnd, LogOr] - ] - --- | A list of all comparison operators for all types. -allCmpOps :: [CmpOp] -allCmpOps = - concat - [ map CmpEq allPrimTypes, - map CmpUlt allIntTypes, - map CmpUle allIntTypes, - map CmpSlt allIntTypes, - map CmpSle allIntTypes, - map FCmpLt allFloatTypes, - map FCmpLe allFloatTypes, - [CmpLlt, CmpLle] - ] - --- | A list of all conversion operators for all types. -allConvOps :: [ConvOp] -allConvOps = - concat - [ ZExt <$> allIntTypes <*> allIntTypes, - SExt <$> allIntTypes <*> allIntTypes, - FPConv <$> allFloatTypes <*> allFloatTypes, - FPToUI <$> allFloatTypes <*> allIntTypes, - FPToSI <$> allFloatTypes <*> allIntTypes, - UIToFP <$> allIntTypes <*> allFloatTypes, - SIToFP <$> allIntTypes <*> allFloatTypes, - IToB <$> allIntTypes, - BToI <$> allIntTypes, - FToB <$> allFloatTypes, - BToF <$> allFloatTypes - ] - --- | Apply an 'UnOp' to an operand. Returns 'Nothing' if the --- application is mistyped. -doUnOp :: UnOp -> PrimValue -> Maybe PrimValue -doUnOp Not (BoolValue b) = Just $ BoolValue $ not b -doUnOp Complement {} (IntValue v) = Just $ IntValue $ doComplement v -doUnOp Abs {} (IntValue v) = Just $ IntValue $ doAbs v -doUnOp FAbs {} (FloatValue v) = Just $ FloatValue $ doFAbs v -doUnOp SSignum {} (IntValue v) = Just $ IntValue $ doSSignum v -doUnOp USignum {} (IntValue v) = Just $ IntValue $ doUSignum v -doUnOp FSignum {} (FloatValue v) = Just $ FloatValue $ doFSignum v -doUnOp _ _ = Nothing - --- | E.g., @~(~1) = 1@. -doComplement :: IntValue -> IntValue -doComplement v = intValue (intValueType v) $ complement $ intToInt64 v - --- | @abs(-2) = 2@. -doAbs :: IntValue -> IntValue -doAbs v = intValue (intValueType v) $ abs $ intToInt64 v - --- | @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 - --- | @ssignum(-2)@ = -1. -doSSignum :: IntValue -> IntValue -doSSignum v = intValue (intValueType v) $ signum $ intToInt64 v - --- | @usignum(-2)@ = -1. -doUSignum :: IntValue -> IntValue -doUSignum v = intValue (intValueType v) $ signum $ intToWord64 v - --- | @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 - --- | Apply a 'BinOp' to an operand. Returns 'Nothing' if the --- application is mistyped, or outside the domain (e.g. division by --- zero). -doBinOp :: BinOp -> PrimValue -> PrimValue -> Maybe PrimValue -doBinOp Add {} = doIntBinOp doAdd -doBinOp FAdd {} = doFloatBinOp (+) (+) (+) -doBinOp Sub {} = doIntBinOp doSub -doBinOp FSub {} = doFloatBinOp (-) (-) (-) -doBinOp Mul {} = doIntBinOp doMul -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' 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 fmin fmin fmin - where - fmin x y - | isNaN x = y - | isNaN y = x - | otherwise = min x y -doBinOp SMax {} = doIntBinOp doSMax -doBinOp UMax {} = doIntBinOp doUMax -doBinOp FMax {} = doFloatBinOp fmax fmax fmax - where - fmax x y - | isNaN x = y - | isNaN y = x - | otherwise = max x y -doBinOp Shl {} = doIntBinOp doShl -doBinOp LShr {} = doIntBinOp doLShr -doBinOp AShr {} = doIntBinOp doAShr -doBinOp And {} = doIntBinOp doAnd -doBinOp Or {} = doIntBinOp doOr -doBinOp Xor {} = doIntBinOp doXor -doBinOp Pow {} = doRiskyIntBinOp doPow -doBinOp FPow {} = doFloatBinOp (**) (**) (**) -doBinOp LogAnd {} = doBoolBinOp (&&) -doBinOp LogOr {} = doBoolBinOp (||) - -doIntBinOp :: - (IntValue -> IntValue -> IntValue) -> - PrimValue -> - PrimValue -> - Maybe PrimValue -doIntBinOp f (IntValue v1) (IntValue v2) = - Just $ IntValue $ f v1 v2 -doIntBinOp _ _ _ = Nothing - -doRiskyIntBinOp :: - (IntValue -> IntValue -> Maybe IntValue) -> - PrimValue -> - PrimValue -> - Maybe PrimValue -doRiskyIntBinOp f (IntValue v1) (IntValue v2) = - IntValue <$> f v1 v2 -doRiskyIntBinOp _ _ _ = Nothing - -doFloatBinOp :: - (Half -> Half -> Half) -> - (Float -> Float -> Float) -> - (Double -> Double -> Double) -> - PrimValue -> - PrimValue -> - Maybe PrimValue -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)) = - Just $ FloatValue $ Float64Value $ f64 v1 v2 -doFloatBinOp _ _ _ _ _ = Nothing - -doBoolBinOp :: - (Bool -> Bool -> Bool) -> - PrimValue -> - PrimValue -> - Maybe PrimValue -doBoolBinOp f (BoolValue v1) (BoolValue v2) = - Just $ BoolValue $ f v1 v2 -doBoolBinOp _ _ _ = Nothing - --- | Integer addition. -doAdd :: IntValue -> IntValue -> IntValue -doAdd v1 v2 = intValue (intValueType v1) $ intToInt64 v1 + intToInt64 v2 - --- | Integer subtraction. -doSub :: IntValue -> IntValue -> IntValue -doSub v1 v2 = intValue (intValueType v1) $ intToInt64 v1 - intToInt64 v2 - --- | Integer multiplication. -doMul :: IntValue -> IntValue -> IntValue -doMul v1 v2 = intValue (intValueType v1) $ intToInt64 v1 * intToInt64 v2 - --- | Unsigned integer division. Rounds towards negativity infinity. --- Note: this is different from LLVM. -doUDiv :: IntValue -> IntValue -> Maybe IntValue -doUDiv v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = - Just $ - intValue (intValueType v1) $ - intToWord64 v1 `div` intToWord64 v2 - --- | Unsigned integer division. Rounds towards positive infinity. -doUDivUp :: IntValue -> IntValue -> Maybe IntValue -doUDivUp v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = - Just $ - intValue (intValueType v1) $ - (intToWord64 v1 + intToWord64 v2 - 1) `div` intToWord64 v2 - --- | Signed integer division. Rounds towards negativity infinity. --- Note: this is different from LLVM. -doSDiv :: IntValue -> IntValue -> Maybe IntValue -doSDiv v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = - Just $ - intValue (intValueType v1) $ - intToInt64 v1 `div` intToInt64 v2 - --- | Signed integer division. Rounds towards positive infinity. -doSDivUp :: IntValue -> IntValue -> Maybe IntValue -doSDivUp v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = - Just $ - intValue (intValueType v1) $ - (intToInt64 v1 + intToInt64 v2 - 1) `div` intToInt64 v2 - --- | Unsigned integer modulus; the countepart to 'UDiv'. -doUMod :: IntValue -> IntValue -> Maybe IntValue -doUMod v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToWord64 v1 `mod` intToWord64 v2 - --- | Signed integer modulus; the countepart to 'SDiv'. -doSMod :: IntValue -> IntValue -> Maybe IntValue -doSMod v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `mod` intToInt64 v2 - --- | Signed integer division. Rounds towards zero. --- This corresponds to the @sdiv@ instruction in LLVM. -doSQuot :: IntValue -> IntValue -> Maybe IntValue -doSQuot v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `quot` intToInt64 v2 - --- | Signed integer division. Rounds towards zero. --- This corresponds to the @srem@ instruction in LLVM. -doSRem :: IntValue -> IntValue -> Maybe IntValue -doSRem v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `rem` intToInt64 v2 - --- | Minimum of two signed integers. -doSMin :: IntValue -> IntValue -> IntValue -doSMin v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `min` intToInt64 v2 - --- | Minimum of two unsigned integers. -doUMin :: IntValue -> IntValue -> IntValue -doUMin v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `min` intToWord64 v2 - --- | Maximum of two signed integers. -doSMax :: IntValue -> IntValue -> IntValue -doSMax v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `max` intToInt64 v2 - --- | Maximum of two unsigned integers. -doUMax :: IntValue -> IntValue -> IntValue -doUMax v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `max` intToWord64 v2 - --- | Left-shift. -doShl :: IntValue -> IntValue -> IntValue -doShl v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` intToInt v2 - --- | Logical right-shift, zero-extended. -doLShr :: IntValue -> IntValue -> IntValue -doLShr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `shift` negate (intToInt v2) - --- | Arithmetic right-shift, sign-extended. -doAShr :: IntValue -> IntValue -> IntValue -doAShr v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` negate (intToInt v2) - --- | Bitwise and. -doAnd :: IntValue -> IntValue -> IntValue -doAnd v1 v2 = intValue (intValueType v1) $ intToWord64 v1 .&. intToWord64 v2 - --- | Bitwise or. -doOr :: IntValue -> IntValue -> IntValue -doOr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 .|. intToWord64 v2 - --- | Bitwise exclusive-or. -doXor :: IntValue -> IntValue -> IntValue -doXor v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `xor` intToWord64 v2 - --- | Signed integer exponentatation. -doPow :: IntValue -> IntValue -> Maybe IntValue -doPow v1 v2 - | negativeIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 ^ intToInt64 v2 - --- | Apply a 'ConvOp' to an operand. Returns 'Nothing' if the --- application is mistyped. -doConvOp :: ConvOp -> PrimValue -> Maybe PrimValue -doConvOp (ZExt _ to) (IntValue v) = Just $ IntValue $ doZExt v to -doConvOp (SExt _ to) (IntValue v) = Just $ IntValue $ doSExt v to -doConvOp (FPConv _ to) (FloatValue v) = Just $ FloatValue $ doFPConv v to -doConvOp (FPToUI _ to) (FloatValue v) = Just $ IntValue $ doFPToUI v to -doConvOp (FPToSI _ to) (FloatValue v) = Just $ IntValue $ doFPToSI v to -doConvOp (UIToFP _ to) (IntValue v) = Just $ FloatValue $ doUIToFP v to -doConvOp (SIToFP _ to) (IntValue v) = Just $ FloatValue $ doSIToFP v to -doConvOp (IToB _) (IntValue v) = Just $ BoolValue $ intToInt64 v /= 0 -doConvOp (BToI to) (BoolValue v) = Just $ IntValue $ intValue to $ if v then 1 else 0 :: Int -doConvOp (FToB _) (FloatValue v) = Just $ BoolValue $ floatToDouble v /= 0 -doConvOp (BToF to) (BoolValue v) = Just $ FloatValue $ floatValue to $ if v then 1 else 0 :: Double -doConvOp _ _ = Nothing - --- | Turn the conversion the other way around. Note that most --- conversions are lossy, so there is no guarantee the value will --- round-trip. -flipConvOp :: ConvOp -> ConvOp -flipConvOp (ZExt from to) = ZExt to from -flipConvOp (SExt from to) = SExt to from -flipConvOp (FPConv from to) = FPConv to from -flipConvOp (FPToUI from to) = UIToFP to from -flipConvOp (FPToSI from to) = SIToFP to from -flipConvOp (UIToFP from to) = FPToSI to from -flipConvOp (SIToFP from to) = FPToSI to from -flipConvOp (IToB from) = BToI from -flipConvOp (BToI to) = IToB to -flipConvOp (FToB from) = BToF from -flipConvOp (BToF to) = FToB to - --- | Zero-extend the given integer value to the size of the given --- type. If the type is smaller than the given value, the result is a --- truncation. -doZExt :: IntValue -> IntType -> IntValue -doZExt (Int8Value x) t = intValue t $ toInteger (fromIntegral x :: Word8) -doZExt (Int16Value x) t = intValue t $ toInteger (fromIntegral x :: Word16) -doZExt (Int32Value x) t = intValue t $ toInteger (fromIntegral x :: Word32) -doZExt (Int64Value x) t = intValue t $ toInteger (fromIntegral x :: Word64) - --- | Sign-extend the given integer value to the size of the given --- type. If the type is smaller than the given value, the result is a --- truncation. -doSExt :: IntValue -> IntType -> IntValue -doSExt (Int8Value x) t = intValue t $ toInteger x -doSExt (Int16Value x) t = intValue t $ toInteger x -doSExt (Int32Value x) t = intValue t $ toInteger x -doSExt (Int64Value x) t = intValue t $ toInteger x - --- | 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 - --- | Convert a floating-point value to the nearest --- unsigned integer (rounding towards zero). -doFPToUI :: FloatValue -> IntType -> IntValue -doFPToUI v t = intValue t (truncate $ floatToDouble v :: Word64) - --- | Convert a floating-point value to the nearest --- signed integer (rounding towards zero). -doFPToSI :: FloatValue -> IntType -> IntValue -doFPToSI v t = intValue t (truncate $ floatToDouble v :: Word64) - --- | Convert an unsigned integer to a floating-point value. -doUIToFP :: IntValue -> FloatType -> FloatValue -doUIToFP v t = floatValue t $ intToWord64 v - --- | Convert a signed integer to a floating-point value. -doSIToFP :: IntValue -> FloatType -> FloatValue -doSIToFP v t = floatValue t $ intToInt64 v - --- | Apply a 'CmpOp' to an operand. Returns 'Nothing' if the --- application is mistyped. -doCmpOp :: CmpOp -> PrimValue -> PrimValue -> Maybe Bool -doCmpOp CmpEq {} v1 v2 = Just $ doCmpEq v1 v2 -doCmpOp CmpUlt {} (IntValue v1) (IntValue v2) = Just $ doCmpUlt v1 v2 -doCmpOp CmpUle {} (IntValue v1) (IntValue v2) = Just $ doCmpUle v1 v2 -doCmpOp CmpSlt {} (IntValue v1) (IntValue v2) = Just $ doCmpSlt v1 v2 -doCmpOp CmpSle {} (IntValue v1) (IntValue v2) = Just $ doCmpSle v1 v2 -doCmpOp FCmpLt {} (FloatValue v1) (FloatValue v2) = Just $ doFCmpLt v1 v2 -doCmpOp FCmpLe {} (FloatValue v1) (FloatValue v2) = Just $ doFCmpLe v1 v2 -doCmpOp CmpLlt {} (BoolValue v1) (BoolValue v2) = Just $ not v1 && v2 -doCmpOp CmpLle {} (BoolValue v1) (BoolValue v2) = Just $ not (v1 && not v2) -doCmpOp _ _ _ = Nothing - --- | Compare any two primtive values for exact equality. -doCmpEq :: PrimValue -> PrimValue -> Bool -doCmpEq (FloatValue (Float32Value v1)) (FloatValue (Float32Value v2)) = v1 == v2 -doCmpEq (FloatValue (Float64Value v1)) (FloatValue (Float64Value v2)) = v1 == v2 -doCmpEq v1 v2 = v1 == v2 - --- | Unsigned less than. -doCmpUlt :: IntValue -> IntValue -> Bool -doCmpUlt v1 v2 = intToWord64 v1 < intToWord64 v2 - --- | Unsigned less than or equal. -doCmpUle :: IntValue -> IntValue -> Bool -doCmpUle v1 v2 = intToWord64 v1 <= intToWord64 v2 - --- | Signed less than. -doCmpSlt :: IntValue -> IntValue -> Bool -doCmpSlt = (<) - --- | Signed less than or equal. -doCmpSle :: IntValue -> IntValue -> Bool -doCmpSle = (<=) - --- | Floating-point less than. -doFCmpLt :: FloatValue -> FloatValue -> Bool -doFCmpLt = (<) - --- | Floating-point less than or equal. -doFCmpLe :: FloatValue -> FloatValue -> Bool -doFCmpLe = (<=) - --- | Translate an t'IntValue' to 'Word64'. This is guaranteed to fit. -intToWord64 :: IntValue -> Word64 -intToWord64 (Int8Value v) = fromIntegral (fromIntegral v :: Word8) -intToWord64 (Int16Value v) = fromIntegral (fromIntegral v :: Word16) -intToWord64 (Int32Value v) = fromIntegral (fromIntegral v :: Word32) -intToWord64 (Int64Value v) = fromIntegral (fromIntegral v :: Word64) - --- | Translate an t'IntValue' to t'Int64'. This is guaranteed to fit. -intToInt64 :: IntValue -> Int64 -intToInt64 (Int8Value v) = fromIntegral v -intToInt64 (Int16Value v) = fromIntegral v -intToInt64 (Int32Value v) = fromIntegral v -intToInt64 (Int64Value v) = fromIntegral v - --- | Careful - there is no guarantee this will fit. -intToInt :: IntValue -> Int -intToInt = fromIntegral . intToInt64 - -floatToDouble :: FloatValue -> Double -floatToDouble (Float16Value v) - | isInfinite v, v > 0 = 1 / 0 - | 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 - | isNaN v = 0 / 0 - | otherwise = fromRational $ toRational v -floatToDouble (Float64Value v) = v - -floatToFloat :: FloatValue -> Float -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 -binOpType (Sub t _) = IntType t -binOpType (Mul t _) = IntType t -binOpType (SDiv t _) = IntType t -binOpType (SDivUp t _) = IntType t -binOpType (SMod t _) = IntType t -binOpType (SQuot t _) = IntType t -binOpType (SRem t _) = IntType t -binOpType (UDiv t _) = IntType t -binOpType (UDivUp t _) = IntType t -binOpType (UMod t _) = IntType t -binOpType (SMin t) = IntType t -binOpType (UMin t) = IntType t -binOpType (FMin t) = FloatType t -binOpType (SMax t) = IntType t -binOpType (UMax t) = IntType t -binOpType (FMax t) = FloatType t -binOpType (Shl t) = IntType t -binOpType (LShr t) = IntType t -binOpType (AShr t) = IntType t -binOpType (And t) = IntType t -binOpType (Or t) = IntType t -binOpType (Xor t) = IntType t -binOpType (Pow t) = IntType t -binOpType (FPow t) = FloatType t -binOpType LogAnd = Bool -binOpType LogOr = Bool -binOpType (FAdd t) = FloatType t -binOpType (FSub t) = FloatType t -binOpType (FMul t) = FloatType t -binOpType (FDiv t) = FloatType t -binOpType (FMod t) = FloatType t - --- | The operand types of a comparison operator. -cmpOpType :: CmpOp -> PrimType -cmpOpType (CmpEq t) = t -cmpOpType (CmpSlt t) = IntType t -cmpOpType (CmpSle t) = IntType t -cmpOpType (CmpUlt t) = IntType t -cmpOpType (CmpUle t) = IntType t -cmpOpType (FCmpLt t) = FloatType t -cmpOpType (FCmpLe t) = FloatType t -cmpOpType CmpLlt = Bool -cmpOpType CmpLle = Bool - --- | The operand and result type of a unary operator. -unOpType :: UnOp -> PrimType -unOpType (SSignum t) = IntType t -unOpType (USignum t) = IntType t -unOpType Not = Bool -unOpType (Complement t) = IntType t -unOpType (Abs t) = IntType t -unOpType (FAbs t) = FloatType t -unOpType (FSignum t) = FloatType t - --- | The input and output types of a conversion operator. -convOpType :: ConvOp -> (PrimType, PrimType) -convOpType (ZExt from to) = (IntType from, IntType to) -convOpType (SExt from to) = (IntType from, IntType to) -convOpType (FPConv from to) = (FloatType from, FloatType to) -convOpType (FPToUI from to) = (FloatType from, IntType to) -convOpType (FPToSI from to) = (FloatType from, IntType to) -convOpType (UIToFP from to) = (IntType from, FloatType to) -convOpType (SIToFP from to) = (IntType from, FloatType to) -convOpType (IToB from) = (IntType from, Bool) -convOpType (BToI to) = (Bool, IntType to) -convOpType (FToB from) = (FloatType from, Bool) -convOpType (BToF to) = (Bool, FloatType 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 - -wordToFloat :: Word32 -> Float -wordToFloat = G.runGet G.getFloatle . P.runPut . P.putWord32le - -doubleToWord :: Double -> Word64 -doubleToWord = G.runGet G.getWord64le . P.runPut . P.putDoublele - -wordToDouble :: Word64 -> Double -wordToDouble = G.runGet G.getDoublele . P.runPut . P.putWord64le - --- | A mapping from names of primitive functions to their parameter --- types, their result type, and a function for evaluating them. -primFuns :: - M.Map - String - ( [PrimType], - PrimType, - [PrimValue] -> Maybe PrimValue - ) -primFuns = - M.fromList - [ f16 "sqrt16" sqrt, - f32 "sqrt32" sqrt, - f64 "sqrt64" sqrt, - -- - f16 "cbrt16" $ convFloat . cbrtf . convFloat, - f32 "cbrt32" cbrtf, - f64 "cbrt64" cbrt, - -- - 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, - -- - -- - f16 "erf16" $ convFloat . erff . convFloat, - f32 "erf32" erff, - f64 "erf64" erf, - -- - f16 "erfc16" $ convFloat . erfcf . convFloat, - f32 "erfc32" erfcf, - f64 "erfc64" erfc, - -- - i8 "clz8" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, - i16 "clz16" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, - i32 "clz32" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, - i64 "clz64" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, - i8 "ctz8" $ IntValue . Int32Value . fromIntegral . countTrailingZeros, - i16 "ctz16" $ IntValue . Int32Value . fromIntegral . countTrailingZeros, - i32 "ctz32" $ IntValue . Int32Value . fromIntegral . countTrailingZeros, - i64 "ctz64" $ IntValue . Int32Value . fromIntegral . countTrailingZeros, - i8 "popc8" $ IntValue . Int32Value . fromIntegral . popCount, - i16 "popc16" $ IntValue . Int32Value . fromIntegral . popCount, - i32 "popc32" $ IntValue . Int32Value . fromIntegral . popCount, - i64 "popc64" $ IntValue . Int32Value . fromIntegral . popCount, - ( "mad_hi8", - ( [IntType Int8, IntType Int8, IntType Int8], - IntType Int8, - \case - [IntValue (Int8Value a), IntValue (Int8Value b), IntValue (Int8Value c)] -> - Just $ IntValue . Int8Value $ mad_hi8 (Int8Value a) (Int8Value b) c - _ -> Nothing - ) - ), - ( "mad_hi16", - ( [IntType Int16, IntType Int16, IntType Int16], - IntType Int16, - \case - [IntValue (Int16Value a), IntValue (Int16Value b), IntValue (Int16Value c)] -> - Just $ IntValue . Int16Value $ mad_hi16 (Int16Value a) (Int16Value b) c - _ -> Nothing - ) - ), - ( "mad_hi32", - ( [IntType Int32, IntType Int32, IntType Int32], - IntType Int32, - \case - [IntValue (Int32Value a), IntValue (Int32Value b), IntValue (Int32Value c)] -> - Just $ IntValue . Int32Value $ mad_hi32 (Int32Value a) (Int32Value b) c - _ -> Nothing - ) - ), - ( "mad_hi64", - ( [IntType Int64, IntType Int64, IntType Int64], - IntType Int64, - \case - [IntValue (Int64Value a), IntValue (Int64Value b), IntValue (Int64Value c)] -> - Just $ IntValue . Int64Value $ mad_hi64 (Int64Value a) (Int64Value b) c - _ -> Nothing - ) - ), - ( "mul_hi8", - ( [IntType Int8, IntType Int8], - IntType Int8, - \case - [IntValue (Int8Value a), IntValue (Int8Value b)] -> - Just $ IntValue . Int8Value $ mul_hi8 (Int8Value a) (Int8Value b) - _ -> Nothing - ) - ), - ( "mul_hi16", - ( [IntType Int16, IntType Int16], - IntType Int16, - \case - [IntValue (Int16Value a), IntValue (Int16Value b)] -> - Just $ IntValue . Int16Value $ mul_hi16 (Int16Value a) (Int16Value b) - _ -> Nothing - ) - ), - ( "mul_hi32", - ( [IntType Int32, IntType Int32], - IntType Int32, - \case - [IntValue (Int32Value a), IntValue (Int32Value b)] -> - Just $ IntValue . Int32Value $ mul_hi32 (Int32Value a) (Int32Value b) - _ -> Nothing - ) - ), - ( "mul_hi64", - ( [IntType Int64, IntType Int64], - IntType Int64, - \case - [IntValue (Int64Value a), IntValue (Int64Value b)] -> - Just $ IntValue . Int64Value $ mul_hi64 (Int64Value a) (Int64Value b) - _ -> 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, - \case - [FloatValue (Float32Value x), FloatValue (Float32Value y)] -> - Just $ FloatValue $ Float32Value $ atan2 x y - _ -> Nothing - ) - ), - ( "atan2_64", - ( [FloatType Float64, FloatType Float64], - FloatType Float64, - \case - [FloatValue (Float64Value x), FloatValue (Float64Value y)] -> - Just $ FloatValue $ Float64Value $ atan2 x y - _ -> 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, - \case - [FloatValue (Float32Value x), FloatValue (Float32Value y)] -> - Just $ FloatValue $ Float32Value $ hypotf x y - _ -> Nothing - ) - ), - ( "hypot64", - ( [FloatType Float64, FloatType Float64], - FloatType Float64, - \case - [FloatValue (Float64Value x), FloatValue (Float64Value y)] -> - Just $ FloatValue $ Float64Value $ hypot x y - _ -> Nothing - ) - ), - ( "isinf16", - ( [FloatType Float16], - Bool, - \case - [FloatValue (Float16Value x)] -> Just $ BoolValue $ isInfinite x - _ -> Nothing - ) - ), - ( "isinf32", - ( [FloatType Float32], - Bool, - \case - [FloatValue (Float32Value x)] -> Just $ BoolValue $ isInfinite x - _ -> Nothing - ) - ), - ( "isinf64", - ( [FloatType Float64], - Bool, - \case - [FloatValue (Float64Value x)] -> Just $ BoolValue $ isInfinite x - _ -> Nothing - ) - ), - ( "isnan16", - ( [FloatType Float16], - Bool, - \case - [FloatValue (Float16Value x)] -> Just $ BoolValue $ isNaN x - _ -> Nothing - ) - ), - ( "isnan32", - ( [FloatType Float32], - Bool, - \case - [FloatValue (Float32Value x)] -> Just $ BoolValue $ isNaN x - _ -> Nothing - ) - ), - ( "isnan64", - ( [FloatType Float64], - Bool, - \case - [FloatValue (Float64Value x)] -> Just $ BoolValue $ isNaN x - _ -> Nothing - ) - ), - ( "to_bits16", - ( [FloatType Float16], - IntType Int16, - \case - [FloatValue (Float16Value x)] -> - Just $ IntValue $ Int16Value $ fromIntegral $ halfToWord x - _ -> Nothing - ) - ), - ( "to_bits32", - ( [FloatType Float32], - IntType Int32, - \case - [FloatValue (Float32Value x)] -> - Just $ IntValue $ Int32Value $ fromIntegral $ floatToWord x - _ -> Nothing - ) - ), - ( "to_bits64", - ( [FloatType Float64], - IntType Int64, - \case - [FloatValue (Float64Value x)] -> - Just $ IntValue $ Int64Value $ fromIntegral $ doubleToWord x - _ -> Nothing - ) - ), - ( "from_bits16", - ( [IntType Int16], - FloatType Float16, - \case - [IntValue (Int16Value x)] -> - Just $ FloatValue $ Float16Value $ wordToHalf $ fromIntegral x - _ -> Nothing - ) - ), - ( "from_bits32", - ( [IntType Int32], - FloatType Float32, - \case - [IntValue (Int32Value x)] -> - Just $ FloatValue $ Float32Value $ wordToFloat $ fromIntegral x - _ -> Nothing - ) - ), - ( "from_bits64", - ( [IntType Int64], - FloatType Float64, - \case - [IntValue (Int64Value x)] -> - Just $ FloatValue $ Float64Value $ wordToDouble $ fromIntegral x - _ -> Nothing - ) - ), - f16_3 "lerp16" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), - f32_3 "lerp32" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), - f64_3 "lerp64" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), - 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) - ] - where - i8 s f = (s, ([IntType Int8], IntType Int32, i8PrimFun f)) - 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], - FloatType Float32, - f32PrimFun3 f - ) - ) - f64_3 s f = - ( s, - ( [FloatType Float64, FloatType Float64, FloatType Float64], - FloatType Float64, - f64PrimFun3 f - ) - ) - - i8PrimFun f [IntValue (Int8Value x)] = - Just $ f x - i8PrimFun _ _ = Nothing - - i16PrimFun f [IntValue (Int16Value x)] = - Just $ f x - i16PrimFun _ _ = Nothing - - i32PrimFun f [IntValue (Int32Value x)] = - Just $ f x - i32PrimFun _ _ = Nothing - - i64PrimFun f [IntValue (Int64Value x)] = - 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 - - f64PrimFun f [FloatValue (Float64Value x)] = - 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), - FloatValue (Float32Value b), - FloatValue (Float32Value c) - ] = - Just $ FloatValue $ Float32Value $ f a b c - f32PrimFun3 _ _ = Nothing - - f64PrimFun3 - f - [ FloatValue (Float64Value a), - FloatValue (Float64Value b), - FloatValue (Float64Value c) - ] = - Just $ FloatValue $ Float64Value $ f a b c - f64PrimFun3 _ _ = Nothing - --- | 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 -zeroIsh _ = False - --- | 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 -oneIsh _ = False - --- | 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 -negativeIsh UnitValue = False - --- | Is the given integer value kind of zero? -zeroIshInt :: IntValue -> Bool -zeroIshInt (Int8Value k) = k == 0 -zeroIshInt (Int16Value k) = k == 0 -zeroIshInt (Int32Value k) = k == 0 -zeroIshInt (Int64Value k) = k == 0 - --- | Is the given integer value kind of one? -oneIshInt :: IntValue -> Bool -oneIshInt (Int8Value k) = k == 1 -oneIshInt (Int16Value k) = k == 1 -oneIshInt (Int32Value k) = k == 1 -oneIshInt (Int64Value k) = k == 1 - --- | Is the given integer value kind of negative? -negativeIshInt :: IntValue -> Bool -negativeIshInt (Int8Value k) = k < 0 -negativeIshInt (Int16Value k) = k < 0 -negativeIshInt (Int32Value k) = k < 0 -negativeIshInt (Int64Value k) = k < 0 - --- | The size of a value of a given primitive type in bits. -primBitSize :: PrimType -> Int -primBitSize = (* 8) . primByteSize - --- | The size of a value of a given primitive type in eight-bit bytes. -primByteSize :: Num a => PrimType -> a -primByteSize (IntType t) = intByteSize t -primByteSize (FloatType t) = floatByteSize t -primByteSize Bool = 1 -primByteSize Unit = 0 - --- | The size of a value of a given integer type in eight-bit bytes. -intByteSize :: Num a => IntType -> a -intByteSize Int8 = 1 -intByteSize Int16 = 2 -intByteSize Int32 = 4 -intByteSize Int64 = 8 - --- | The size of a value of a given floating-point type in eight-bit bytes. -floatByteSize :: Num a => FloatType -> a -floatByteSize Float16 = 2 -floatByteSize Float32 = 4 -floatByteSize Float64 = 8 - --- | True if the given binary operator is commutative. -commutativeBinOp :: BinOp -> Bool -commutativeBinOp Add {} = True -commutativeBinOp FAdd {} = True -commutativeBinOp Mul {} = True -commutativeBinOp FMul {} = True -commutativeBinOp And {} = True -commutativeBinOp Or {} = True -commutativeBinOp Xor {} = True -commutativeBinOp LogOr {} = True -commutativeBinOp LogAnd {} = True -commutativeBinOp SMax {} = True -commutativeBinOp SMin {} = True -commutativeBinOp UMax {} = True -commutativeBinOp UMin {} = True -commutativeBinOp FMax {} = True -commutativeBinOp FMin {} = True -commutativeBinOp _ = False - --- | True if the given binary operator is associative. -associativeBinOp :: BinOp -> Bool -associativeBinOp Add {} = True -associativeBinOp Mul {} = True -associativeBinOp And {} = True -associativeBinOp Or {} = True -associativeBinOp Xor {} = True -associativeBinOp LogOr {} = True -associativeBinOp LogAnd {} = True -associativeBinOp SMax {} = True -associativeBinOp SMin {} = True -associativeBinOp UMax {} = True -associativeBinOp UMin {} = True -associativeBinOp FMax {} = True -associativeBinOp FMin {} = True -associativeBinOp _ = False - --- Prettyprinting instances - -instance Pretty BinOp where - ppr (Add t OverflowWrap) = taggedI "add" t - ppr (Add t OverflowUndef) = taggedI "add_nw" t - ppr (Sub t OverflowWrap) = taggedI "sub" t - ppr (Sub t OverflowUndef) = taggedI "sub_nw" t - ppr (Mul t OverflowWrap) = taggedI "mul" t - ppr (Mul t OverflowUndef) = taggedI "mul_nw" t - ppr (FAdd t) = taggedF "fadd" t - ppr (FSub t) = taggedF "fsub" t - ppr (FMul t) = taggedF "fmul" t - ppr (UDiv t Safe) = taggedI "udiv_safe" t - ppr (UDiv t Unsafe) = taggedI "udiv" t - ppr (UDivUp t Safe) = taggedI "udiv_up_safe" t - ppr (UDivUp t Unsafe) = taggedI "udiv_up" t - ppr (UMod t Safe) = taggedI "umod_safe" t - ppr (UMod t Unsafe) = taggedI "umod" t - ppr (SDiv t Safe) = taggedI "sdiv_safe" t - ppr (SDiv t Unsafe) = taggedI "sdiv" t - ppr (SDivUp t Safe) = taggedI "sdiv_up_safe" t - ppr (SDivUp t Unsafe) = taggedI "sdiv_up" t - ppr (SMod t Safe) = taggedI "smod_safe" t - ppr (SMod t Unsafe) = taggedI "smod" t - ppr (SQuot t Safe) = taggedI "squot_safe" t - ppr (SQuot t Unsafe) = taggedI "squot" t - ppr (SRem t Safe) = taggedI "srem_safe" t - ppr (SRem t Unsafe) = taggedI "srem" t - ppr (FDiv t) = taggedF "fdiv" t - ppr (FMod t) = taggedF "fmod" t - ppr (SMin t) = taggedI "smin" t - ppr (UMin t) = taggedI "umin" t - ppr (FMin t) = taggedF "fmin" t - ppr (SMax t) = taggedI "smax" t - ppr (UMax t) = taggedI "umax" t - ppr (FMax t) = taggedF "fmax" t - ppr (Shl t) = taggedI "shl" t - ppr (LShr t) = taggedI "lshr" t - ppr (AShr t) = taggedI "ashr" t - ppr (And t) = taggedI "and" t - ppr (Or t) = taggedI "or" t - ppr (Xor t) = taggedI "xor" t - ppr (Pow t) = taggedI "pow" t - ppr (FPow t) = taggedF "fpow" t - ppr LogAnd = text "logand" - ppr LogOr = text "logor" - -instance Pretty CmpOp where - ppr (CmpEq t) = text "eq_" <> ppr t - ppr (CmpUlt t) = taggedI "ult" t - ppr (CmpUle t) = taggedI "ule" t - ppr (CmpSlt t) = taggedI "slt" t - ppr (CmpSle t) = taggedI "sle" t - ppr (FCmpLt t) = taggedF "lt" t - ppr (FCmpLe t) = taggedF "le" t - ppr CmpLlt = text "llt" - ppr CmpLle = text "lle" - -instance Pretty ConvOp where - ppr op = convOp (convOpFun op) from to - where - (from, to) = convOpType op - -instance Pretty UnOp where - ppr Not = text "not" - ppr (Abs t) = taggedI "abs" t - ppr (FAbs t) = taggedF "fabs" t - ppr (SSignum t) = taggedI "ssignum" t - ppr (USignum t) = taggedI "usignum" t - ppr (FSignum t) = taggedF "fsignum" t - ppr (Complement t) = taggedI "complement" t - --- | The human-readable name for a 'ConvOp'. This is used to expose --- the 'ConvOp' in the @intrinsics@ module of a Futhark program. -convOpFun :: ConvOp -> String -convOpFun ZExt {} = "zext" -convOpFun SExt {} = "sext" -convOpFun FPConv {} = "fpconv" -convOpFun FPToUI {} = "fptoui" -convOpFun FPToSI {} = "fptosi" -convOpFun UIToFP {} = "uitofp" -convOpFun SIToFP {} = "sitofp" -convOpFun IToB {} = "itob" -convOpFun BToI {} = "btoi" -convOpFun FToB {} = "ftob" -convOpFun BToF {} = "btof" - -taggedI :: String -> IntType -> Doc -taggedI s Int8 = text $ s ++ "8" -taggedI s Int16 = text $ s ++ "16" -taggedI s Int32 = text $ s ++ "32" -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" - -convOp :: (Pretty from, Pretty to) => String -> from -> to -> Doc -convOp s from to = text s <> text "_" <> ppr from <> text "_" <> ppr to - --- | True if signed. Only makes a difference for integer types. -prettySigned :: Bool -> PrimType -> String -prettySigned True (IntType it) = 'u' : drop 1 (pretty it) -prettySigned _ t = pretty t - -mul_hi8 :: IntValue -> IntValue -> Int8 -mul_hi8 a b = - let a' = intToWord64 a - b' = intToWord64 b - in fromIntegral (shiftR (a' * b') 8) - -mul_hi16 :: IntValue -> IntValue -> Int16 -mul_hi16 a b = - let a' = intToWord64 a - b' = intToWord64 b - in fromIntegral (shiftR (a' * b') 16) - -mul_hi32 :: IntValue -> IntValue -> Int32 -mul_hi32 a b = - let a' = intToWord64 a - b' = intToWord64 b - in fromIntegral (shiftR (a' * b') 32) - -mul_hi64 :: IntValue -> IntValue -> Int64 -mul_hi64 a b = - let a' = (toInteger . intToWord64) a - b' = (toInteger . intToWord64) b - in fromIntegral (shiftR (a' * b') 64) - -mad_hi8 :: IntValue -> IntValue -> Int8 -> Int8 -mad_hi8 a b c = mul_hi8 a b + c - -mad_hi16 :: IntValue -> IntValue -> Int16 -> Int16 -mad_hi16 a b c = mul_hi16 a b + c - -mad_hi32 :: IntValue -> IntValue -> Int32 -> Int32 -mad_hi32 a b c = mul_hi32 a b + c - -mad_hi64 :: IntValue -> IntValue -> Int64 -> Int64 -mad_hi64 a b c = mul_hi64 a b + c diff --git a/src/Futhark/IR/Primitive/Parse.hs b/src/Futhark/IR/Primitive/Parse.hs deleted file mode 100644 --- a/src/Futhark/IR/Primitive/Parse.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Parsers for primitive values and types. Mostly useful for --- "Futhark.IR.Parse", but can perhaps come in handy elsewhere too. -module Futhark.IR.Primitive.Parse - ( pPrimValue, - pPrimType, - pFloatType, - pIntType, - - -- * Building blocks - constituent, - lexeme, - keyword, - whitespace, - ) -where - -import Data.Char (isAlphaNum) -import Data.Functor -import qualified Data.Text as T -import Data.Void -import Futhark.IR.Primitive -import Futhark.Util.Pretty hiding (empty) -import Text.Megaparsec -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L - --- | Is this character a valid member of an identifier? -constituent :: Char -> Bool -constituent c = isAlphaNum c || (c `elem` ("_/'+-=!&^.<>*|" :: String)) - --- | Consume whitespace (including skipping line comments). -whitespace :: Parsec Void T.Text () -whitespace = L.space space1 (L.skipLineComment "--") empty - --- | Consume whitespace after the provided parser, if it succeeds. -lexeme :: Parsec Void T.Text a -> Parsec Void T.Text a -lexeme = try . L.lexeme whitespace - --- | @keyword k@ parses @k@, which must not be immediately followed by --- a 'constituent' character. This ensures that @iff@ is not seen as --- the @if@ keyword followed by @f@. Sometimes called the "maximum --- munch" rule. -keyword :: T.Text -> Parsec Void T.Text () -keyword s = lexeme $ chunk s *> notFollowedBy (satisfy constituent) - --- | Parse an integer value. -pIntValue :: Parsec Void T.Text IntValue -pIntValue = try $ do - x <- L.signed (pure ()) L.decimal - t <- pIntType - pure $ intValue t (x :: Integer) - --- | Parse a floating-point value. -pFloatValue :: Parsec Void T.Text FloatValue -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), - keyword "f64.nan" $> Float64Value (0 / 0), - keyword "f64.inf" $> Float64Value (1 / 0), - keyword "-f64.inf" $> Float64Value (-1 / 0) - ] - where - pNum = try $ do - x <- L.signed (pure ()) L.float - t <- pFloatType - pure $ floatValue t (x :: Double) - --- | Parse a boolean value. -pBoolValue :: Parsec Void T.Text Bool -pBoolValue = - choice - [ keyword "true" $> True, - keyword "false" $> False - ] - --- | Defined in this module for convenience. -pPrimValue :: Parsec Void T.Text PrimValue -pPrimValue = - choice - [ FloatValue <$> pFloatValue, - IntValue <$> pIntValue, - BoolValue <$> pBoolValue, - UnitValue <$ "()" - ] - "primitive value" - --- | Parse a floating-point type. -pFloatType :: Parsec Void T.Text FloatType -pFloatType = choice $ map p allFloatTypes - where - p t = keyword (prettyText t) $> t - --- | Parse an integer type. -pIntType :: Parsec Void T.Text IntType -pIntType = choice $ map p allIntTypes - where - p t = keyword (prettyText t) $> t - --- | Parse a primitive type. -pPrimType :: Parsec Void T.Text PrimType -pPrimType = - choice [p Bool, p Unit, FloatType <$> pFloatType, IntType <$> pIntType] - where - p t = keyword (prettyText t) $> t 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 @@ -5,10 +5,9 @@ {-# LANGUAGE TypeFamilies #-} -- | This module provides various simple ways to query and manipulate --- fundamental Futhark terms, such as types and values. The intent is to --- keep "Futhark.IRrsentation.AST.Syntax" simple, and put whatever --- embellishments we need here. This is an internal, desugared --- representation. +-- fundamental Futhark terms, such as types and values. The intent is +-- to keep "Futhark.IR.Syntax" simple, and put whatever embellishments +-- we need here. This is an internal, desugared representation. module Futhark.IR.Prop ( module Futhark.IR.Prop.Reshape, module Futhark.IR.Prop.Rearrange, @@ -29,7 +28,6 @@ subExpVars, subExpVar, commutativeLambda, - entryPointSize, defAux, stmCerts, certify, @@ -171,15 +169,6 @@ && n2 == length (bodyResult body) && all okComponent (zip3 xps yps $ bodyResult body) --- | How many value parameters are accepted by this entry point? This --- is used to determine which of the function parameters correspond to --- the parameters of the original function (they must all come at the --- end). -entryPointSize :: EntryPointType -> Int -entryPointSize (TypeOpaque _ _ x) = x -entryPointSize (TypeUnsigned _) = 1 -entryPointSize (TypeDirect _) = 1 - -- | A 'StmAux' with empty 'Certs'. defAux :: dec -> StmAux dec defAux = StmAux mempty mempty @@ -240,7 +229,9 @@ expExtTypesFromPat :: Typed dec => Pat dec -> [ExtType] expExtTypesFromPat pat = existentialiseExtTypes (patNames pat) $ - staticShapes $ map patElemType $ patElems pat + staticShapes $ + map patElemType $ + patElems pat -- | Keep only those attributes that are relevant for 'Assert' -- expressions. @@ -259,7 +250,9 @@ guard $ cs == mempty Let (Pat [pe]) _ (BasicOp (BinOp op (Var x) (Var y))) <- find (([res] ==) . patNames . stmPat) $ - stmsToList $ bodyStms $ lambdaBody lam + stmsToList $ + bodyStms $ + lambdaBody lam i <- Var res `elemIndex` map resSubExp (bodyResult (lambdaBody lam)) xp <- maybeNth i $ lambdaParams lam yp <- maybeNth (n + i) $ lambdaParams lam diff --git a/src/Futhark/IR/Prop/Constants.hs b/src/Futhark/IR/Prop/Constants.hs --- a/src/Futhark/IR/Prop/Constants.hs +++ b/src/Futhark/IR/Prop/Constants.hs @@ -7,7 +7,8 @@ ) where -import Futhark.IR.Syntax.Core +import Futhark.IR.Syntax.Core (SubExp (..)) +import Language.Futhark.Primitive -- | If a Haskell type is an instance of 'IsValue', it means that a -- value of that type can be converted to a Futhark 'PrimValue'. 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 @@ -299,7 +299,8 @@ FreeIn (Stm rep) where freeIn' (Let pat (StmAux cs attrs dec) e) = - freeIn' cs <> freeIn' attrs + freeIn' cs + <> freeIn' attrs <> precomputed dec (freeIn' dec <> freeIn' e <> freeIn' pat) instance FreeIn (Stm rep) => FreeIn (Stms rep) where 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 @@ -88,7 +88,8 @@ where notFound = error $ - "Scope.lookupInfo: Name " ++ pretty name + "Scope.lookupInfo: Name " + ++ pretty name ++ " not found in type environment." -- | Return the type environment contained in the applicative 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 @@ -376,9 +376,12 @@ TypeBase shape u -> Bool subtypeOf (Array t1 shape1 u1) (Array t2 shape2 u2) = - u2 <= u1 - && t1 == t2 - && shape1 `subShapeOf` shape2 + u2 + <= u1 + && t1 + == t2 + && shape1 + `subShapeOf` shape2 subtypeOf t1 t2 = t1 == t2 -- | @xs \`subtypesOf\` ys@ is true if @xs@ is the same size as @ys@, @@ -443,10 +446,7 @@ -- | 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) - where - ext (Ext x) = Just x - ext (Free _) = Nothing +shapeContext = S.fromList . concatMap (mapMaybe isExt . shapeDims . arrayShape) -- | If all dimensions of the given 'ExtShape' are statically known, -- change to the corresponding t'Shape'. diff --git a/src/Futhark/IR/Rep.hs b/src/Futhark/IR/Rep.hs --- a/src/Futhark/IR/Rep.hs +++ b/src/Futhark/IR/Rep.hs @@ -12,7 +12,7 @@ import qualified Data.Kind import Futhark.IR.Prop.Types import Futhark.IR.RetType -import Futhark.IR.Syntax.Core +import Futhark.IR.Syntax.Core (DeclExtType, DeclType, ExtType, Type) -- | A collection of type families giving various common types for a -- representation, along with constraints specifying that the types 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 @@ -64,7 +64,8 @@ if length args == length params && and ( zipWith subtypeOf argtypes $ - expectedTypes (map paramName params) params $ map fst args + expectedTypes (map paramName params) params $ + map fst args ) then Just $ map correctExtDims extret else Nothing 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 @@ -40,6 +40,8 @@ scremaLambda, ppScrema, ppHist, + ppStream, + ppScatter, groupScatterResults, groupScatterResults', splitScatterResults, @@ -405,15 +407,18 @@ SOAC frep -> m (SOAC trep) mapSOACM tv (JVP lam args vec) = - JVP <$> mapOnSOACLambda tv lam + JVP + <$> mapOnSOACLambda tv lam <*> mapM (mapOnSOACSubExp tv) args <*> mapM (mapOnSOACSubExp tv) vec mapSOACM tv (VJP lam args vec) = - VJP <$> mapOnSOACLambda tv lam + VJP + <$> mapOnSOACLambda tv lam <*> mapM (mapOnSOACSubExp tv) args <*> mapM (mapOnSOACSubExp tv) vec mapSOACM tv (Stream size arrs form accs lam) = - Stream <$> mapOnSOACSubExp tv size + Stream + <$> mapOnSOACSubExp tv size <*> mapM (mapOnSOACVName tv) arrs <*> mapOnStreamForm form <*> mapM (mapOnSOACSubExp tv) accs @@ -430,7 +435,8 @@ <*> mapOnSOACLambda tv lam <*> mapM ( \(aw, an, a) -> - (,,) <$> mapM (mapOnSOACSubExp tv) aw + (,,) + <$> mapM (mapOnSOACSubExp tv) aw <*> pure an <*> mapOnSOACVName tv a ) @@ -441,7 +447,8 @@ <*> mapM (mapOnSOACVName tv) arrs <*> mapM ( \(HistOp shape rf op_arrs nes op) -> - HistOp <$> mapM (mapOnSOACSubExp tv) shape + HistOp + <$> mapM (mapOnSOACSubExp tv) shape <*> mapOnSOACSubExp tv rf <*> mapM (mapOnSOACVName tv) op_arrs <*> mapM (mapOnSOACSubExp tv) nes @@ -450,19 +457,22 @@ ops <*> mapOnSOACLambda tv bucket_fun mapSOACM tv (Screma w arrs (ScremaForm scans reds map_lam)) = - Screma <$> mapOnSOACSubExp tv w + Screma + <$> mapOnSOACSubExp tv w <*> mapM (mapOnSOACVName tv) arrs <*> ( ScremaForm <$> forM scans ( \(Scan red_lam red_nes) -> - Scan <$> mapOnSOACLambda tv red_lam + Scan + <$> mapOnSOACLambda tv red_lam <*> mapM (mapOnSOACSubExp tv) red_nes ) <*> forM reds ( \(Reduce comm red_lam red_nes) -> - Reduce comm <$> mapOnSOACLambda tv red_lam + Reduce comm + <$> mapOnSOACLambda tv red_lam <*> mapM (mapOnSOACSubExp tv) red_nes ) <*> mapOnSOACLambda tv map_lam @@ -474,6 +484,24 @@ where mapper = identitySOACMapper {mapOnSOACLambda = traverseLambdaStms f} +instance ASTRep rep => FreeIn (Scan rep) where + freeIn' (Scan lam ne) = freeIn' lam <> freeIn' ne + +instance ASTRep rep => FreeIn (Reduce rep) where + freeIn' (Reduce _ lam ne) = freeIn' lam <> freeIn' ne + +instance ASTRep rep => FreeIn (ScremaForm rep) where + freeIn' (ScremaForm scans reds lam) = + freeIn' scans <> freeIn' reds <> freeIn' lam + +instance ASTRep rep => FreeIn (StreamForm rep) where + freeIn' Sequential = mempty + freeIn' (Parallel _ _ lam) = freeIn' lam + +instance ASTRep rep => FreeIn (HistOp rep) where + freeIn' (HistOp w rf dests nes lam) = + freeIn' w <> freeIn' rf <> freeIn' dests <> freeIn' nes <> freeIn' lam + instance ASTRep rep => FreeIn (SOAC rep) where freeIn' = flip execState mempty . mapSOACM free where @@ -611,7 +639,7 @@ instance ASTRep rep => IsOp (SOAC rep) where safeOp _ = False - cheapOp _ = True + cheapOp _ = False substNamesInType :: M.Map VName SubExp -> Type -> Type substNamesInType _ t@Prim {} = t @@ -672,8 +700,26 @@ -- | Type-check a SOAC. typeCheckSOAC :: TC.Checkable rep => SOAC (Aliases rep) -> TC.TypeM rep () -typeCheckSOAC JVP {} = pure () -typeCheckSOAC VJP {} = pure () +typeCheckSOAC (VJP lam args vec) = do + args' <- mapM TC.checkArg args + TC.checkLambda lam $ map TC.noArgAliases args' + vec_ts <- mapM TC.checkSubExp vec + unless (vec_ts == lambdaReturnType lam) $ + TC.bad . TC.TypeError . pretty $ + "Return type" + PP.indent 2 (ppr (lambdaReturnType lam)) + "does not match type of seed vector" + PP.indent 2 (ppr vec_ts) +typeCheckSOAC (JVP lam args vec) = do + args' <- mapM TC.checkArg args + TC.checkLambda lam $ map TC.noArgAliases args' + vec_ts <- mapM TC.checkSubExp vec + unless (vec_ts == map TC.argType args') $ + TC.bad . TC.TypeError . pretty $ + "Parameter type" + PP.indent 2 (ppr $ map TC.argType args') + "does not match type of seed vector" + PP.indent 2 (ppr vec_ts) typeCheckSOAC (Stream size arrexps form accexps lam) = do TC.require [Prim int64] size accargs <- mapM TC.checkArg accexps @@ -686,7 +732,8 @@ let acc_len = length accexps let lamrtp = take acc_len $ lambdaReturnType lam unless (map TC.argType accargs == lamrtp) $ - TC.bad $ TC.TypeError "Stream with inconsistent accumulator type in lambda." + TC.bad $ + TC.TypeError "Stream with inconsistent accumulator type in lambda." -- check reduce's lambda, if any _ <- case form of Parallel _ _ lam0 -> do @@ -696,7 +743,8 @@ unless (acct == outerRetType) $ TC.bad $ TC.TypeError $ - "Initial value is of type " ++ prettyTuple acct + "Initial value is of type " + ++ prettyTuple acct ++ ", but stream's reduce lambda returns type " ++ prettyTuple outerRetType ++ "." @@ -739,12 +787,14 @@ -- 1. unless (length rts == sum as_ns + sum (zipWith (*) as_ns $ map length as_ws)) $ - TC.bad $ TC.TypeError "Scatter: number of index types, value types and array outputs do not match." + TC.bad $ + TC.TypeError "Scatter: number of index types, value types and array outputs do not match." -- 2. forM_ rtsI $ \rtI -> unless (Prim int64 == rtI) $ - TC.bad $ TC.TypeError "Scatter: Index return type must be i64." + TC.bad $ + TC.TypeError "Scatter: Index return type must be i64." forM_ (zip (chunks as_ns rtsV) as) $ \(rtVs, (aw, _, a)) -> do -- All lengths must have type i64. @@ -840,10 +890,11 @@ ( take (length scan_nes' + length red_nes') map_lam_ts == map TC.argType (scan_nes' ++ red_nes') ) - $ TC.bad $ - TC.TypeError $ - "Map function return type " ++ prettyTuple map_lam_ts - ++ " wrong for given scan and reduction functions." + $ TC.bad + $ TC.TypeError + $ "Map function return type " + ++ prettyTuple map_lam_ts + ++ " wrong for given scan and reduction functions." instance OpMetrics (Op rep) => OpMetrics (SOAC rep) where opMetrics (VJP lam _ _) = @@ -880,36 +931,9 @@ PP.braces (commasep $ map ppr vec) ) ppr (Stream size arrs form acc lam) = - case form of - Parallel o comm lam0 -> - let ord_str = if o == Disorder then "Per" else "" - comm_str = case comm of - Commutative -> "Comm" - Noncommutative -> "" - in text ("streamPar" ++ ord_str ++ comm_str) - <> parens - ( ppr size <> comma - ppTuple' arrs <> comma - ppr lam0 <> comma - ppTuple' acc <> comma - ppr lam - ) - Sequential -> - text "streamSeq" - <> parens - ( ppr size <> comma - ppTuple' arrs <> comma - ppTuple' acc <> comma - ppr lam - ) + ppStream size arrs form acc lam ppr (Scatter w arrs lam dests) = - "scatter" - <> parens - ( ppr w <> comma - ppTuple' arrs <> comma - ppr lam <> comma - commasep (map ppr dests) - ) + ppScatter w arrs lam dests ppr (Hist w arrs ops bucket_fun) = ppHist w arrs ops bucket_fun ppr (Screma w arrs (ScremaForm scans reds map_lam)) @@ -952,6 +976,45 @@ ppr map_lam ) +-- | Prettyprint the given Stream. +ppStream :: + (PrettyRep rep, Pretty inp) => SubExp -> [inp] -> StreamForm rep -> [SubExp] -> Lambda rep -> Doc +ppStream size arrs form acc lam = + case form of + Parallel o comm lam0 -> + let ord_str = if o == Disorder then "Per" else "" + comm_str = case comm of + Commutative -> "Comm" + Noncommutative -> "" + in text ("streamPar" ++ ord_str ++ comm_str) + <> parens + ( ppr size <> comma + ppTuple' arrs <> comma + ppr lam0 <> comma + ppTuple' acc <> comma + ppr lam + ) + Sequential -> + text "streamSeq" + <> parens + ( ppr size <> comma + ppTuple' arrs <> comma + ppTuple' acc <> comma + ppr lam + ) + +-- | Prettyprint the given Scatter. +ppScatter :: + (PrettyRep rep, Pretty inp) => SubExp -> [inp] -> Lambda rep -> [(Shape, Int, VName)] -> Doc +ppScatter w arrs lam dests = + "scatter" + <> parens + ( ppr w <> comma + ppTuple' arrs <> comma + ppr lam <> comma + commasep (map ppr dests) + ) + instance PrettyRep rep => Pretty (Scan rep) where ppr (Scan scan_lam scan_nes) = ppr scan_lam <> comma PP.braces (commasep $ map ppr scan_nes) @@ -983,6 +1046,8 @@ ) where ppOp (HistOp dest_w rf dests nes op) = - ppr dest_w <> comma <+> ppr rf <> comma <+> PP.braces (commasep $ map ppr dests) <> comma + ppr dest_w <> comma + <+> ppr rf <> comma + <+> PP.braces (commasep $ map ppr dests) <> comma ppTuple' nes <> comma ppr op diff --git a/src/Futhark/IR/SOACS/Simplify.hs b/src/Futhark/IR/SOACS/Simplify.hs --- a/src/Futhark/IR/SOACS/Simplify.hs +++ b/src/Futhark/IR/SOACS/Simplify.hs @@ -147,7 +147,8 @@ (map_lam', map_lam_hoisted) <- Engine.enterLoop $ Engine.simplifyLambda map_lam (,) - <$> ( Screma <$> Engine.simplify w + <$> ( Screma + <$> Engine.simplify w <*> Engine.simplify arrs <*> pure (ScremaForm scans' reds' map_lam') ) @@ -251,7 +252,8 @@ onStm (Let se_pat se_aux (BasicOp (SubExp se))) = do let (invariant, variant) = partition (`ST.elem` vtable) $ - unCerts $ stmAuxCerts se_aux + unCerts $ + stmAuxCerts se_aux se_aux' = se_aux {stmAuxCerts = Certs variant} modify (Certs invariant <>) pure $ Let se_pat se_aux' $ BasicOp $ SubExp se @@ -308,7 +310,10 @@ } mapM_ (uncurry letBind) invariant auxing aux $ - letBindNames (map patElemName pat') $ Op $ soacOp $ Screma w arrs (mapSOAC fun') + letBindNames (map patElemName pat') $ + Op $ + soacOp $ + Screma w arrs (mapSOAC fun') liftIdentityMapping _ _ _ _ = Skip liftIdentityStreaming :: BottomUpRuleOp (Wise SOACS) @@ -328,7 +333,8 @@ auxing aux $ letBind (Pat $ fold_pes ++ variant_map_pes) $ - Op $ Stream w arrs form nes lam' + Op $ + Stream w arrs form nes lam' where num_folds = length nes (fold_pes, map_pes) = splitAt num_folds pes @@ -391,7 +397,7 @@ isReplicateAndNotConsumed p v | Just (BasicOp (Replicate (Shape (_ : ds)) e), v_cs) <- ST.lookupExp v vtable, - not $ paramName p `nameIn` consumedByLambda fun = + paramName p `notNameIn` consumedByLambda fun = Right ( [paramName p], v_cs, @@ -437,7 +443,10 @@ in if map_pes /= map_pes' then Simplify . auxing aux $ - letBind (Pat $ nonmap_pes <> map_pes') $ Op $ Screma w arrs $ ScremaForm scans reds lam' + letBind (Pat $ nonmap_pes <> map_pes') $ + Op $ + Screma w arrs $ + ScremaForm scans reds lam' else Skip where num_nonmap_res = scanResults scans + redResults reds @@ -546,7 +555,7 @@ (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 + not $ all (== True) (take (length nes) alive_mask) = Simplify $ do let fixDeadToNeutral lives ne = if lives then Nothing else Just ne dead_fix = zipWith fixDeadToNeutral alive_mask nes (used_red_pes, _, used_nes) = @@ -558,7 +567,9 @@ auxing aux $ letBind (Pat $ used_red_pes ++ map_pes) $ - Op $ Screma w arrs $ redomapSOAC [Reduce comm redlam' used_nes] maplam' + Op $ + Screma w arrs $ + redomapSOAC [Reduce comm redlam' used_nes] maplam' removeDeadReduction _ _ _ _ = Skip -- | If we are writing to an array that is never used, get rid of it. @@ -577,7 +588,9 @@ in if pat /= Pat pat' then Simplify . auxing aux $ - letBind (Pat pat') $ Op $ Scatter w arrs fun' dests' + letBind (Pat pat') $ + Op $ + Scatter w arrs fun' dests' else Skip removeDeadWrite _ _ _ _ = Skip @@ -602,7 +615,8 @@ lambdaReturnType = mix its <> mix vts } certifying (mconcat css) . letBind pat . Op $ - Scatter w' (concat xivs) fun' $ map (incWrites r) dests + Scatter w' (concat xivs) fun' $ + map (incWrites r) dests where sizeOf :: VName -> Maybe SubExp sizeOf x = arraySize 0 . typeOf <$> ST.lookup x vtable @@ -647,10 +661,15 @@ bindMapParam p a = do a_t <- lookupType a letBindNames [paramName p] $ - BasicOp $ Index a $ fullSlice a_t [DimFix $ constant (0 :: Int64)] + BasicOp $ + Index a $ + fullSlice a_t [DimFix $ constant (0 :: Int64)] bindArrayResult pe (SubExpRes cs se) = certifying cs . letBindNames [patElemName pe] $ - BasicOp $ ArrayLit [se] $ rowType $ patElemType pe + BasicOp $ + ArrayLit [se] $ + rowType $ + patElemType pe bindResult pe (SubExpRes cs se) = certifying cs $ letBindNames [patElemName pe] $ BasicOp $ SubExp se @@ -671,7 +690,9 @@ partitionChunkedFoldParameters (length nes) (lambdaParams fold_lam) letBindNames [paramName chunk_param] $ - BasicOp $ SubExp $ intConst Int64 1 + BasicOp $ + SubExp $ + intConst Int64 1 forM_ (zip acc_params nes) $ \(p, ne) -> letBindNames [paramName p] $ BasicOp $ SubExp ne @@ -815,7 +836,8 @@ Just (p, _) <- find isIota (zip (lambdaParams map_lam) arrs), indexings <- mapMaybe (indexesWith (paramName p)) . S.toList $ - arrayOps $ lambdaBody map_lam, + arrayOps $ + lambdaBody map_lam, not $ null indexings = Simplify $ do -- For each indexing with iota, add the corresponding array to -- the Screma, and construct a new lambda parameter. @@ -897,7 +919,9 @@ } auxing aux $ - letBind screma_pat $ Op $ Screma w (arrs <> more_arrs) (ScremaForm scan reduce map_lam') + letBind screma_pat $ + Op $ + Screma w (arrs <> more_arrs) (ScremaForm scan reduce map_lam') where -- It is not safe to move the transform if the root array is being -- consumed by the Screma. This is a bit too conservative - it's @@ -936,7 +960,7 @@ mapOverArr (pat, op) | Just (_, arr) <- find ((== arrayOpArr op) . fst) (zip map_param_names arrs), - not $ arr `nameIn` consumed = do + arr `notNameIn` consumed = do arr_t <- lookupType arr let whole_dim = DimSlice (intConst Int64 0) (arraySize 0 arr_t) (intConst Int64 1) arr_transformed <- certifying (arrayOpCerts op) $ 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 @@ -149,7 +149,8 @@ histType :: HistOp rep -> [Type] histType op = map (`arrayOfShape` (histShape op <> histOpShape op)) $ - lambdaReturnType $ histOp op + lambdaReturnType $ + histOp op -- | Split reduction results returned by a 'KernelBody' into those -- that correspond to indexes for the 'HistOp's, and those that @@ -378,7 +379,8 @@ unless (length ts == length kres) $ TC.bad $ TC.TypeError $ - "Kernel return type is " ++ prettyTuple ts + "Kernel return type is " + ++ prettyTuple ts ++ ", but body returns " ++ show (length kres) ++ " values." @@ -419,7 +421,9 @@ TC.require [Prim int64] per_thread_elems vt <- lookupType v unless (vt == t `arrayOfRow` arraySize 0 vt) $ - TC.bad $ TC.TypeError $ "Invalid type for ConcatReturns " ++ pretty v + TC.bad $ + TC.TypeError $ + "Invalid type for ConcatReturns " ++ pretty v checkKernelResult (TileReturns cs dims v) t = do TC.checkCerts cs forM_ dims $ \(dim, tile) -> do @@ -427,7 +431,9 @@ 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 + TC.bad $ + TC.TypeError $ + "Invalid type for TileReturns " ++ pretty v checkKernelResult (RegTileReturns cs dims_n_tiles arr) t = do TC.checkCerts cs mapM_ (TC.require [Prim int64]) dims @@ -452,7 +458,8 @@ instance PrettyRep rep => Pretty (KernelBody rep) where ppr (KernelBody _ stms res) = PP.stack (map ppr (stmsToList stms)) - text "return" <+> PP.braces (PP.commasep $ map ppr res) + text "return" + <+> PP.braces (PP.commasep $ map ppr res) certAnnots :: Certs -> [PP.Doc] certAnnots cs @@ -469,8 +476,11 @@ ppr (WriteReturns cs shape arr res) = PP.spread $ certAnnots cs - ++ [ ppr arr <+> PP.colon <+> ppr shape - "with" <+> PP.apply (map ppRes res) + ++ [ ppr arr + <+> PP.colon + <+> ppr shape + "with" + <+> PP.apply (map ppRes res) ] where ppRes (slice, e) = ppr slice <+> text "=" <+> ppr e @@ -478,13 +488,15 @@ PP.spread $ certAnnots cs ++ [ "concat" - <> parens (commasep [ppr w, ppr per_thread_elems]) <+> ppr v + <> 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 + <> 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] @@ -760,7 +772,8 @@ let nes_t = map TC.argType nes' unless (lambdaReturnType lam == nes_t) $ - TC.bad $ TC.TypeError "wrong type for operator or neutral elements." + TC.bad $ + TC.TypeError "wrong type for operator or neutral elements." pure $ map (`arrayOfShape` shape) nes_t @@ -850,7 +863,8 @@ <*> mapOnSegOpBody tv body where onHistOp (HistOp w rf arrs nes shape op) = - HistOp <$> mapM (mapOnSegOpSubExp tv) w + HistOp + <$> mapM (mapOnSegOpSubExp tv) w <*> mapOnSegOpSubExp tv rf <*> mapM (mapOnSegOpVName tv) arrs <*> mapM (mapOnSegOpSubExp tv) nes @@ -914,7 +928,8 @@ where freeIn' e = fvBind (namesFromList $ M.keys $ scopeOfSegSpace (segSpace e)) $ - flip execState mempty $ mapSegOpM free e + flip execState mempty $ + mapSegOpM free e where walk f x = modify (<> f x) >> pure x free = @@ -991,7 +1006,8 @@ <+> PP.nestedBlock "{" "}" (ppr body) where ppOp (HistOp w rf dests nes shape op) = - ppr w <> PP.comma <+> ppr rf <> PP.comma + ppr w <> PP.comma + <+> ppr rf <> PP.comma PP.braces (PP.commasep $ map ppr dests) <> PP.comma PP.braces (PP.commasep $ map ppr nes) <> PP.comma ppr shape <> PP.comma @@ -1124,7 +1140,8 @@ simplify (Returns manifest cs what) = Returns manifest <$> Engine.simplify cs <*> Engine.simplify what simplify (WriteReturns cs ws a res) = - WriteReturns <$> Engine.simplify cs + WriteReturns + <$> Engine.simplify cs <*> Engine.simplify ws <*> Engine.simplify a <*> Engine.simplify res @@ -1188,7 +1205,8 @@ . Engine.localVtable (<> scope_vtable) . Engine.localVtable (\vtable -> vtable {ST.simplifyMemory = True}) . Engine.enterLoop - $ Engine.blockIf blocker stms $ do + $ Engine.blockIf blocker stms + $ do res' <- Engine.localVtable (ST.hideCertified $ namesFromList $ M.keys $ scopeOf stms) $ mapM Engine.simplify res @@ -1351,7 +1369,10 @@ kbody <- mkKernelBodyM kstms kres' addStm $ - Let (Pat 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 @@ -1361,7 +1382,8 @@ rm == ResultMaySimplify, isInvariant se = do letBindNames [patElemName pe] $ - BasicOp $ Replicate (Shape $ segSpaceDims space) se + BasicOp $ + Replicate (Shape $ segSpaceDims space) se pure False checkForInvarianceResult _ = pure True @@ -1403,7 +1425,8 @@ lam = Lambda { lambdaParams = - op1_xparams ++ op2_xparams + op1_xparams + ++ op2_xparams ++ op1_yparams ++ op2_yparams, lambdaReturnType = lambdaReturnType lam1 ++ lambdaReturnType lam2, @@ -1502,9 +1525,12 @@ $ segSpaceDims space index kpe' = letBindNames [patElemName kpe'] . BasicOp . Index arr $ - Slice $ outer_slice <> remaining_slice - if patElemName kpe `UT.isConsumed` used - || arr `nameIn` consumed_in_segop + Slice $ + outer_slice <> remaining_slice + if patElemName kpe + `UT.isConsumed` used + || arr + `nameIn` consumed_in_segop then do precopy <- newVName $ baseString (patElemName kpe) <> "_precopy" index kpe {patElemName = precopy} diff --git a/src/Futhark/IR/Syntax.hs b/src/Futhark/IR/Syntax.hs --- a/src/Futhark/IR/Syntax.hs +++ b/src/Futhark/IR/Syntax.hs @@ -32,7 +32,7 @@ -- curly braces. -- -- The system of primitive types is interesting in itself. See --- "Futhark.IR.Primitive". +-- "Language.Futhark.Primitive". -- -- == Overall AST design -- @@ -147,9 +147,9 @@ FParam, LParam, FunDef (..), - EntryPoint, EntryParam (..), - EntryPointType (..), + EntryResult (..), + EntryPoint, Prog (..), -- * Utils @@ -525,37 +525,35 @@ deriving instance RepTypes rep => Ord (FunDef rep) --- | Every entry point argument and return value has an annotation --- indicating how it maps to the original source program type. -data EntryPointType - = -- | Is an unsigned integer or array of unsigned - -- integers. - TypeUnsigned Uniqueness - | -- | A black box type comprising this many core - -- values. The string is a human-readable - -- description with no other semantics. - TypeOpaque Uniqueness String Int - | -- | Maps directly. - TypeDirect Uniqueness - deriving (Eq, Show, Ord) - -- | An entry point parameter, comprising its name and original type. data EntryParam = EntryParam { entryParamName :: Name, + entryParamUniqueness :: Uniqueness, entryParamType :: EntryPointType } deriving (Eq, Show, Ord) +-- | An entry point result type. +data EntryResult = EntryResult + { entryResultUniqueness :: Uniqueness, + entryResultType :: EntryPointType + } + deriving (Eq, Show, Ord) + -- | Information about the inputs and outputs (return value) of an entry -- point. -type EntryPoint = (Name, [EntryParam], [EntryPointType]) +type EntryPoint = (Name, [EntryParam], [EntryResult]) -- | An entire Futhark program. data Prog rep = Prog - { -- | Top-level constants that are computed at program startup, and + { -- | The opaque types used in entry points. This information is + -- used to generate extra API functions for + -- construction and deconstruction of values of these types. + progTypes :: OpaqueTypes, + -- | Top-level constants that are computed at program startup, and -- which are in scope inside all functions. progConsts :: Stms rep, - -- | The functions comprising the program. All funtions are also + -- | The functions comprising the program. All functions are also -- available in scope in the definitions of the constants, so be -- careful not to introduce circular dependencies (not currently -- checked). 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 @@ -11,7 +11,7 @@ -- there should be no reason to include it explicitly. module Futhark.IR.Syntax.Core ( module Language.Futhark.Core, - module Futhark.IR.Primitive, + module Language.Futhark.Primitive, -- * Types Commutativity (..), @@ -37,6 +37,13 @@ ErrorMsgPart (..), errorMsgArgTypes, + -- * Entry point information + ValueType (..), + OpaqueType (..), + OpaqueTypes (..), + Signedness (..), + EntryPointType (..), + -- * Attributes Attr (..), Attrs (..), @@ -81,8 +88,8 @@ import qualified Data.Set as S import Data.String import Data.Traversable (fmapDefault, foldMapDefault) -import Futhark.IR.Primitive import Language.Futhark.Core +import Language.Futhark.Primitive import Prelude hiding (id, (.)) -- | Whether some operator is commutative or not. The 'Monoid' @@ -558,3 +565,48 @@ -- | Map a function over an attribute set. mapAttrs :: (Attr -> a) -> Attrs -> [a] mapAttrs f (Attrs attrs) = map f $ S.toList attrs + +-- | 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 +-- indicate whether they are really unsigned integers. This doesn't +-- matter for non-integer types. +data Signedness + = Unsigned + | Signed + deriving (Eq, Ord, Show) + +-- | An actual non-opaque type that can be passed to and from Futhark +-- programs, or serve as the contents of opaque types. Scalars are +-- represented with zero rank. +data ValueType + = ValueType Signedness Rank PrimType + deriving (Eq, Ord, Show) + +-- | Every entry point argument and return value has an annotation +-- indicating how it maps to the original source program type. +data EntryPointType + = -- | An opaque type of this name. + TypeOpaque String + | -- | A transparent type, which is scalar if the rank is zero. + TypeTransparent ValueType + deriving (Eq, Show, Ord) + +-- | The representation of an opaque type. +data OpaqueType + = OpaqueType [ValueType] + | -- | Note that the field ordering here denote the actual + -- representation - make sure it is preserved. + OpaqueRecord [(Name, EntryPointType)] + deriving (Eq, Ord, Show) + +-- | Names of opaque types and their representation. +newtype OpaqueTypes = OpaqueTypes [(String, OpaqueType)] + deriving (Eq, Ord, Show) + +instance Monoid OpaqueTypes where + mempty = OpaqueTypes mempty + +instance Semigroup OpaqueTypes where + OpaqueTypes x <> OpaqueTypes y = + OpaqueTypes $ x <> filter ((`notElem` map fst x) . fst) y diff --git a/src/Futhark/IR/Traversals.hs b/src/Futhark/IR/Traversals.hs --- a/src/Futhark/IR/Traversals.hs +++ b/src/Futhark/IR/Traversals.hs @@ -91,7 +91,8 @@ BasicOp <$> (SubExp <$> mapOnSubExp tv se) mapExpM tv (BasicOp (ArrayLit els rowt)) = BasicOp - <$> ( ArrayLit <$> mapM (mapOnSubExp tv) els + <$> ( ArrayLit + <$> mapM (mapOnSubExp tv) els <*> mapOnType (mapOnSubExp tv) rowt ) mapExpM tv (BasicOp (BinOp bop x y)) = @@ -103,7 +104,10 @@ mapExpM tv (BasicOp (UnOp op x)) = BasicOp <$> (UnOp op <$> mapOnSubExp tv x) mapExpM tv (If c texp fexp (IfDec ts s)) = - If <$> mapOnSubExp tv c <*> mapOnBody tv mempty texp <*> mapOnBody tv mempty fexp + If + <$> mapOnSubExp tv c + <*> mapOnBody tv mempty texp + <*> mapOnBody tv mempty fexp <*> (IfDec <$> mapM (mapOnBranchType tv) ts <*> pure s) mapExpM tv (Apply fname args ret loc) = do args' <- forM args $ \(arg, d) -> @@ -111,23 +115,27 @@ Apply fname args' <$> mapM (mapOnRetType tv) ret <*> pure loc mapExpM tv (BasicOp (Index arr slice)) = BasicOp - <$> ( Index <$> mapOnVName tv arr + <$> ( Index + <$> mapOnVName tv arr <*> traverse (mapOnSubExp tv) slice ) mapExpM tv (BasicOp (Update safety arr slice se)) = BasicOp - <$> ( Update safety <$> mapOnVName tv arr + <$> ( Update safety + <$> mapOnVName tv arr <*> traverse (mapOnSubExp tv) slice <*> mapOnSubExp tv se ) mapExpM tv (BasicOp (FlatIndex arr slice)) = BasicOp - <$> ( FlatIndex <$> mapOnVName tv arr + <$> ( FlatIndex + <$> mapOnVName tv arr <*> traverse (mapOnSubExp tv) slice ) mapExpM tv (BasicOp (FlatUpdate arr slice se)) = BasicOp - <$> ( FlatUpdate <$> mapOnVName tv arr + <$> ( FlatUpdate + <$> mapOnVName tv arr <*> traverse (mapOnSubExp tv) slice <*> mapOnVName tv se ) @@ -171,7 +179,9 @@ WithAcc <$> mapM onInput inputs <*> mapOnLambda tv lam where onInput (shape, vs, op) = - (,,) <$> mapOnShape tv shape <*> mapM (mapOnVName tv) vs + (,,) + <$> mapOnShape tv shape + <*> mapM (mapOnVName tv) vs <*> traverse (bitraverse (mapOnLambda tv) (mapM (mapOnSubExp tv))) op mapExpM tv (DoLoop merge form loopbody) = do params' <- mapM (mapOnFParam tv) params @@ -195,7 +205,10 @@ LoopForm frep -> m (LoopForm trep) mapOnLoopForm tv (ForLoop i it bound loop_vars) = - ForLoop <$> mapOnVName tv i <*> pure it <*> mapOnSubExp tv bound + ForLoop + <$> mapOnVName tv i + <*> pure it + <*> mapOnSubExp tv bound <*> (zip <$> mapM (mapOnLParam tv) loop_lparams <*> mapM (mapOnVName tv) loop_arrs) where (loop_lparams, loop_arrs) = unzip loop_vars @@ -259,7 +272,8 @@ walkOnLoopForm :: Monad m => Walker rep m -> LoopForm rep -> m () walkOnLoopForm tv (ForLoop i _ bound loop_vars) = - walkOnVName tv i >> walkOnSubExp tv bound + walkOnVName tv i + >> walkOnSubExp tv bound >> mapM_ (walkOnLParam tv) loop_lparams >> mapM_ (walkOnVName tv) loop_arrs where diff --git a/src/Futhark/IR/TypeCheck.hs b/src/Futhark/IR/TypeCheck.hs --- a/src/Futhark/IR/TypeCheck.hs +++ b/src/Futhark/IR/TypeCheck.hs @@ -55,7 +55,6 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Control.Parallel.Strategies -import Data.Bifunctor (second) import Data.List (find, intercalate, isPrefixOf, sort) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M @@ -103,7 +102,8 @@ ++ pretty t ++ "." show (ReturnTypeError fname rettype bodytype) = - "Declaration of function " ++ nameToString fname + "Declaration of function " + ++ nameToString fname ++ " declares return type\n " ++ prettyTuple rettype ++ "\nBut body has type\n " @@ -111,14 +111,16 @@ show (DupDefinitionError name) = "Duplicate definition of function " ++ nameToString name ++ "" show (DupParamError funname paramname) = - "Parameter " ++ pretty paramname + "Parameter " + ++ pretty paramname ++ " mentioned multiple times in argument list of function " ++ nameToString funname ++ "." show (DupPatError name) = "Variable " ++ pretty name ++ " bound twice in pattern." show (InvalidPatError pat t desc) = - "Pat\n" ++ pretty pat + "Pat\n" + ++ pretty pat ++ "\ncannot match value of type\n" ++ prettyTupleLines t ++ end @@ -131,7 +133,9 @@ show (UnknownFunctionError fname) = "Call of unknown function " ++ nameToString fname ++ "." show (ParameterMismatch fname expected got) = - "In call of " ++ fname' ++ ":\n" + "In call of " + ++ fname' + ++ ":\n" ++ "expecting " ++ show nexpected ++ " arguments of type(s)\n" @@ -147,12 +151,16 @@ show (SlicingError dims got) = show got ++ " indices given, but type of indexee has " ++ show dims ++ " dimension(s)." show (BadAnnotation desc expected got) = - "Annotation of \"" ++ desc ++ "\" type of expression is " ++ pretty expected + "Annotation of \"" + ++ desc + ++ "\" type of expression is " + ++ pretty expected ++ ", but derived to be " ++ pretty got ++ "." show (ReturnAliased fname name) = - "Unique return value of function " ++ nameToString fname + "Unique return value of function " + ++ nameToString fname ++ " is aliased to " ++ pretty name ++ ", which is not consumed." @@ -161,12 +169,14 @@ ++ nameToString fname ++ " is aliased to some other tuple component." show (NotAnArray e t) = - "The expression " ++ pretty e + "The expression " + ++ pretty e ++ " is expected to be an array, but is " ++ pretty t ++ "." show (PermutationError perm rank name) = - "The permutation (" ++ intercalate ", " (map show perm) + "The permutation (" + ++ intercalate ", " (map show perm) ++ ") is not valid for array " ++ name' ++ "of rank " @@ -284,12 +294,7 @@ -- | The type checker runs in this monad. newtype TypeM rep a - = TypeM - ( ReaderT - (Env rep) - (StateT TState (Either (TypeError rep))) - a - ) + = TypeM (ReaderT (Env rep) (StateT TState (Either (TypeError rep))) a) deriving ( Monad, Functor, @@ -310,9 +315,9 @@ runTypeM :: Env rep -> TypeM rep a -> - Either (TypeError rep) (a, Consumption) + Either (TypeError rep) a runTypeM env (TypeM m) = - second stateCons <$> runStateT (runReaderT m env) (TState mempty mempty) + evalStateT (runReaderT m env) (TState mempty mempty) -- | Signal a type error. bad :: ErrorCase rep -> TypeM rep a @@ -348,7 +353,9 @@ bound name = do already_seen <- gets $ nameIn name . stateNames when already_seen $ - bad $ TypeError $ "Name " ++ pretty name ++ " bound twice" + bad $ + TypeError $ + "Name " ++ pretty name ++ " bound twice" modify $ \s -> s {stateNames = oneName name <> stateNames s} occur :: Occurences -> TypeM rep () @@ -418,12 +425,10 @@ wasConsumed v | Just als <- lookup v consumable = pure als | otherwise = - bad $ - TypeError $ - unlines - [ pretty v ++ " was invalidly consumed.", - what ++ " can be consumed here." - ] + bad . TypeError . unlines $ + [ pretty v ++ " was invalidly consumed.", + what ++ " can be consumed here." + ] what | null consumable = "Nothing" | otherwise = "Only " ++ intercalate ", " (map (pretty . fst) consumable) @@ -524,7 +529,8 @@ require ts se = do t <- checkSubExp se unless (t `elem` ts) $ - bad $ UnexpectedType (BasicOp $ SubExp se) t ts + bad $ + UnexpectedType (BasicOp $ SubExp se) t ts -- | Variant of 'require' working on variable names. requireI :: Checkable rep => [Type] -> VName -> TypeM rep () @@ -555,6 +561,23 @@ ++ " should be an accumulator but is of type " ++ pretty t +checkOpaques :: OpaqueTypes -> Either (TypeError rep) () +checkOpaques (OpaqueTypes types) = descend [] types + where + descend _ [] = pure () + descend known ((name, t) : ts) = do + check known t + descend (name : known) ts + check known (OpaqueRecord fs) = + mapM_ (checkEntryPointType known . snd) fs + check _ (OpaqueType _) = + pure () + checkEntryPointType known (TypeOpaque s) = + when (s `notElem` known) $ + Left . Error [] . TypeError $ + "Opaque not defined before first use: " <> s + checkEntryPointType _ (TypeTransparent _) = pure () + -- | Type check a program containing arbitrary type information, -- yielding either a type error or a program with complete type -- information. @@ -562,7 +585,8 @@ Checkable rep => Prog (Aliases rep) -> Either (TypeError rep) () -checkProg (Prog consts funs) = do +checkProg (Prog opaques consts funs) = do + checkOpaques opaques let typeenv = Env { envVtable = M.empty, @@ -570,15 +594,15 @@ envContext = [], envCheckOp = checkOp } - let onFunction ftable vtable fun = - fmap fst $ - runTypeM typeenv $ - local (\env -> env {envFtable = ftable, envVtable = vtable}) $ - checkFun fun - (ftable, _) <- runTypeM typeenv buildFtable - (vtable, _) <- - runTypeM typeenv {envFtable = ftable} $ - checkStms consts $ asks envVtable + let const_names = foldMap (patNames . stmPat) consts + onFunction ftable vtable fun = runTypeM typeenv $ do + modify $ \s -> s {stateNames = namesFromList const_names} + local (\env -> env {envFtable = ftable, envVtable = vtable}) $ + checkFun fun + ftable <- + runTypeM typeenv buildFtable + vtable <- + runTypeM typeenv {envFtable = ftable} $ checkStms consts $ asks envVtable sequence_ $ parMap rpar (onFunction ftable vtable) funs where buildFtable = do @@ -605,17 +629,17 @@ FunDef (Aliases rep) -> TypeM rep () checkFun (FunDef _ _ fname rettype params body) = - context ("In function " ++ nameToString fname) $ - checkFun' + context ("In function " ++ nameToString fname) + $ checkFun' ( fname, map declExtTypeOf rettype, funParamsToNameInfos params ) (Just consumable) - $ do - checkFunParams params - checkRetType rettype - context "When checking function body" $ checkFunBody rettype body + $ do + checkFunParams params + checkRetType rettype + context "When checking function body" $ checkFunBody rettype body where consumable = [ (paramName param, mempty) @@ -669,7 +693,8 @@ ( "When checking the body aliases: " ++ pretty (map namesToList body_aliases) ) - $ checkReturnAlias $ map (namesFromList . filter isArray . namesToList) body_aliases + $ checkReturnAlias + $ map (namesFromList . filter isArray . namesToList) body_aliases where param_names = map fst params @@ -772,23 +797,24 @@ TypeM rep () checkLambdaResult ts es | length ts /= length es = - bad $ - TypeError $ - "Lambda has return type " ++ prettyTuple ts - ++ " describing " - ++ show (length ts) - ++ " values, but body returns " - ++ show (length es) - ++ " values: " - ++ prettyTuple es + bad . TypeError $ + "Lambda has return type " + ++ prettyTuple ts + ++ " describing " + ++ show (length ts) + ++ " values, but body returns " + ++ show (length es) + ++ " values: " + ++ prettyTuple es | otherwise = forM_ (zip ts es) $ \(t, e) -> do et <- checkSubExpRes e - unless (et == t) $ - bad $ - TypeError $ - "Subexpression " ++ pretty e ++ " has type " ++ pretty et - ++ " but expected " - ++ pretty t + unless (et == t) . bad . TypeError $ + "Subexpression " + ++ pretty e + ++ " has type " + ++ pretty et + ++ " but expected " + ++ pretty t checkBody :: Checkable rep => @@ -812,13 +838,11 @@ checkBasicOp (ArrayLit (e : es') t) = do let check elemt eleme = do elemet <- checkSubExp eleme - unless (elemet == elemt) $ - bad $ - TypeError $ - pretty elemet - ++ " is not of expected type " - ++ pretty elemt - ++ "." + unless (elemet == elemt) . bad . TypeError $ + pretty elemet + ++ " is not of expected type " + ++ pretty elemt + ++ "." et <- checkSubExp e -- Compare that type with the one given for the array literal. @@ -833,16 +857,19 @@ vt <- lookupType ident observe ident when (arrayRank vt /= length idxes) $ - bad $ SlicingError (arrayRank vt) (length idxes) + bad $ + SlicingError (arrayRank vt) (length idxes) mapM_ checkDimIndex idxes checkBasicOp (Update _ src (Slice idxes) se) = do (src_shape, src_pt) <- checkArrIdent src when (shapeRank src_shape /= length idxes) $ - bad $ SlicingError (shapeRank src_shape) (length idxes) + bad $ + SlicingError (shapeRank src_shape) (length idxes) se_aliases <- subExpAliasesM se when (src `nameIn` se_aliases) $ - bad $ TypeError "The target of an Update must not alias the value to be written." + bad $ + TypeError "The target of an Update must not alias the value to be written." mapM_ checkDimIndex idxes require [arrayOf (Prim src_pt) (Shape (sliceDims (Slice idxes))) NoUniqueness] se @@ -851,16 +878,19 @@ vt <- lookupType ident observe ident when (arrayRank vt /= 1) $ - bad $ SlicingError (arrayRank vt) 1 + bad $ + SlicingError (arrayRank vt) 1 checkFlatSlice slice checkBasicOp (FlatUpdate src slice v) = do (src_shape, src_pt) <- checkArrIdent src when (shapeRank src_shape /= 1) $ - bad $ SlicingError (shapeRank src_shape) 1 + bad $ + SlicingError (shapeRank src_shape) 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." + bad $ + TypeError "The target of an Update must not alias the value to be written." checkFlatSlice slice requireI [arrayOf (Prim src_pt) (Shape (flatSliceDims slice)) NoUniqueness] v @@ -883,21 +913,25 @@ pure () checkDimChange rank (DimCoercion se) i | i >= rank = - bad $ - TypeError $ - "Asked to coerce dimension " ++ show i ++ " to " ++ pretty se - ++ ", but array " - ++ pretty arrexp - ++ " has only " - ++ pretty rank - ++ " dimensions" + bad . TypeError $ + "Asked to coerce dimension " + ++ show i + ++ " to " + ++ pretty se + ++ ", but array " + ++ pretty arrexp + ++ " has only " + ++ pretty rank + ++ " dimensions" | otherwise = pure () checkBasicOp (Rearrange perm arr) = do arrt <- lookupType arr let rank = arrayRank arrt when (length perm /= rank || sort perm /= [0 .. rank - 1]) $ - bad $ PermutationError perm rank $ Just arr + bad $ + PermutationError perm rank $ + Just arr checkBasicOp (Rotate rots arr) = do arrt <- lookupType arr let rank = arrayRank arrt @@ -905,7 +939,8 @@ when (length rots /= rank) $ bad $ TypeError $ - "Cannot rotate " ++ show (length rots) + "Cannot rotate " + ++ show (length rots) ++ " dimensions of " ++ show rank ++ "-dimensional array." @@ -913,7 +948,8 @@ arr1_dims <- shapeDims . fst <$> checkArrIdent arr1exp arr2s_dims <- map (shapeDims . fst) <$> mapM checkArrIdent arr2exps unless (all ((== dropAt i 1 arr1_dims) . dropAt i 1) arr2s_dims) $ - bad $ TypeError "Types of arguments to concat do not match." + bad $ + TypeError "Types of arguments to concat do not match." require [Prim int64] ressize checkBasicOp (Copy e) = void $ checkArrIdent e @@ -928,23 +964,20 @@ checkBasicOp (UpdateAcc acc is ses) = do (shape, ts) <- checkAccIdent acc - unless (length ses == length ts) $ - bad $ - TypeError $ - "Accumulator requires " - ++ show (length ts) - ++ " values, but " - ++ show (length ses) - ++ " provided." + unless (length ses == length ts) . bad . TypeError $ + "Accumulator requires " + ++ show (length ts) + ++ " values, but " + ++ show (length ses) + ++ " provided." unless (length is == shapeRank shape) $ - bad $ - TypeError $ - "Accumulator requires " - ++ show (shapeRank shape) - ++ " indices, but " - ++ show (length is) - ++ " provided." + bad . TypeError $ + "Accumulator requires " + ++ show (shapeRank shape) + ++ " indices, but " + ++ show (length is) + ++ " provided." zipWithM_ require (map pure ts) ses consume =<< lookupAliases acc @@ -957,7 +990,8 @@ matchLoopResultExt merge loopres = do let rettype_ext = existentialiseExtTypes (map paramName merge) $ - staticShapes $ map typeOf merge + staticShapes $ + map typeOf merge bodyt <- mapM subExpResType loopres @@ -969,12 +1003,11 @@ rettype_ext (staticShapes bodyt) Just rettype' -> - unless (bodyt `subtypesOf` rettype') $ - bad $ - ReturnTypeError - (nameFromString "") - (staticShapes rettype') - (staticShapes bodyt) + unless (bodyt `subtypesOf` rettype') . bad $ + ReturnTypeError + (nameFromString "") + (staticShapes rettype') + (staticShapes bodyt) checkExp :: Checkable rep => @@ -1015,28 +1048,30 @@ ] ++ form_consumable - context "Inside the loop body" $ - checkFun' + context "Inside the loop body" + $ checkFun' ( nameFromString "", staticShapes rettype, funParamsToNameInfos mergepat ) (Just consumable) - $ do - checkFunParams mergepat - checkBodyDec $ snd $ bodyDec loopbody + $ do + checkFunParams mergepat + checkBodyDec $ snd $ bodyDec loopbody - checkStms (bodyStms loopbody) $ do - context "In loop body result" $ - checkResult $ bodyResult loopbody + checkStms (bodyStms loopbody) $ do + context "In loop body result" $ + checkResult $ + bodyResult loopbody - context "When matching result of body with loop parameters" $ - matchLoopResult (map fst merge) $ bodyResult loopbody + context "When matching result of body with loop parameters" $ + matchLoopResult (map fst merge) $ + bodyResult loopbody - let bound_here = - namesFromList $ M.keys $ scopeOf $ bodyStms loopbody - map (`namesSubtract` bound_here) - <$> mapM (subExpAliasesM . resSubExp) (bodyResult loopbody) + let bound_here = + namesFromList $ M.keys $ scopeOf $ bodyStms loopbody + map (`namesSubtract` bound_here) + <$> mapM (subExpAliasesM . resSubExp) (bodyResult loopbody) where checkLoopVar (p, a) = do a_t <- lookupType a @@ -1045,21 +1080,21 @@ Just a_t_r -> do checkLParamDec (paramName p) $ paramDec p unless (a_t_r `subtypeOf` typeOf (paramDec p)) $ - bad $ - TypeError $ - "Loop parameter " ++ pretty p - ++ " not valid for element of " - ++ pretty a - ++ ", which has row type " - ++ pretty a_t_r + bad . TypeError $ + "Loop parameter " + ++ pretty p + ++ " not valid for element of " + ++ pretty a + ++ ", which has row type " + ++ pretty a_t_r als <- lookupAliases a pure (paramName p, als) _ -> - bad $ - TypeError $ - "Cannot loop over " ++ pretty a - ++ " of type " - ++ pretty a_t + bad . TypeError $ + "Cannot loop over " + ++ pretty a + ++ " of type " + ++ pretty a_t checkForm mergeargs (ForLoop loopvar it boundexp loopvars) = do iparam <- primFParam loopvar $ IntType it let mergepat = map fst merge @@ -1074,11 +1109,12 @@ case find ((== cond) . paramName . fst) merge of Just (condparam, _) -> unless (paramType condparam == Prim Bool) $ - bad $ - TypeError $ - "Conditional '" ++ pretty cond ++ "' of while-loop is not boolean, but " - ++ pretty (paramType condparam) - ++ "." + bad . TypeError $ + "Conditional '" + ++ pretty cond + ++ "' of while-loop is not boolean, but " + ++ pretty (paramType condparam) + ++ "." Nothing -> bad $ TypeError $ @@ -1116,7 +1152,8 @@ elem_ts <- forM arrs $ \arr -> do arr_t <- lookupType arr unless (shapeDims shape `isPrefixOf` arrayDims arr_t) $ - bad . TypeError $ pretty arr <> " is not an array of outer shape " <> pretty shape + bad . TypeError $ + pretty arr <> " is not an array of outer shape " <> pretty shape consume =<< lookupAliases arr pure $ stripArray (shapeRank shape) arr_t @@ -1159,12 +1196,13 @@ Acc {} -> pure (t, als) Array {} -> do let argSize = arraySize 0 t - unless (argSize == width) $ - bad . TypeError $ - "SOAC argument " ++ pretty v ++ " has outer size " - ++ pretty argSize - ++ ", but width of SOAC is " - ++ pretty width + unless (argSize == width) . bad . TypeError $ + "SOAC argument " + ++ pretty v + ++ " has outer size " + ++ pretty argSize + ++ ", but width of SOAC is " + ++ pretty width pure (rowType t, als) _ -> bad . TypeError $ @@ -1282,7 +1320,8 @@ TypeM rep () matchExtPat pat ts = unless (expExtTypesFromPat pat == ts) $ - bad $ InvalidPatError pat ts Nothing + bad $ + InvalidPatError pat ts Nothing matchExtReturnType :: Checkable rep => @@ -1308,14 +1347,12 @@ matchExtReturns rettype res ts = do let problem :: TypeM rep a problem = - bad $ - TypeError $ - unlines - [ "Type annotation is", - " " ++ prettyTuple rettype, - "But result returns type", - " " ++ prettyTuple ts - ] + bad . TypeError . unlines $ + [ "Type annotation is", + " " ++ prettyTuple rettype, + "But result returns type", + " " ++ prettyTuple ts + ] unless (length res == length rettype) problem @@ -1371,7 +1408,9 @@ checkFuncall fname paramts args = do let argts = map argType args unless (validApply paramts argts) $ - bad $ ParameterMismatch fname (map fromDecl paramts) $ map argType args + bad $ + ParameterMismatch fname (map fromDecl paramts) $ + map argType args consumeArgs paramts args consumeArgs :: @@ -1402,28 +1441,24 @@ if soac then Just $ zip (map paramName params) (map argAliases args) else Nothing + params' = + [(paramName param, LParamName $ paramDec param) | param <- params] checkFun' - ( fname, - staticShapes $ map (`toDecl` Nonunique) rettype, - [ ( paramName param, - LParamName $ paramDec param - ) - | param <- params - ] - ) + (fname, staticShapes $ map (`toDecl` Nonunique) rettype, params') consumable $ do checkLambdaParams params mapM_ checkType rettype checkLambdaBody rettype body else - bad $ - TypeError $ - "Anonymous function defined with " ++ show (length params) ++ " parameters:\n" - ++ pretty params - ++ "\nbut expected to take " - ++ show (length args) - ++ " arguments." + bad . TypeError $ + "Anonymous function defined with " + ++ show (length params) + ++ " parameters:\n" + ++ pretty params + ++ "\nbut expected to take " + ++ show (length args) + ++ " arguments." checkLambda :: Checkable rep => Lambda (Aliases rep) -> [Arg] -> TypeM rep () checkLambda = checkAnyLambda True @@ -1445,28 +1480,24 @@ (bad $ TypeError $ "Unknown function: " ++ h) pure $ M.lookup h primFuns - when (length h_ts /= length args) $ - bad $ - TypeError $ - "Function expects " ++ show (length h_ts) - ++ " parameters, but given " - ++ show (length args) - ++ " arguments." - when (h_ret /= t) $ - bad $ - TypeError $ - "Function return annotation is " ++ pretty t - ++ ", but expected " - ++ pretty h_ret + when (length h_ts /= length args) . bad . TypeError $ + "Function expects " + ++ show (length h_ts) + ++ " parameters, but given " + ++ show (length args) + ++ " arguments." + when (h_ret /= t) . bad . TypeError $ + "Function return annotation is " + ++ pretty t + ++ ", but expected " + ++ pretty h_ret zipWithM_ requirePrimExp h_ts args requirePrimExp :: Checkable rep => PrimType -> PrimExp VName -> TypeM rep () requirePrimExp t e = context ("in PrimExp " ++ pretty e) $ do checkPrimExp e - unless (primExpType e == t) $ - bad $ - TypeError $ - pretty e ++ " must have type " ++ pretty t + unless (primExpType e == t) . bad . TypeError $ + pretty e ++ " must have type " ++ pretty t class ASTRep rep => CheckableOp rep where checkOp :: OpWithAliases (Op rep) -> TypeM rep () diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -47,6 +47,7 @@ import Futhark.IR.SOACS as I hiding (stmPat) import Futhark.Internalise.Defunctionalise as Defunctionalise import Futhark.Internalise.Defunctorise as Defunctorise +import Futhark.Internalise.Entry (visibleTypes) import qualified Futhark.Internalise.Exps as Exps import Futhark.Internalise.LiftLambdas as LiftLambdas import Futhark.Internalise.Monad as I @@ -71,7 +72,7 @@ maybeLog "Defunctionalising" prog_decs''' <- Defunctionalise.transformProg prog_decs'' maybeLog "Converting to core IR" - Exps.transformProg (futharkSafe config) prog_decs''' + Exps.transformProg (futharkSafe config) (visibleTypes prog) prog_decs''' where verbose = fst (futharkVerbose config) > NotVerbose maybeLog s 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 @@ -53,7 +53,8 @@ let (certparams, valueparams') = unzip $ map fixAccParam (concat valueparams) I.localScope (I.scopeOfFParams $ catMaybes certparams ++ shape_params ++ valueparams') $ substitutingVars shape_subst $ - m (catMaybes certparams ++ shape_params) $ chunks num_param_ts valueparams' + m (catMaybes certparams ++ shape_params) $ + chunks num_param_ts valueparams' where fixAccParam (I.Param attrs pv (I.Acc acc ispace ts u)) = ( Just (I.Param attrs acc $ I.Prim I.Unit), @@ -76,7 +77,9 @@ bindingFlatPat pat_idents pat_ts $ \valueparams -> I.localScope (I.scopeOfFParams $ shape_params ++ concat valueparams) $ - substitutingVars shape_subst $ m shape_params $ concat valueparams + substitutingVars shape_subst $ + m shape_params $ + concat valueparams bindingLambdaParams :: [E.Pat] -> @@ -115,10 +118,9 @@ internaliseBindee :: E.Ident -> InternaliseM [VName] internaliseBindee bindee = do let name = E.identName bindee - n <- internalisedTypeSize $ E.unInfo $ E.identType bindee - case n of + case internalisedTypeSize $ E.unInfo $ E.identType bindee of 1 -> pure [name] - _ -> replicateM n $ newVName $ baseString name + n -> replicateM n $ newVName $ baseString name bindingFlatPat :: Show t => 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 @@ -19,7 +19,6 @@ import Data.Maybe import qualified Data.Set as S import Futhark.IR.Pretty () -import qualified Futhark.Internalise.FreeVars as FV import Futhark.MonadFreshNames import Language.Futhark import Language.Futhark.Traversals @@ -77,15 +76,15 @@ replaceTypeSizes :: M.Map VName SizeSubst -> - TypeBase (DimDecl VName) als -> - TypeBase (DimDecl VName) als + TypeBase Size als -> + TypeBase Size als replaceTypeSizes substs = first onDim where - onDim (NamedDim v) = + onDim (NamedSize v) = case M.lookup (qualLeaf v) substs of - Just (SubstNamed v') -> NamedDim v' - Just (SubstConst d) -> ConstDim d - Nothing -> NamedDim v + Just (SubstNamed v') -> NamedSize v' + Just (SubstConst d) -> ConstSize d + Nothing -> NamedSize v onDim d = d replaceStaticValSizes :: @@ -145,12 +144,12 @@ te' = onTypeExp substs te onExp substs e = onAST substs e - onTypeExpDim substs d@(DimExpNamed v loc) = + onTypeExpDim substs d@(SizeExpNamed v loc) = case M.lookup (qualLeaf v) substs of Just (SubstNamed v') -> - DimExpNamed v' loc + SizeExpNamed v' loc Just (SubstConst x) -> - DimExpConst x loc + SizeExpConst x loc Nothing -> d onTypeExpDim _ d = d @@ -203,8 +202,8 @@ -- | Returns the defunctionalization environment restricted -- to the given set of variable names and types. -restrictEnvTo :: FV.NameSet -> DefM Env -restrictEnvTo (FV.NameSet m) = asks restrict +restrictEnvTo :: FV -> DefM Env +restrictEnvTo (FV m) = asks restrict where restrict (globals, env) = M.mapMaybeWithKey keep env where @@ -272,7 +271,7 @@ -- Anything not in scope is going to be an existential size. pure $ Dynamic $ Scalar $ Prim $ Signed Int64 --- Like patternDimNames, but ignores sizes that are only found in +-- Like freeInPat, but ignores sizes that are only found in -- funtion types. arraySizes :: StructType -> S.Set VName arraySizes (Scalar Arrow {}) = mempty @@ -281,15 +280,15 @@ arraySizes (Scalar (TypeVar _ _ _ targs)) = mconcat $ map f targs where - f (TypeArgDim (NamedDim d) _) = S.singleton $ qualLeaf d + f (TypeArgDim (NamedSize d) _) = S.singleton $ qualLeaf d f TypeArgDim {} = mempty f (TypeArgType t _) = arraySizes t arraySizes (Scalar Prim {}) = mempty arraySizes (Array _ _ shape t) = arraySizes (Scalar t) <> foldMap dimName (shapeDims shape) where - dimName :: DimDecl VName -> S.Set VName - dimName (NamedDim qn) = S.singleton $ qualLeaf qn + dimName :: Size -> S.Set VName + dimName (NamedSize qn) = S.singleton $ qualLeaf qn dimName _ = mempty patternArraySizes :: Pat -> S.Set VName @@ -302,25 +301,25 @@ dimMapping :: Monoid a => - TypeBase (DimDecl VName) a -> - TypeBase (DimDecl VName) a -> + TypeBase Size a -> + TypeBase Size a -> M.Map VName SizeSubst dimMapping t1 t2 = execState (matchDims f t1 t2) mempty where - f bound d1 (NamedDim d2) + f bound d1 (NamedSize d2) | qualLeaf d2 `elem` bound = pure d1 - f _ (NamedDim d1) (NamedDim d2) = do + f _ (NamedSize d1) (NamedSize d2) = do modify $ M.insert (qualLeaf d1) $ SubstNamed d2 - pure $ NamedDim d1 - f _ (NamedDim d1) (ConstDim d2) = do + pure $ NamedSize d1 + f _ (NamedSize d1) (ConstSize d2) = do modify $ M.insert (qualLeaf d1) $ SubstConst d2 - pure $ NamedDim d1 + pure $ NamedSize d1 f _ d _ = pure d dimMapping' :: Monoid a => - TypeBase (DimDecl VName) a -> - TypeBase (DimDecl VName) a -> + TypeBase Size a -> + TypeBase Size a -> M.Map VName VName dimMapping' t1 t2 = M.mapMaybe f $ dimMapping t1 t2 where @@ -339,7 +338,7 @@ sizesToRename (SumSV _ svs _) = foldMap sizesToRename svs sizesToRename (LambdaSV param _ _ _) = - patternDimNames param + freeInPat param <> S.map identName (S.filter couldBeSize $ patIdents param) where couldBeSize ident = @@ -400,8 +399,8 @@ -- the lambda. Closed-over 'DynamicFun's are converted to their -- closure representation. let used = - FV.freeVars (Lambda pats e0 Nothing (Info (mempty, ret)) loc) - `FV.without` S.fromList tparams + freeInExp (Lambda pats e0 Nothing (Info (mempty, ret)) loc) + `freeWithout` S.fromList tparams used_env <- restrictEnvTo used -- The closure parts that are sizes are proactively turned into size @@ -411,7 +410,9 @@ <> patternArraySizes pat notSize = not . (`S.member` sizes_of_arrays) (fields, env) = - second M.fromList . unzip . map closureFromDynamicFun + second M.fromList + . unzip + . map closureFromDynamicFun . filter (notSize . fst) $ M.toList used_env @@ -527,7 +528,8 @@ -- newly computed body type. let mapping = dimMapping' (typeOf e2) t subst v = fromMaybe v $ M.lookup v mapping - t' = first (fmap subst) $ typeOf e2' + mapper = identityMapper {mapOnName = pure . subst} + t' = first (runIdentity . astMap mapper) $ typeOf e2' pure (AppExp (LetPat sizes pat' e1' e2' loc) (Info (AppRes t' retext)), sv2) defuncExp (AppExp (LetFun vn _ _ _) _) = error $ "defuncExp: Unexpected LetFun: " ++ prettyName vn @@ -645,15 +647,15 @@ where defuncType :: Monoid als => - TypeBase (DimDecl VName) als -> - TypeBase (DimDecl VName) als + TypeBase Size als -> + TypeBase Size als defuncType (Array as u shape t) = Array as u shape (defuncScalar t) defuncType (Scalar t) = Scalar $ defuncScalar t defuncScalar :: Monoid als => - ScalarTypeBase (DimDecl VName) als -> - ScalarTypeBase (DimDecl VName) als + ScalarTypeBase Size als -> + ScalarTypeBase Size als defuncScalar (Record fs) = Record $ M.map defuncType fs defuncScalar Arrow {} = Record mempty defuncScalar (Sum fs) = Sum $ M.map (map defuncType) fs @@ -661,7 +663,9 @@ defuncScalar (TypeVar as u tn targs) = TypeVar as u tn targs defuncExp (Constr name _ (Info t) loc) = error $ - "Constructor " ++ pretty name ++ " given type " + "Constructor " + ++ pretty name + ++ " given type " ++ pretty t ++ " at " ++ locStr loc @@ -757,7 +761,7 @@ DefM ([VName], [Pat], Exp, StaticVal) defuncLet dims ps@(pat : pats) body (RetType ret_dims rettype) | patternOrderZero pat = do - let bound_by_pat = (`S.member` patternDimNames pat) + let bound_by_pat = (`S.member` freeInPat pat) -- Take care to not include more size parameters than necessary. (pat_dims, rest_dims) = partition bound_by_pat dims env = envFromPat pat <> envFromDimNames pat_dims @@ -790,24 +794,26 @@ where bound = bound_sizes <> foldMap patNames params tv = identityMapper {mapOnPatType = bitraverse onDim pure} - onDim (AnyDim (Just v)) = do + onDim (AnySize (Just v)) = do modify $ S.insert v - pure $ NamedDim $ qualName v - onDim (AnyDim Nothing) = do + pure $ NamedSize $ qualName v + onDim (AnySize Nothing) = do v <- lift $ newVName "size" modify $ S.insert v - pure $ NamedDim $ qualName v - onDim (NamedDim d) = do + pure $ NamedSize $ qualName v + onDim (NamedSize d) = do unless (qualLeaf d `S.member` bound) $ - modify $ S.insert $ qualLeaf d - pure $ NamedDim d + modify $ + S.insert $ + qualLeaf d + pure $ NamedSize d onDim d = pure d unRetType :: StructRetType -> StructType unRetType (RetType [] t) = t unRetType (RetType ext t) = first onDim t where - onDim (NamedDim d) | qualLeaf d `elem` ext = AnyDim Nothing + onDim (NamedSize d) | qualLeaf d `elem` ext = AnySize Nothing onDim d = d -- | Defunctionalize an application expression at a given depth of application. @@ -844,7 +850,8 @@ rettype = buildRetType closure_env params_for_rettype (unRetType e0_t) $ typeOf e0' already_bound = - globals <> S.fromList dims + globals + <> S.fromList dims <> S.map identName (foldMap patIdents params) more_dims = @@ -861,7 +868,7 @@ liftedName (i + 1) f liftedName _ _ = "defunc" - -- Ensure that no parameter sizes are AnyDim. The internaliser + -- Ensure that no parameter sizes are AnySize. The internaliser -- expects this. This is easy, because they are all -- first-order. let bound_sizes = S.fromList (dims <> more_dims) <> globals @@ -883,7 +890,8 @@ fname' ( Info ( Scalar . Arrow mempty Unnamed t1 . RetType [] $ - Scalar . Arrow mempty Unnamed t2 $ RetType [] rettype + Scalar . Arrow mempty Unnamed t2 $ + RetType [] rettype ) ) loc @@ -967,7 +975,7 @@ (argtypes', rettype) = dynamicFunType sv' argtypes dims' = mempty - -- Ensure that no parameter sizes are AnyDim. The internaliser + -- Ensure that no parameter sizes are AnySize. The internaliser -- expects this. This is easy, because they are all -- first-order. globals <- asks fst @@ -1046,7 +1054,7 @@ mkExt v | not $ v `S.member` bound_here = Just v mkExt _ = Nothing - rettype_st = RetType (mapMaybe mkExt (S.toList (typeDimNames ret)) ++ ret_dims) ret + rettype_st = RetType (mapMaybe mkExt (S.toList (freeInType ret)) ++ ret_dims) ret dec = ValBind @@ -1089,7 +1097,9 @@ S.fromList (M.keys env) <> S.map identName (foldMap patIdents pats) boundAsUnique v = maybe False (unique . unInfo . identType) $ - find ((== v) . identName) $ S.toList $ foldMap patIdents 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 @@ -1154,7 +1164,7 @@ else dim_env <> M.singleton vn (Binding Nothing sv) where dim_env = - M.fromList $ map (,i64) $ S.toList $ typeDimNames t + M.fromList $ map (,i64) $ S.toList $ freeInType t i64 = Binding Nothing $ Dynamic $ Scalar $ Prim $ Signed Int64 matchPatSV (Wildcard _ _) _ = mempty matchPatSV (PatAscription pat _ _) sv = matchPatSV pat sv @@ -1174,7 +1184,8 @@ matchPatSV pat (Dynamic t) = matchPatSV pat $ svFromType t matchPatSV pat sv = error $ - "Tried to match pattern " ++ pretty pat + "Tried to match pattern " + ++ pretty pat ++ " with static value " ++ show sv ++ "." @@ -1226,7 +1237,8 @@ updatePat pat (Dynamic t) = updatePat pat (svFromType t) updatePat pat sv = error $ - "Tried to update pattern " ++ pretty pat + "Tried to update pattern " + ++ pretty pat ++ "to reflect the static value " ++ show sv @@ -1260,7 +1272,8 @@ defuncValBind valbind@(ValBind _ name retdecl (Info (RetType ret_dims rettype)) tparams params body _ _ _) = do when (any isTypeParam tparams) $ error $ - prettyName name ++ " has type parameters, " + prettyName name + ++ " has type parameters, " ++ "but the defunctionaliser expects a monomorphic input program." (tparams', params', body', sv) <- defuncLet (map typeParamName tparams) params body $ RetType ret_dims rettype @@ -1272,7 +1285,7 @@ -- applications of lifted functions, we don't properly update -- the types in the return type annotation. combineTypeShapes rettype $ first (anyDimIfNotBound bound_sizes) $ toStruct $ typeOf body' - ret_dims' = filter (`S.member` typeDimNames rettype') ret_dims + ret_dims' = filter (`S.member` freeInType rettype') ret_dims (missing_dims, params'') <- sizesForAll bound_sizes params' pure @@ -1294,8 +1307,8 @@ sv ) where - anyDimIfNotBound bound_sizes (NamedDim v) - | qualLeaf v `S.notMember` bound_sizes = AnyDim $ Just $ qualLeaf v + anyDimIfNotBound bound_sizes (NamedSize v) + | qualLeaf v `S.notMember` bound_sizes = AnySize $ Just $ qualLeaf v anyDimIfNotBound _ d = d -- | Defunctionalize a list of top-level declarations. 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 @@ -255,8 +255,6 @@ { mapOnExp = onExp scope, mapOnName = \v -> pure $ qualLeaf $ fst $ lookupSubstInScope (qualName v) scope, - mapOnQualName = \v -> - pure $ fst $ lookupSubstInScope v scope, mapOnStructType = astMap (substituter scope), mapOnPatType = astMap (substituter scope), mapOnStructRetType = astMap (substituter scope), @@ -281,21 +279,32 @@ transformExp :: Exp -> TransformM Exp transformExp = transformNames +transformEntry :: EntryPoint -> TransformM EntryPoint +transformEntry (EntryPoint params ret) = + EntryPoint <$> mapM onEntryParam params <*> onEntryType ret + where + onEntryParam (EntryParam v t) = + EntryParam v <$> onEntryType t + onEntryType (EntryType t te) = + EntryType <$> transformStructType t <*> pure te + transformValBind :: ValBind -> TransformM () transformValBind (ValBind entry name tdecl (Info (RetType dims t)) tparams params e doc attrs loc) = do + entry' <- traverse (traverse transformEntry) entry name' <- transformName name tdecl' <- traverse transformTypeExp tdecl t' <- transformStructType t e' <- transformExp e tparams' <- traverse transformNames tparams params' <- traverse transformNames params - emit $ ValDec $ ValBind entry name' tdecl' (Info (RetType dims t')) tparams' params' e' doc attrs loc + emit $ ValDec $ ValBind entry' name' tdecl' (Info (RetType dims t')) tparams' params' e' doc attrs loc transformTypeBind :: TypeBind -> TransformM () transformTypeBind (TypeBind name l tparams te (Info (RetType dims t)) doc loc) = do name' <- transformName name emit . TypeDec - =<< ( TypeBind name' l <$> traverse transformNames tparams + =<< ( TypeBind name' l + <$> traverse transformNames tparams <*> transformTypeExp te <*> (Info . RetType dims <$> transformStructType t) <*> pure doc @@ -306,11 +315,11 @@ transformModBind mb = do let addParam p me = ModLambda p Nothing me $ srclocOf me mod <- - evalModExp $ - foldr + evalModExp + $ foldr addParam (maybeAscript (srclocOf mb) (modSignature mb) $ modExp mb) - $ modParams mb + $ modParams mb mname <- transformName $ modName mb pure $ Scope (scopeSubsts $ modScope mod) $ M.singleton mname mod @@ -348,7 +357,10 @@ let abs = S.fromList $ map qualLeaf $ M.keys $ fileAbs imp scope <- censor (fmap maybeHideEntryPoint) $ - bindingAbs abs $ transformDecs $ progDecs $ fileProg imp + bindingAbs abs $ + transformDecs $ + progDecs $ + fileProg imp bindingAbs abs $ bindingImport name scope $ transformImports imps where -- Only the "main" file (last import) is allowed to have entry points. diff --git a/src/Futhark/Internalise/Entry.hs b/src/Futhark/Internalise/Entry.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Internalise/Entry.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | Generating metadata so that programs can run at all. +module Futhark.Internalise.Entry + ( entryPoint, + VisibleTypes, + visibleTypes, + ) +where + +import Control.Monad.State +import Data.List (find) +import qualified Data.Map as M +import Data.String (fromString) +import qualified Futhark.IR as I +import Futhark.Internalise.TypesValues (internalisedTypeSize) +import Futhark.Util.Pretty (prettyOneLine) +import qualified Language.Futhark as E hiding (TypeArg) +import Language.Futhark.Core (Name, Uniqueness (..), VName) +import qualified Language.Futhark.Semantic as E + +-- | The types that are visible to the outside world. +newtype VisibleTypes = VisibleTypes [E.TypeBind] + +-- | Retrieve those type bindings that should be visible to the +-- outside world. Currently that is everything at top level that does +-- not have type parameters. +visibleTypes :: E.Imports -> VisibleTypes +visibleTypes = VisibleTypes . foldMap (modTypes . snd) + where + modTypes = progTypes . E.fileProg + progTypes = foldMap decTypes . E.progDecs + decTypes (E.TypeDec tb) = [tb] + decTypes _ = [] + +findType :: VName -> VisibleTypes -> Maybe (E.TypeExp VName) +findType v (VisibleTypes ts) = E.typeExp <$> find ((== v) . E.typeAlias) ts + +valueType :: I.TypeBase I.Rank Uniqueness -> I.ValueType +valueType (I.Prim pt) = I.ValueType I.Signed (I.Rank 0) pt +valueType (I.Array pt rank _) = I.ValueType I.Signed rank pt +valueType I.Acc {} = error "valueType Acc" +valueType I.Mem {} = error "valueType Mem" + +withoutDims :: E.TypeExp VName -> (Int, E.TypeExp VName) +withoutDims (E.TEArray _ te _) = + let (d, te') = withoutDims te + in (d + 1, te') +withoutDims te = (0 :: Int, te) + +rootType :: E.TypeExp VName -> E.TypeExp VName +rootType (E.TEApply te E.TypeArgExpDim {} _) = rootType te +rootType (E.TEUnique te _) = rootType te +rootType te = te + +typeExpOpaqueName :: E.TypeExp VName -> String +typeExpOpaqueName = f . rootType + where + f (E.TEArray _ te _) = + let (d, te') = withoutDims te + in "arr_" <> typeExpOpaqueName te' <> "_" <> show (1 + d) <> "d" + f te = fromString $ prettyOneLine te + +type GenOpaque = State I.OpaqueTypes + +runGenOpaque :: GenOpaque a -> (a, I.OpaqueTypes) +runGenOpaque = flip runState mempty + +addType :: String -> I.OpaqueType -> GenOpaque () +addType s t = modify (<> I.OpaqueTypes [(s, t)]) + +isRecord :: VisibleTypes -> E.TypeExp VName -> Maybe (M.Map Name (E.TypeExp VName)) +isRecord _ (E.TERecord fs _) = Just $ M.fromList fs +isRecord _ (E.TETuple fs _) = Just $ E.tupleFields fs +isRecord types (E.TEVar v _) = isRecord types =<< findType (E.qualLeaf v) types +isRecord _ _ = Nothing + +recordFields :: + VisibleTypes -> + M.Map Name E.StructType -> + Maybe (E.TypeExp VName) -> + [(Name, E.EntryType)] +recordFields types fs t = + case isRecord types . rootType =<< t of + Just e_fs -> + zipWith f (E.sortFields fs) (E.sortFields e_fs) + where + f (k, f_t) (_, e_f_t) = (k, E.EntryType f_t $ Just e_f_t) + Nothing -> + map (fmap (`E.EntryType` Nothing)) $ E.sortFields fs + +opaqueRecord :: + VisibleTypes -> + [(Name, E.EntryType)] -> + [I.TypeBase I.Rank Uniqueness] -> + GenOpaque [(Name, I.EntryPointType)] +opaqueRecord _ [] _ = pure [] +opaqueRecord types ((f, t) : fs) ts = do + let (f_ts, ts') = splitAt (internalisedTypeSize $ E.entryType t) ts + f' <- opaqueField t f_ts + ((f, f') :) <$> opaqueRecord types fs ts' + where + opaqueField e_t i_ts = snd <$> entryPointType types e_t i_ts + +entryPointType :: + VisibleTypes -> + E.EntryType -> + [I.TypeBase I.Rank Uniqueness] -> + GenOpaque (Uniqueness, I.EntryPointType) +entryPointType types t ts + | E.Scalar (E.Prim E.Unsigned {}) <- E.entryType t, + [I.Prim ts0] <- ts = + pure (u, I.TypeTransparent $ I.ValueType I.Unsigned (I.Rank 0) ts0) + | E.Array _ _ _ (E.Prim E.Unsigned {}) <- E.entryType t, + [I.Array ts0 r _] <- ts = + pure (u, I.TypeTransparent $ I.ValueType I.Unsigned r ts0) + | E.Scalar E.Prim {} <- E.entryType t, + [I.Prim ts0] <- ts = + pure (u, I.TypeTransparent $ I.ValueType I.Signed (I.Rank 0) ts0) + | E.Array _ _ _ E.Prim {} <- E.entryType t, + [I.Array ts0 r _] <- ts = + pure (u, I.TypeTransparent $ I.ValueType I.Signed r ts0) + | otherwise = do + case E.entryType t of + E.Scalar (E.Record fs) + | not $ null fs -> + let fs' = recordFields types fs $ E.entryAscribed t + in addType desc . I.OpaqueRecord =<< opaqueRecord types fs' ts + _ -> addType desc $ I.OpaqueType $ map valueType ts + pure (u, I.TypeOpaque desc) + where + u = foldl max Nonunique $ map I.uniqueness ts + desc = + maybe (fromString $ prettyOneLine t') typeExpOpaqueName $ + E.entryAscribed t + t' = E.noSizes (E.entryType t) `E.setUniqueness` Nonunique + +entryPoint :: + VisibleTypes -> + Name -> + [(E.EntryParam, [I.Param I.DeclType])] -> + ( E.EntryType, + [[I.TypeBase I.Rank I.Uniqueness]] + ) -> + (I.EntryPoint, I.OpaqueTypes) +entryPoint types name params (eret, crets) = + runGenOpaque $ + (name,,) + <$> mapM onParam params + <*> ( map (uncurry I.EntryResult) + <$> case ( E.isTupleRecord $ E.entryType eret, + E.entryAscribed eret + ) of + (Just ts, Just (E.TETuple e_ts _)) -> + zipWithM (entryPointType types) (zipWith E.EntryType ts (map Just e_ts)) crets + (Just ts, Nothing) -> + zipWithM (entryPointType types) (map (`E.EntryType` Nothing) ts) crets + _ -> + pure <$> entryPointType types eret (concat crets) + ) + where + onParam (E.EntryParam e_p e_t, ps) = + uncurry (I.EntryParam e_p) + <$> entryPointType types e_t (map (I.rankShaped . I.paramDeclType) ps) 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 @@ -17,31 +17,32 @@ import Futhark.IR.SOACS as I hiding (stmPat) import Futhark.Internalise.AccurateSizes import Futhark.Internalise.Bindings +import Futhark.Internalise.Entry import Futhark.Internalise.Lambdas import Futhark.Internalise.Monad as I import Futhark.Internalise.TypesValues import Futhark.Transform.Rename as I import Futhark.Util (splitAt3) -import Futhark.Util.Pretty (align, ppr, prettyOneLine) +import Futhark.Util.Pretty (align, ppr) import Language.Futhark as E hiding (TypeArg) -- | Convert a program in source Futhark to a program in the Futhark -- core language. -transformProg :: MonadFreshNames m => Bool -> [E.ValBind] -> m (I.Prog SOACS) -transformProg always_safe vbinds = do - (consts, funs) <- - runInternaliseM always_safe (internaliseValBinds vbinds) - I.renameProg $ I.Prog consts funs +transformProg :: MonadFreshNames m => Bool -> VisibleTypes -> [E.ValBind] -> m (I.Prog SOACS) +transformProg always_safe types vbinds = do + (opaques, consts, funs) <- + runInternaliseM always_safe (internaliseValBinds types vbinds) + I.renameProg $ I.Prog opaques consts funs -internaliseValBinds :: [E.ValBind] -> InternaliseM () -internaliseValBinds = mapM_ internaliseValBind +internaliseValBinds :: VisibleTypes -> [E.ValBind] -> InternaliseM () +internaliseValBinds types = mapM_ $ internaliseValBind types internaliseFunName :: VName -> Name internaliseFunName = nameFromString . pretty -internaliseValBind :: E.ValBind -> InternaliseM () -internaliseValBind fb@(E.ValBind entry fname retdecl (Info rettype) tparams params body _ attrs loc) = do - localConstsScope . bindingFParams tparams params $ \shapeparams params' -> do +internaliseValBind :: VisibleTypes -> E.ValBind -> InternaliseM () +internaliseValBind types fb@(E.ValBind entry fname retdecl (Info rettype) tparams params body _ attrs loc) = do + bindingFParams tparams params $ \shapeparams params' -> do let shapenames = map I.paramName shapeparams msg <- case retdecl of @@ -54,7 +55,7 @@ (body', rettype') <- buildBody $ do body_res <- internaliseExp (baseString fname <> "_res") body rettype' <- - fmap zeroExts . internaliseReturnType rettype =<< mapM subExpType body_res + zeroExts . internaliseReturnType rettype <$> mapM subExpType body_res body_res' <- ensureResultExtShape msg loc (map I.fromDecl rettype') $ subExpsRes body_res pure @@ -88,19 +89,26 @@ ) case entry of - Just (Info entry') -> generateEntryPoint entry' fb + Just (Info entry') -> generateEntryPoint types entry' fb Nothing -> pure () where zeroExts ts = generaliseExtTypes ts ts -generateEntryPoint :: E.EntryPoint -> E.ValBind -> InternaliseM () -generateEntryPoint (E.EntryPoint e_params e_rettype) vb = localConstsScope $ do +generateEntryPoint :: VisibleTypes -> E.EntryPoint -> E.ValBind -> InternaliseM () +generateEntryPoint types (E.EntryPoint e_params e_rettype) vb = do let (E.ValBind _ ofname _ (Info rettype) tparams params _ _ attrs loc) = vb bindingFParams tparams params $ \shapeparams params' -> do - entry_rettype <- internaliseEntryReturnType rettype - let entry' = entryPoint (baseName ofname) (zip e_params params') (e_rettype, entry_rettype) + let entry_rettype = internaliseEntryReturnType rettype + (entry', opaques) = + entryPoint + types + (baseName ofname) + (zip e_params params') + (e_rettype, map (map I.rankShaped) entry_rettype) args = map (I.Var . I.paramName) $ concat params' + addOpaques opaques + (entry_body, ctx_ts) <- buildBody $ do -- Special case the (rare) situation where the entry point is -- not a function. @@ -127,67 +135,6 @@ where zeroExts ts = generaliseExtTypes ts ts -entryPoint :: - Name -> - [(E.EntryParam, [I.FParam SOACS])] -> - ( E.EntryType, - [[I.TypeBase ExtShape Uniqueness]] - ) -> - I.EntryPoint -entryPoint name params (eret, crets) = - ( name, - map onParam params, - case ( isTupleRecord $ entryType eret, - entryAscribed eret - ) of - (Just ts, Just (E.TETuple e_ts _)) -> - zipWith - entryPointType - (zipWith E.EntryType ts (map Just e_ts)) - crets - (Just ts, Nothing) -> - zipWith - entryPointType - (map (`E.EntryType` Nothing) ts) - crets - _ -> - [entryPointType eret $ concat crets] - ) - where - onParam (E.EntryParam e_p e_t, ps) = - I.EntryParam e_p $ entryPointType e_t $ staticShapes $ map I.paramDeclType ps - - entryPointType t ts - | E.Scalar (E.Prim E.Unsigned {}) <- E.entryType t = - I.TypeUnsigned u - | E.Array _ _ _ (E.Prim E.Unsigned {}) <- E.entryType t = - I.TypeUnsigned u - | E.Scalar E.Prim {} <- E.entryType t = - I.TypeDirect u - | E.Array _ _ _ E.Prim {} <- E.entryType t = - I.TypeDirect u - | otherwise = - I.TypeOpaque u desc $ length ts - where - u = foldl max Nonunique $ map I.uniqueness ts - desc = maybe (prettyOneLine t') typeExpOpaqueName $ E.entryAscribed t - t' = noSizes (E.entryType t) `E.setUniqueness` Nonunique - typeExpOpaqueName (TEApply te TypeArgExpDim {} _) = - typeExpOpaqueName te - typeExpOpaqueName (TEArray _ te _) = - let (d, te') = withoutDims te - in "arr_" ++ typeExpOpaqueName te' - ++ "_" - ++ show (1 + d) - ++ "d" - typeExpOpaqueName (TEUnique te _) = prettyOneLine te - typeExpOpaqueName te = prettyOneLine te - - withoutDims (TEArray _ te _) = - let (d, te') = withoutDims te - in (d + 1, te') - withoutDims te = (0 :: Int, te) - internaliseBody :: String -> E.Exp -> InternaliseM (Body SOACS) internaliseBody desc e = buildBody_ $ subExpsRes <$> internaliseExp (desc <> "_res") e @@ -277,7 +224,8 @@ Just second' -> do subtracted_step <- letSubExp "subtracted_step" $ - I.BasicOp $ I.BinOp (I.Sub it I.OverflowWrap) second' start' + I.BasicOp $ + I.BinOp (I.Sub it I.OverflowWrap) second' start' step_zero <- letSubExp "step_zero" $ I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) start' second' pure (subtracted_step, step_zero) Nothing -> @@ -288,53 +236,61 @@ bounds_invalid_downwards <- letSubExp "bounds_invalid_downwards" $ - I.BasicOp $ I.CmpOp le_op start' end' + I.BasicOp $ + I.CmpOp le_op start' end' bounds_invalid_upwards <- letSubExp "bounds_invalid_upwards" $ - I.BasicOp $ I.CmpOp lt_op end' start' + I.BasicOp $ + I.CmpOp lt_op end' start' (distance, step_wrong_dir, bounds_invalid) <- case end of DownToExclusive {} -> do step_wrong_dir <- letSubExp "step_wrong_dir" $ - I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign one + I.BasicOp $ + I.CmpOp (I.CmpEq $ IntType it) step_sign one distance <- letSubExp "distance" $ - I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) start' end' + I.BasicOp $ + I.BinOp (Sub it I.OverflowWrap) start' end' distance_i64 <- asIntS Int64 distance pure (distance_i64, step_wrong_dir, bounds_invalid_downwards) UpToExclusive {} -> do step_wrong_dir <- letSubExp "step_wrong_dir" $ - I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign negone + I.BasicOp $ + I.CmpOp (I.CmpEq $ IntType it) step_sign negone distance <- letSubExp "distance" $ I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) end' start' distance_i64 <- asIntS Int64 distance pure (distance_i64, step_wrong_dir, bounds_invalid_upwards) ToInclusive {} -> do downwards <- letSubExp "downwards" $ - I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign negone + I.BasicOp $ + I.CmpOp (I.CmpEq $ IntType it) step_sign negone distance_downwards_exclusive <- letSubExp "distance_downwards_exclusive" $ - I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) start' end' + I.BasicOp $ + I.BinOp (Sub it I.OverflowWrap) start' end' distance_upwards_exclusive <- letSubExp "distance_upwards_exclusive" $ - I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) end' start' + I.BasicOp $ + I.BinOp (Sub it I.OverflowWrap) end' start' bounds_invalid <- - letSubExp "bounds_invalid" $ - I.If + letSubExp "bounds_invalid" + $ I.If downwards (resultBody [bounds_invalid_downwards]) (resultBody [bounds_invalid_upwards]) - $ ifCommon [I.Prim I.Bool] + $ ifCommon [I.Prim I.Bool] distance_exclusive <- - letSubExp "distance_exclusive" $ - I.If + letSubExp "distance_exclusive" + $ I.If downwards (resultBody [distance_downwards_exclusive]) (resultBody [distance_upwards_exclusive]) - $ ifCommon [I.Prim $ IntType it] + $ ifCommon [I.Prim $ IntType it] distance_exclusive_i64 <- asIntS Int64 distance_exclusive distance <- letSubExp "distance" $ @@ -347,29 +303,33 @@ step_invalid <- letSubExp "step_invalid" $ - I.BasicOp $ I.BinOp I.LogOr step_wrong_dir step_zero + I.BasicOp $ + I.BinOp I.LogOr step_wrong_dir step_zero invalid <- letSubExp "range_invalid" $ - I.BasicOp $ I.BinOp I.LogOr step_invalid bounds_invalid + I.BasicOp $ + I.BinOp I.LogOr step_invalid bounds_invalid valid <- letSubExp "valid" $ I.BasicOp $ I.UnOp I.Not invalid cs <- assert "range_valid_c" valid errmsg loc step_i64 <- asIntS Int64 step pos_step <- letSubExp "pos_step" $ - I.BasicOp $ I.BinOp (Mul Int64 I.OverflowWrap) step_i64 step_sign_i64 + I.BasicOp $ + I.BinOp (Mul Int64 I.OverflowWrap) step_i64 step_sign_i64 num_elems <- certifying cs $ letSubExp "num_elems" $ - I.BasicOp $ I.BinOp (SDivUp Int64 I.Unsafe) distance pos_step + I.BasicOp $ + I.BinOp (SDivUp Int64 I.Unsafe) distance pos_step se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it) pure [se] internaliseAppExp desc (E.AppRes et ext) (E.Coerce e dt loc) = do ses <- internaliseExp desc e - ts <- internaliseReturnType (E.RetType ext (E.toStruct et)) =<< mapM subExpType ses + ts <- internaliseReturnType (E.RetType ext (E.toStruct et)) <$> mapM subExpType ses dt' <- typeExpForError dt forM (zip ses ts) $ \(e', t') -> do dims <- arrayDims <$> subExpType e' @@ -545,7 +505,9 @@ loop_end_cond_body <- renameBody <=< buildBody_ $ do forM_ (zip shapepat shapeargs) $ \(p, se) -> unless (se == I.Var (paramName p)) $ - letBindNames [paramName p] $ BasicOp $ SubExp se + letBindNames [paramName p] $ + BasicOp $ + SubExp se forM_ (zip mergepat' ses) $ \(p, se) -> unless (se == I.Var (paramName p)) $ letBindNames [paramName p] $ @@ -586,7 +548,8 @@ (_, pertinent) <- generateCond pLast ses eLast' <- internalisePat' [] pLast pertinent eLast (internaliseBody desc) foldM (\bf c' -> eValBody $ pure $ generateCaseIf ses c' bf) eLast' $ - reverse $ NE.init cs' + reverse $ + NE.init cs' letValExp' desc =<< generateCaseIf ses c bFalse internaliseAppExp desc _ (E.If ce te fe _) = letValExp' desc @@ -602,8 +565,8 @@ internaliseExp desc e internaliseExp desc (E.Hole (Info t) loc) = do let msg = pretty $ "Reached hole of type: " <> align (ppr t) + ts = internaliseType (E.toStruct t) c <- assert "hole_c" (constant False) (errorMsg [ErrorString msg]) loc - ts <- internaliseType (E.toStruct t) case mapM hasStaticShape ts of Nothing -> error $ "Hole at " <> locStr loc <> " has existential type:\n" <> show ts @@ -614,7 +577,9 @@ internaliseExp desc e internaliseExp desc (E.StringLit vs _) = fmap pure . letSubExp desc $ - I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8 + I.BasicOp $ + I.ArrayLit (map constant vs) $ + I.Prim int8 internaliseExp _ (E.Var (E.QualName _ name) _ _) = do subst <- lookupSubst name case subst of @@ -666,7 +631,7 @@ letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr | otherwise = do es' <- mapM (internaliseExp "arr_elem") es - arr_t_ext <- internaliseType $ E.toStruct arr_t + let arr_t_ext = internaliseType $ E.toStruct arr_t rowtypes <- case mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext of @@ -754,12 +719,12 @@ where replace (E.Scalar (E.Record m)) (f : fs) ve' src' | Just t <- M.lookup f m = do - i <- - fmap sum $ - mapM (internalisedTypeSize . snd) $ - takeWhile ((/= f) . fst) $ sortFields m - k <- internalisedTypeSize t - let (bef, to_update, aft) = splitAt3 i k src' + let i = + sum . map (internalisedTypeSize . snd) $ + takeWhile ((/= f) . fst) . sortFields $ + m + k = internalisedTypeSize t + (bef, to_update, aft) = splitAt3 i k src' src'' <- replace t fs ve' to_update pure $ bef ++ src'' ++ aft replace _ _ ve' _ = pure ve' @@ -838,14 +803,13 @@ -- Builtin operators are handled specially because they are -- overloaded. internaliseExp desc (E.Project k e (Info rt) _) = do - n <- internalisedTypeSize $ rt `setAliases` () - i' <- fmap sum $ - mapM internalisedTypeSize $ - case E.typeOf e `setAliases` () of - E.Scalar (Record fs) -> - map snd $ takeWhile ((/= k) . fst) $ sortFields fs - t -> [t] - take n . drop i' <$> internaliseExp desc e + let i' = sum . map internalisedTypeSize $ + case E.typeOf e `setAliases` () of + E.Scalar (Record fs) -> + map snd $ takeWhile ((/= k) . fst) $ sortFields fs + t -> [t] + take (internalisedTypeSize $ rt `setAliases` ()) . drop i' + <$> internaliseExp desc e internaliseExp _ e@E.Lambda {} = error $ "internaliseExp: Unexpected lambda at " ++ locStr (srclocOf e) internaliseExp _ e@E.OpSection {} = @@ -906,8 +870,7 @@ 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 + let (id_ses, rest_ses) = splitAt (internalisedTypeSize $ E.toStruct t) ses pure ([], id_ses, rest_ses) compares (E.PatParens pat _) ses = compares pat ses @@ -984,7 +947,8 @@ ok <- letSubExp "index_ok" =<< eAll oks let msg = errorMsg $ - ["Index ["] ++ intercalate [", "] parts + ["Index ["] + ++ intercalate [", "] parts ++ ["] out of bounds for array of shape ["] ++ intersperse "][" (map (ErrorVal int64) $ take (length idxs) dims) ++ ["]."] @@ -996,7 +960,7 @@ E.DimIndex -> InternaliseM (I.DimIndex SubExp, SubExp, [ErrorMsgPart SubExp]) internaliseDimIndex w (E.DimFix i) = do - (i', _) <- internaliseDimExp "i" i + (i', _) <- internaliseSizeExp "i" i let lowerBound = I.BasicOp $ I.CmpOp (I.CmpSle I.Int64) (I.constant (0 :: I.Int64)) i' upperBound = @@ -1014,7 +978,8 @@ ) = do w_minus_1 <- letSubExp "w_minus_1" $ - BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) w one + BasicOp $ + I.BinOp (Sub Int64 I.OverflowWrap) w one pure ( I.DimSlice w_minus_1 w $ intConst Int64 (-1), constant True, @@ -1023,26 +988,26 @@ where one = constant (1 :: Int64) internaliseDimIndex w (E.DimSlice i j s) = do - s' <- maybe (pure one) (fmap fst . internaliseDimExp "s") s + s' <- maybe (pure one) (fmap fst . internaliseSizeExp "s") s s_sign <- letSubExp "s_sign" $ BasicOp $ I.UnOp (I.SSignum Int64) s' backwards <- letSubExp "backwards" $ I.BasicOp $ I.CmpOp (I.CmpEq int64) s_sign negone w_minus_1 <- letSubExp "w_minus_1" $ BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) w one let i_def = - letSubExp "i_def" $ - I.If + letSubExp "i_def" + $ I.If backwards (resultBody [w_minus_1]) (resultBody [zero]) - $ ifCommon [I.Prim int64] + $ ifCommon [I.Prim int64] j_def = - letSubExp "j_def" $ - I.If + letSubExp "j_def" + $ I.If backwards (resultBody [negone]) (resultBody [w]) - $ ifCommon [I.Prim int64] - i' <- maybe i_def (fmap fst . internaliseDimExp "i") i - j' <- maybe j_def (fmap fst . internaliseDimExp "j") j + $ ifCommon [I.Prim int64] + i' <- maybe i_def (fmap fst . internaliseSizeExp "i") i + j' <- maybe j_def (fmap fst . internaliseSizeExp "j") j j_m_i <- letSubExp "j_m_i" $ BasicOp $ I.BinOp (Sub Int64 I.OverflowWrap) j' i' -- Something like a division-rounding-up, but accomodating negative -- operands. @@ -1071,13 +1036,16 @@ i_p_m_t_s <- letSubExp "i_p_m_t_s" $ I.BasicOp $ I.BinOp (Add Int64 I.OverflowWrap) i' m_t_s zero_leq_i_p_m_t_s <- letSubExp "zero_leq_i_p_m_t_s" $ - I.BasicOp $ I.CmpOp (I.CmpSle Int64) zero i_p_m_t_s + I.BasicOp $ + I.CmpOp (I.CmpSle Int64) zero i_p_m_t_s i_p_m_t_s_leq_w <- letSubExp "i_p_m_t_s_leq_w" $ - I.BasicOp $ I.CmpOp (I.CmpSle Int64) i_p_m_t_s w + I.BasicOp $ + I.CmpOp (I.CmpSle Int64) i_p_m_t_s w i_p_m_t_s_lth_w <- letSubExp "i_p_m_t_s_leq_w" $ - I.BasicOp $ I.CmpOp (I.CmpSlt Int64) i_p_m_t_s w + I.BasicOp $ + I.CmpOp (I.CmpSlt Int64) i_p_m_t_s w zero_lte_i <- letSubExp "zero_lte_i" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) zero i' i_lte_j <- letSubExp "i_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) i' j' @@ -1093,20 +1061,22 @@ [negone_lte_j, negone_lte_j, j_lte_i, zero_leq_i_p_m_t_s, i_p_m_t_s_leq_w] slice_ok <- - letSubExp "slice_ok" $ - I.If + letSubExp "slice_ok" + $ I.If backwards (resultBody [backwards_ok]) (resultBody [forwards_ok]) - $ ifCommon [I.Prim I.Bool] + $ ifCommon [I.Prim I.Bool] ok_or_empty <- letSubExp "ok_or_empty" $ - I.BasicOp $ I.BinOp I.LogOr empty_slice slice_ok + I.BasicOp $ + I.BinOp I.LogOr empty_slice slice_ok acceptable <- letSubExp "slice_acceptable" $ - I.BasicOp $ I.BinOp I.LogAnd nonzero_stride ok_or_empty + I.BasicOp $ + I.BinOp I.LogAnd nonzero_stride ok_or_empty let parts = case (i, j, s) of (_, _, Just {}) -> @@ -1200,7 +1170,7 @@ =<< bodyBind body -- get sizes of histogram and image arrays - shape_hist <- Shape . take dim . I.arrayDims <$> lookupType (head hist') + shape_hist <- I.Shape . take dim . I.arrayDims <$> lookupType (head hist') w_img <- I.arraySize 0 <$> lookupType (head img') letValExp' desc . I.Op $ @@ -1238,11 +1208,14 @@ -- Synthesize neutral elements by applying the fold function -- to an empty chunk. letBindNames [I.paramName chunk_param] $ - I.BasicOp $ I.SubExp $ constant (0 :: Int64) + I.BasicOp $ + I.SubExp $ + constant (0 :: Int64) forM_ lam_val_params $ \p -> letBindNames [I.paramName p] $ I.BasicOp . I.Scratch (I.elemType $ I.paramType p) $ - I.arrayDims $ I.paramType p + I.arrayDims $ + I.paramType p nes <- bodyBind =<< renameBody lam_body nes_ts <- mapM I.subExpResType nes @@ -1293,15 +1266,15 @@ acc_cert_v <- newVName "acc_cert" dest_ts <- mapM lookupType dest' let dest_w = arraysSize 0 dest_ts - acc_t = Acc acc_cert_v (Shape [dest_w]) (map rowType dest_ts) NoUniqueness + acc_t = Acc acc_cert_v (I.Shape [dest_w]) (map rowType dest_ts) NoUniqueness acc_p <- newParam "acc_p" acc_t withacc_lam <- mkLambda [Param mempty acc_cert_v (I.Prim I.Unit), acc_p] $ do - lam' <- - internaliseMapLambda internaliseLambda lam $ - map I.Var $ paramName acc_p : bs' - w <- arraysSize 0 <$> mapM lookupType bs' + bs_ts <- mapM lookupType bs' + lam' <- internaliseLambdaCoerce lam $ map rowType $ paramType acc_p : bs_ts + let w = arraysSize 0 bs_ts fmap subExpsRes . letValExp' "acc_res" $ - I.Op $ I.Screma w (paramName acc_p : bs') (I.mapSOAC lam') + I.Op $ + I.Screma w (paramName acc_p : bs') (I.mapSOAC lam') op' <- case op of @@ -1318,7 +1291,8 @@ destw <- arraysSize 0 <$> mapM lookupType dest' fmap (map I.Var) $ - letTupExp desc $ WithAcc [(Shape [destw], dest', op')] withacc_lam + letTupExp desc $ + WithAcc [(I.Shape [destw], dest', op')] withacc_lam internaliseExp1 :: String -> E.Exp -> InternaliseM I.SubExp internaliseExp1 desc e = do @@ -1329,12 +1303,12 @@ -- | Promote to dimension type as appropriate for the original type. -- Also return original type. -internaliseDimExp :: String -> E.Exp -> InternaliseM (I.SubExp, IntType) -internaliseDimExp s e = do +internaliseSizeExp :: String -> E.Exp -> InternaliseM (I.SubExp, IntType) +internaliseSizeExp s e = do e' <- internaliseExp1 s e case E.typeOf e of - E.Scalar (E.Prim (Signed it)) -> (,it) <$> asIntS Int64 e' - _ -> error "internaliseDimExp: bad type" + E.Scalar (E.Prim (E.Signed it)) -> (,it) <$> asIntS Int64 e' + _ -> error "internaliseSizeExp: bad type" internaliseExpToVars :: String -> E.Exp -> InternaliseM [I.VName] internaliseExpToVars desc e = @@ -1503,7 +1477,8 @@ simpleCmpOp desc I.CmpLle y x -- Note the swapped x and y internaliseBinOp _ _ op _ _ t1 t2 = error $ - "Invalid binary operator " ++ pretty op + "Invalid binary operator " + ++ pretty op ++ " with operand types " ++ pretty t1 ++ ", " @@ -1563,6 +1538,16 @@ pure (params', body', rettype') internaliseLambda e _ = error $ "internaliseLambda: unexpected expression:\n" ++ pretty e +internaliseLambdaCoerce :: E.Exp -> [Type] -> InternaliseM (I.Lambda SOACS) +internaliseLambdaCoerce lam argtypes = do + (params, body, rettype) <- internaliseLambda lam argtypes + mkLambda params $ + ensureResultShape + (ErrorMsg [ErrorString "unexpected lambda result size"]) + (srclocOf lam) + rettype + =<< bodyBind body + -- | Some operators and functions are overloaded or otherwise special -- - we detect and treat them here. isOverloadedFunction :: @@ -1688,11 +1673,10 @@ handleSOACs [TupLit [lam, arr] _] "map" = Just $ \desc -> do arr' <- internaliseExpToVars "map_arr" arr - lam' <- internaliseMapLambda internaliseLambda lam $ map I.Var arr' - w <- arraysSize 0 <$> mapM lookupType arr' - letTupExp' desc $ - I.Op $ - I.Screma w arr' (I.mapSOAC lam') + arr_ts <- mapM lookupType arr' + lam' <- internaliseLambdaCoerce lam $ map rowType arr_ts + let w = arraysSize 0 arr_ts + letTupExp' desc $ I.Op $ I.Screma w arr' (I.mapSOAC lam') handleSOACs [TupLit [k, lam, arr] _] "partition" = do k' <- fromIntegral <$> fromInt32 k Just $ \_desc -> do @@ -1701,7 +1685,7 @@ uncurry (++) <$> partitionWithSOACS (fromIntegral k') lam' arrs where fromInt32 (Literal (SignedValue (Int32Value k')) _) = Just k' - fromInt32 (IntLit k' (Info (E.Scalar (E.Prim (Signed Int32)))) _) = Just $ fromInteger k' + fromInt32 (IntLit k' (Info (E.Scalar (E.Prim (E.Signed Int32)))) _) = Just $ fromInteger k' fromInt32 _ = Nothing handleSOACs [TupLit [lam, ne, arr] _] "reduce" = Just $ \desc -> internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc) @@ -1751,9 +1735,7 @@ | fname `elem` ["jvp2", "vjp2"] = Just $ \desc -> do x' <- internaliseExp "ad_x" x v' <- internaliseExp "ad_v" v - xts <- mapM subExpType x' - (ps, body, ret) <- internaliseLambda f xts - let lam = I.Lambda ps body ret + lam <- internaliseLambdaCoerce f =<< mapM subExpType x' fmap (map I.Var) . letTupExp desc . Op $ case fname of "jvp2" -> JVP lam x' v' @@ -1858,12 +1840,12 @@ e' <- internaliseExp1 "trunc_arg" e case E.typeOf e of E.Scalar (E.Prim E.Bool) -> - letTupExp' desc $ - I.If + letTupExp' desc + $ I.If e' (resultBody [intConst int_to 1]) (resultBody [intConst int_to 0]) - $ ifCommon [I.Prim $ I.IntType int_to] + $ ifCommon [I.Prim $ I.IntType int_to] E.Scalar (E.Prim (E.Signed int_from)) -> letTupExp' desc $ I.BasicOp $ I.ConvOp (I.SExt int_from int_to) e' E.Scalar (E.Prim (E.Unsigned int_from)) -> @@ -1876,12 +1858,12 @@ e' <- internaliseExp1 "trunc_arg" e case E.typeOf e of E.Scalar (E.Prim E.Bool) -> - letTupExp' desc $ - I.If + letTupExp' desc + $ I.If e' (resultBody [intConst int_to 1]) (resultBody [intConst int_to 0]) - $ ifCommon [I.Prim $ I.IntType int_to] + $ ifCommon [I.Prim $ I.IntType int_to] E.Scalar (E.Prim (E.Signed int_from)) -> letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e' E.Scalar (E.Prim (E.Unsigned int_from)) -> @@ -1916,7 +1898,8 @@ loc certifying c $ letExp (baseString sv ++ "_write_sv") $ - I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion si_w] 1 sv_shape) sv + I.BasicOp $ + I.Reshape (reshapeOuter [DimCoercion si_w] 1 sv_shape) sv indexType <- fmap rowType <$> mapM lookupType si' indexName <- mapM (\_ -> newVName "write_index") indexType @@ -1948,7 +1931,7 @@ } sivs = si' <> svs' - let sa_ws = map (Shape . take dim . arrayDims) sa_ts + let sa_ws = map (I.Shape . take dim . arrayDims) sa_ts letTupExp' desc $ I.Op $ I.Scatter si_w sivs lam $ zip3 sa_ws (repeat 1) sas flatIndexHelper :: String -> SrcLoc -> E.Exp -> E.Exp -> [(E.Exp, E.Exp)] -> InternaliseM [SubExp] @@ -2100,7 +2083,7 @@ -- language. bindExtSizes :: AppRes -> [SubExp] -> InternaliseM () bindExtSizes (AppRes ret retext) ses = do - ts <- internaliseType $ E.toStruct ret + let ts = internaliseType $ E.toStruct ret ses_ts <- mapM subExpType ses let combine t1 t2 = @@ -2165,7 +2148,9 @@ sizes <- letTupExp "partition_size" $ I.If is_empty empty_body nonempty_body $ - ifCommon $ replicate k $ I.Prim int64 + ifCommon $ + replicate k $ + I.Prim int64 -- The total size of all partitions must necessarily be equal to the -- size of the input array. @@ -2173,7 +2158,8 @@ -- Create scratch arrays for the result. blanks <- forM arr_ts $ \arr_t -> letExp "partition_dest" $ - I.BasicOp $ Scratch (I.elemType arr_t) (w : drop 1 (I.arrayDims arr_t)) + I.BasicOp $ + Scratch (I.elemType arr_t) (w : drop 1 (I.arrayDims arr_t)) -- Now write into the result. write_lam <- do @@ -2201,11 +2187,12 @@ results <- letTupExp "partition_res" . I.Op $ I.Scatter w (classes : all_offsets ++ arrs) write_lam $ - zip3 (repeat $ Shape [w]) (repeat 1) blanks + zip3 (repeat $ I.Shape [w]) (repeat 1) blanks sizes' <- letSubExp "partition_sizes" $ I.BasicOp $ - I.ArrayLit (map I.Var sizes) $ I.Prim int64 + I.ArrayLit (map I.Var sizes) $ + I.Prim int64 pure (map I.Var results, [sizes']) where mkOffsetLambdaBody :: @@ -2221,7 +2208,8 @@ letSubExp "is_this_one" $ I.BasicOp $ I.CmpOp (CmpEq int64) c $ - intConst Int64 $ toInteger i + intConst Int64 $ + toInteger i next_one <- mkOffsetLambdaBody sizes c (i + 1) ps this_one <- letSubExp "this_offset" @@ -2229,12 +2217,12 @@ (Add Int64 OverflowUndef) (constant (-1 :: Int64)) (I.Var (I.paramName p) : take i sizes) - letSubExp "total_res" $ - I.If + letSubExp "total_res" + $ I.If is_this_one (resultBody [this_one]) (resultBody [next_one]) - $ ifCommon [I.Prim int64] + $ ifCommon [I.Prim int64] typeExpForError :: E.TypeExp VName -> InternaliseM [ErrorMsgPart SubExp] typeExpForError (E.TEVar qn _) = @@ -2277,16 +2265,16 @@ c' <- mapM typeExpForError c pure $ intercalate [" "] c' -dimExpForError :: E.DimExp VName -> InternaliseM (ErrorMsgPart SubExp) -dimExpForError (DimExpNamed d _) = do +dimExpForError :: E.SizeExp VName -> InternaliseM (ErrorMsgPart SubExp) +dimExpForError (SizeExpNamed d _) = do substs <- lookupSubst $ E.qualLeaf d d' <- case substs of Just [v] -> pure v _ -> pure $ I.Var $ E.qualLeaf d pure $ ErrorVal int64 d' -dimExpForError (DimExpConst d _) = +dimExpForError (SizeExpConst d _) = pure $ ErrorString $ pretty d -dimExpForError DimExpAny = pure "" +dimExpForError SizeExpAny = pure "" -- A smart constructor that compacts neighbouring literals for easier -- reading in the IR. diff --git a/src/Futhark/Internalise/FreeVars.hs b/src/Futhark/Internalise/FreeVars.hs deleted file mode 100644 --- a/src/Futhark/Internalise/FreeVars.hs +++ /dev/null @@ -1,132 +0,0 @@ --- | Facilities for computing free variables in an expression, which --- we need for both lambda-lifting and defunctionalisation. -module Futhark.Internalise.FreeVars - ( freeVars, - without, - ident, - sizes, - NameSet (..), - patVars, - ) -where - -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Futhark.IR.Pretty () -import Language.Futhark - --- | A set of names where we also track uniqueness. -newtype NameSet = NameSet {unNameSet :: M.Map VName StructType} - deriving (Show) - -instance Semigroup NameSet where - NameSet x <> NameSet y = NameSet $ M.unionWith max x y - -instance Monoid NameSet where - mempty = NameSet mempty - --- | Set subtraction. -without :: NameSet -> S.Set VName -> NameSet -without (NameSet x) y = NameSet $ M.filterWithKey keep x - where - keep k _ = k `S.notMember` y - -withoutM :: NameSet -> NameSet -> NameSet -withoutM (NameSet x) (NameSet y) = NameSet $ x `M.difference` y - --- | A 'NameSet' with a single 'Nonunique' name. -ident :: Ident -> NameSet -ident v = NameSet $ M.singleton (identName v) (toStruct $ unInfo $ identType v) - -size :: VName -> NameSet -size v = NameSet $ M.singleton v $ Scalar $ Prim $ Signed Int64 - --- | A 'NameSet' with these names, considered to be sizes. -sizes :: S.Set VName -> NameSet -sizes = foldMap size - --- | Compute the set of free variables of an expression. -freeVars :: Exp -> NameSet -freeVars expr = case expr of - Literal {} -> mempty - IntLit {} -> mempty - FloatLit {} -> mempty - StringLit {} -> mempty - Hole {} -> mempty - Parens e _ -> freeVars e - QualParens _ e _ -> freeVars e - TupLit es _ -> foldMap freeVars es - RecordLit fs _ -> foldMap freeVarsField fs - where - freeVarsField (RecordFieldExplicit _ e _) = freeVars e - freeVarsField (RecordFieldImplicit vn t _) = ident $ Ident vn t mempty - ArrayLit es t _ -> - foldMap freeVars es <> sizes (typeDimNames $ unInfo t) - AppExp (Range e me incl _) _ -> - freeVars e <> foldMap freeVars me <> foldMap freeVars incl - Var qn (Info t) _ -> NameSet $ M.singleton (qualLeaf qn) $ toStruct t - Ascript e _ _ -> freeVars e - AppExp (Coerce e _ _) (Info ar) -> - freeVars e <> sizes (typeDimNames (appResType ar)) - AppExp (LetPat let_sizes pat e1 e2 _) _ -> - freeVars e1 - <> ( (sizes (patternDimNames pat) <> freeVars e2) - `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 patIdents pats) - <> S.fromList (map typeParamName tparams) - ) - ) - <> (freeVars e2 `without` S.singleton vn) - 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 (_, RetType dims t)) _ -> - (sizes (foldMap patternDimNames pats) <> freeVars e0 <> sizes (typeDimNames t)) - `withoutM` (foldMap patVars pats <> foldMap size dims) - OpSection {} -> mempty - OpSectionLeft _ _ e _ _ _ -> freeVars e - OpSectionRight _ _ e _ _ _ -> freeVars e - ProjectSection {} -> mempty - IndexSection idxs _ _ -> foldMap freeDimIndex idxs - AppExp (DoLoop sparams pat e1 form e3 _) _ -> - let (e2fv, e2ident) = formVars form - in freeVars e1 - <> ( (e2fv <> freeVars e3) - `withoutM` (sizes (S.fromList sparams) <> patVars pat <> e2ident) - ) - where - formVars (For v e2) = (freeVars e2, ident v) - 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) - <> freeVars e1 - <> freeVars e2 - Project _ e _ _ -> freeVars e - AppExp (LetWith id1 id2 idxs e1 e2 _) _ -> - ident id2 <> foldMap freeDimIndex idxs <> freeVars e1 - <> (freeVars e2 `without` S.singleton (identName id1)) - AppExp (Index e idxs _) _ -> freeVars e <> foldMap freeDimIndex idxs - Update e1 idxs e2 _ -> freeVars e1 <> foldMap freeDimIndex idxs <> freeVars e2 - RecordUpdate e1 _ e2 _ _ -> freeVars e1 <> freeVars e2 - Assert e1 e2 _ _ -> freeVars e1 <> freeVars e2 - Constr _ es _ _ -> foldMap freeVars es - Attr _ e _ -> freeVars e - AppExp (Match e cs _) _ -> freeVars e <> foldMap caseFV cs - where - caseFV (CasePat p eCase _) = - (sizes (patternDimNames p) <> freeVars eCase) - `withoutM` patVars p - -freeDimIndex :: DimIndexBase Info VName -> NameSet -freeDimIndex (DimFix e) = freeVars e -freeDimIndex (DimSlice me1 me2 me3) = - foldMap (foldMap freeVars) [me1, me2, me3] - --- | Extract all the variable names bound in a pattern. -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 @@ -2,7 +2,6 @@ module Futhark.Internalise.Lambdas ( InternaliseLambda, - internaliseMapLambda, internaliseStreamMapLambda, internaliseFoldLambda, internaliseStreamLambda, @@ -19,22 +18,6 @@ type InternaliseLambda = E.Exp -> [I.Type] -> InternaliseM ([I.LParam SOACS], I.Body SOACS, [I.Type]) -internaliseMapLambda :: - InternaliseLambda -> - E.Exp -> - [I.SubExp] -> - InternaliseM (I.Lambda SOACS) -internaliseMapLambda internaliseLambda lam args = do - argtypes <- mapM I.subExpType args - let rowtypes = map I.rowType argtypes - (params, body, rettype) <- internaliseLambda lam rowtypes - mkLambda params $ - ensureResultShape - (ErrorMsg [ErrorString "not all iterations produce same shape"]) - (srclocOf lam) - rettype - =<< bodyBind body - internaliseStreamMapLambda :: InternaliseLambda -> E.Exp -> @@ -122,8 +105,8 @@ rettype = replicate (k + 2) $ I.Prim int64 result i = map constant $ - fromIntegral i : - (replicate i 0 ++ [1 :: Int64] ++ replicate (k - i) 0) + fromIntegral i + : (replicate i 0 ++ [1 :: Int64] ++ replicate (k - i) 0) mkResult _ i | i >= k = pure $ result i mkResult eq_class i = do @@ -131,7 +114,8 @@ letSubExp "is_i" $ BasicOp $ CmpOp (CmpEq int64) eq_class $ - intConst Int64 $ toInteger i + intConst Int64 $ + toInteger i letTupExp' "part_res" =<< eIf (eSubExp is_i) 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 @@ -16,7 +16,6 @@ import Data.Maybe import qualified Data.Set as S import Futhark.IR.Pretty () -import qualified Futhark.Internalise.FreeVars as FV import Futhark.MonadFreshNames import Language.Futhark import Language.Futhark.Traversals @@ -71,6 +70,10 @@ m = identityMapper {mapOnExp = \e' -> modify (<> existentials e') >> pure e'} in execState (astMap m e) here +freeSizes :: S.Set VName -> FV +freeSizes vs = + FV $ M.fromList $ zip (S.toList vs) $ repeat $ Scalar $ Prim $ Signed Int64 + liftFunction :: VName -> [TypeParam] -> [Pat] -> StructRetType -> Exp -> LiftM Exp liftFunction fname tparams params (RetType dims ret) funbody = do -- Find free variables @@ -82,20 +85,19 @@ <> S.fromList dims free = - let immediate_free = FV.freeVars funbody `FV.without` (bound <> existentials funbody) + let immediate_free = freeInExp funbody `freeWithout` (bound <> existentials funbody) sizes_in_free = - foldMap typeDimNames $ - M.elems $ FV.unNameSet immediate_free + foldMap freeInType $ M.elems $ unFV immediate_free sizes = - FV.sizes $ + freeSizes $ sizes_in_free - <> foldMap patternDimNames params - <> typeDimNames ret - in M.toList $ FV.unNameSet $ immediate_free <> (sizes `FV.without` bound) + <> foldMap freeInPat params + <> freeInType ret + in M.toList $ unFV $ immediate_free <> (sizes `freeWithout` bound) -- Those parameters that correspond to sizes must come first. sizes_in_types = - foldMap typeDimNames (ret : map snd free ++ map patternStructType params) + foldMap freeInType (ret : map snd free ++ map patternStructType params) isSize (v, _) = v `S.member` sizes_in_types (free_dims, free_nondims) = partition isSize free @@ -117,10 +119,10 @@ valBindEntryPoint = Nothing } - pure $ - apply + pure + $ apply (Var (qualName fname) (Info (augType $ free_dims ++ free_nondims)) mempty) - $ free_dims ++ free_nondims + $ free_dims ++ free_nondims where orig_type = funType params $ RetType dims ret mkParam (v, t) = Id v (Info (fromStruct t)) mempty 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 @@ -14,13 +14,13 @@ FunInfo, substitutingVars, lookupSubst, + addOpaques, addFunDef, lookupFunction, lookupFunction', lookupConst, bindFunction, bindConstant, - localConstsScope, assert, -- * Convenient reexports @@ -60,8 +60,8 @@ { stateNameSource :: VNameSource, stateFunTable :: FunTable, stateConstSubsts :: VarSubsts, - stateConstScope :: Scope SOACS, - stateFuns :: [FunDef SOACS] + stateFuns :: [FunDef SOACS], + stateTypes :: OpaqueTypes } newtype InternaliseM a @@ -74,10 +74,20 @@ MonadReader InternaliseEnv, MonadState InternaliseState, MonadFreshNames, - HasScope SOACS, - LocalScope SOACS + HasScope SOACS ) +-- Internalisation has to deal with the risk of multiple binding of +-- the same variable (although always of the same type) in the +-- program; in particular this might imply shadowing a constant. The +-- LocalScope instance for BuilderT does not handle this properly (and +-- doing so would make it slower). So we remove already-known +-- variables before passing the scope on. +instance LocalScope SOACS InternaliseM where + localScope scope (InternaliseM m) = do + old_scope <- askScope + InternaliseM $ localScope (scope `M.difference` old_scope) m + instance MonadFreshNames (State InternaliseState) where getNameSource = gets stateNameSource putNameSource src = modify $ \s -> s {stateNameSource = src} @@ -95,12 +105,14 @@ MonadFreshNames m => Bool -> InternaliseM () -> - m (Stms SOACS, [FunDef SOACS]) + m (OpaqueTypes, Stms SOACS, [FunDef SOACS]) runInternaliseM safe (InternaliseM m) = modifyNameSource $ \src -> let ((_, consts), s) = runState (runReaderT (runBuilderT m mempty) newEnv) (newState src) - in ((consts, reverse $ stateFuns s), stateNameSource s) + in ( (stateTypes s, consts, reverse $ stateFuns s), + stateNameSource s + ) where newEnv = InternaliseEnv @@ -114,8 +126,8 @@ { stateNameSource = src, stateFunTable = mempty, stateConstSubsts = mempty, - stateConstScope = mempty, - stateFuns = mempty + stateFuns = mempty, + stateTypes = mempty } substitutingVars :: VarSubsts -> InternaliseM a -> InternaliseM a @@ -127,6 +139,12 @@ const_substs <- gets $ M.lookup v . stateConstSubsts pure $ env_substs `mplus` const_substs +-- | Add opaque types. If the types are already known, they will not +-- be added. +addOpaques :: OpaqueTypes -> InternaliseM () +addOpaques ts = modify $ \s -> + s {stateTypes = stateTypes s <> ts} + -- | Add a function definition to the program being constructed. addFunDef :: FunDef SOACS -> InternaliseM () addFunDef fd = modify $ \s -> s {stateFuns = fd : stateFuns s} @@ -140,7 +158,13 @@ bad = error $ "Internalise.lookupFunction: Function '" ++ pretty fname ++ "' not found." lookupConst :: VName -> InternaliseM (Maybe [SubExp]) -lookupConst fname = gets $ M.lookup fname . stateConstSubsts +lookupConst fname = do + is_var <- asksScope (fname `M.member`) + fname_subst <- lookupSubst fname + case (is_var, fname_subst) of + (_, Just ses) -> pure $ Just ses + (True, _) -> pure $ Just [Var fname] + _ -> pure Nothing bindFunction :: VName -> FunDef SOACS -> FunInfo -> InternaliseM () bindFunction fname fd info = do @@ -149,21 +173,18 @@ bindConstant :: VName -> FunDef SOACS -> InternaliseM () bindConstant cname fd = do - let stms = bodyStms $ funDefBody fd - substs = - drop (length (shapeContext (funDefRetType fd))) $ - map resSubExp $ bodyResult $ funDefBody fd - addStms stms - modify $ \s -> - s - { stateConstSubsts = M.insert cname substs $ stateConstSubsts s, - stateConstScope = scopeOf stms <> stateConstScope s - } + addStms $ bodyStms $ funDefBody fd -localConstsScope :: InternaliseM a -> InternaliseM a -localConstsScope m = do - scope <- gets stateConstScope - localScope scope m + case map resSubExp . bodyResult . funDefBody $ fd of + [se] -> do + letBindNames [cname] $ BasicOp $ SubExp se + ses -> do + let substs = + drop (length (shapeContext (funDefRetType fd))) ses + modify $ \s -> + s + { stateConstSubsts = M.insert cname substs $ stateConstSubsts s + } -- | Construct an 'Assert' statement, but taking attributes into -- account. Always use this function, and never construct 'Assert' @@ -178,7 +199,8 @@ attrs <- asks $ attrsForAssert . envAttrs attributing attrs $ letExp desc $ - BasicOp $ Assert se msg (loc, mempty) + BasicOp $ + Assert se msg (loc, mempty) -- | Execute the given action if 'envDoBoundsChecks' is true, otherwise -- just return an empty list. 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 @@ -159,18 +159,18 @@ ppr (MonoKnown i) = text "?" <> ppr i ppr (MonoAnon v) = text "?" <> pprName v -instance Pretty (ShapeDecl MonoSize) where - ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds) +instance Pretty (Shape MonoSize) where + ppr (Shape ds) = mconcat (map (brackets . ppr) ds) -- The kind of type relative to which we monomorphise. What is most -- important to us is not the specific dimensions, but merely whether -- they are known or anonymous/local. type MonoType = TypeBase MonoSize () -monoType :: TypeBase (DimDecl VName) als -> MonoType +monoType :: TypeBase Size als -> MonoType monoType = (`evalState` (0, mempty)) . traverseDims onDim . toStruct where - onDim bound _ (NamedDim d) + onDim bound _ (NamedSize d) -- A locally bound size. | qualLeaf d `S.member` bound = pure $ MonoAnon $ qualLeaf d onDim _ _ d = do @@ -267,10 +267,10 @@ pure (sizes, params') where tv = identityMapper {mapOnPatType = bitraverse onDim pure} - onDim (AnyDim _) = do + onDim (AnySize _) = do v <- lift $ newVName "size" modify (v :) - pure $ NamedDim $ qualName v + pure $ NamedSize $ qualName v onDim d = pure d transformAppRes :: AppRes -> MonoM AppRes @@ -288,7 +288,8 @@ transformAppExp (LetPat sizes pat e1 e2 loc) res = do (pat', rr) <- transformPat pat AppExp - <$> ( LetPat sizes pat' <$> transformExp e1 + <$> ( LetPat sizes pat' + <$> transformExp e1 <*> withRecordReplacements rr (transformExp e2) <*> pure loc ) @@ -324,7 +325,7 @@ While e2 -> While <$> transformExp e2 e3' <- transformExp e3 -- Maybe monomorphisation introduced new arrays to the loop, and - -- maybe they have AnyDim sizes. This is not allowed. Invent some + -- maybe they have AnySize sizes. This is not allowed. Invent some -- sizes for them. (pat_sizes, pat') <- sizesForPat pat pure $ AppExp (DoLoop (sparams ++ pat_sizes) pat' e1' form' e3' loc) (Info res) @@ -491,11 +492,15 @@ e' <- transformExp e pure $ Project n e' tp loc transformExp (Update e1 idxs e2 loc) = - Update <$> transformExp e1 <*> mapM transformDimIndex idxs + Update + <$> transformExp e1 + <*> mapM transformDimIndex idxs <*> transformExp e2 <*> pure loc transformExp (RecordUpdate e1 fs e2 t loc) = - RecordUpdate <$> transformExp e1 <*> pure fs + RecordUpdate + <$> transformExp e1 + <*> pure fs <*> transformExp e2 <*> pure t <*> pure loc @@ -542,9 +547,9 @@ ) (Info $ AppRes (Scalar $ Arrow mempty yp ytype (RetType [] t)) []) rettype' = - let onDim (NamedDim d) - | Named p <- xp, qualLeaf d == p = NamedDim $ qualName v1 - | Named p <- yp, qualLeaf d == p = NamedDim $ qualName v2 + let onDim (NamedSize d) + | Named p <- xp, qualLeaf d == p = NamedSize $ qualName v1 + | Named p <- yp, qualLeaf d == p = NamedSize $ qualName v2 onDim d = d in first onDim rettype body = @@ -599,7 +604,8 @@ Project field e (Info t) mempty t -> error $ - "desugarOpSection: type " ++ pretty t + "desugarOpSection: type " + ++ pretty t ++ " does not have field " ++ pretty field desugarProjectSection _ t _ = error $ "desugarOpSection: not a function type: " ++ pretty t @@ -619,11 +625,10 @@ t1' = fromStruct t1 desugarIndexSection _ t _ = error $ "desugarIndexSection: not a function type: " ++ pretty t -noticeDims :: TypeBase (DimDecl VName) as -> MonoM () -noticeDims = mapM_ notice . nestedDims +noticeDims :: TypeBase Size as -> MonoM () +noticeDims = mapM_ notice . freeInType where - notice (NamedDim v) = void $ transformFName mempty v i64 - notice _ = pure () + notice v = void $ transformFName mempty (qualName v) i64 -- Convert a collection of 'ValBind's to a nested sequence of let-bound, -- monomorphic functions with the given expression at the bottom. @@ -678,20 +683,20 @@ wildcard t loc = Wildcard (Info t) loc -type DimInst = M.Map VName (DimDecl VName) +type DimInst = M.Map VName Size dimMapping :: Monoid a => - TypeBase (DimDecl VName) a -> - TypeBase (DimDecl VName) a -> + TypeBase Size a -> + TypeBase Size a -> DimInst dimMapping t1 t2 = execState (matchDims f t1 t2) mempty where - f bound d1 (NamedDim d2) + f bound d1 (NamedSize d2) | qualLeaf d2 `elem` bound = pure d1 - f _ (NamedDim d1) d2 = do + f _ (NamedSize d1) d2 = do modify $ M.insert (qualLeaf d1) d2 - pure $ NamedDim d1 + pure $ NamedSize d1 f _ d _ = pure d inferSizeArgs :: [TypeParam] -> StructType -> StructType -> [Exp] @@ -700,9 +705,9 @@ where tparamArg dinst tp = case M.lookup (typeParamName tp) dinst of - Just (NamedDim d) -> + Just (NamedSize d) -> Just $ Var d (Info i64) mempty - Just (ConstDim x) -> + Just (ConstSize x) -> Just $ Literal (SignedValue $ Int64Value $ fromIntegral x) mempty _ -> Just $ Literal (SignedValue $ Int64Value 0) mempty @@ -746,7 +751,7 @@ 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) $ + partition ((`S.member` mustBeExplicitInBinding bind_t') . typeParamName) $ shape_params ++ t_shape_params (params'', rrs) <- unzip <$> mapM transformPat params' @@ -789,7 +794,6 @@ ASTMapper { mapOnExp = updateExpTypes substs, mapOnName = pure, - mapOnQualName = pure, mapOnStructType = pure . applySubst substs, mapOnPatType = pure . applySubst substs, mapOnStructRetType = pure . applySubst substs, @@ -822,7 +826,7 @@ runWriterT $ fst <$> execStateT (sub orig_t1 orig_t2) (mempty, mempty) where subRet (Scalar (TypeVar _ _ v _)) rt = - unless (baseTag (typeLeaf v) <= maxIntrinsicTag) $ + unless (baseTag (qualLeaf v) <= maxIntrinsicTag) $ addSubst v rt subRet t1 (RetType _ t2) = sub t1 t2 @@ -832,8 +836,9 @@ Just t2' <- peelArray (arrayRank t1) t2 = sub t1' t2' sub (Scalar (TypeVar _ _ v _)) t = - unless (baseTag (typeLeaf v) <= maxIntrinsicTag) $ - addSubst v $ RetType [] t + unless (baseTag (qualLeaf v) <= maxIntrinsicTag) $ + addSubst v $ + RetType [] t sub (Scalar (Record fields1)) (Scalar (Record fields2)) = zipWithM_ sub @@ -851,7 +856,7 @@ sub t1 t2@(Scalar Sum {}) = sub t1 t2 sub t1 t2 = error $ unlines ["typeSubstsM: mismatched types:", pretty t1, pretty t2] - addSubst (TypeName _ v) (RetType ext t) = do + addSubst (QualName _ v) (RetType ext t) = do (ts, sizes) <- get unless (v `M.member` ts) $ do t' <- bitraverse onDim pure t @@ -864,10 +869,10 @@ d <- lift $ lift $ newVName "d" tell [TypeParamDim d loc] put (ts, M.insert i d sizes) - pure $ NamedDim $ qualName d + pure $ NamedSize $ qualName d Just d -> - pure $ NamedDim $ qualName d - onDim (MonoAnon v) = pure $ AnyDim $ Just v + pure $ NamedSize $ qualName d + onDim (MonoAnon v) = pure $ AnySize $ Just v -- Perform a given substitution on the types in a pattern. substPat :: Bool -> (PatType -> PatType) -> Pat -> Pat @@ -899,7 +904,6 @@ ASTMapper { mapOnExp = onExp, mapOnName = pure, - mapOnQualName = pure, mapOnStructType = pure . applySubst (`M.lookup` subs), mapOnPatType = pure . applySubst (`M.lookup` subs), mapOnStructRetType = pure . applySubst (`M.lookup` subs), @@ -922,21 +926,34 @@ subs <- asks $ M.map substFromAbbr . envTypeBindings pure $ applySubst (`M.lookup` subs) t +transformEntryPoint :: EntryPoint -> MonoM EntryPoint +transformEntryPoint (EntryPoint params ret) = + EntryPoint <$> mapM onEntryParam params <*> onEntryType ret + where + onEntryParam (EntryParam v t) = + EntryParam v <$> onEntryType t + onEntryType (EntryType t te) = + EntryType <$> removeTypeVariablesInType t <*> pure te + transformValBind :: ValBind -> MonoM Env transformValBind valbind = do valbind' <- toPolyBinding <$> removeTypeVariables (isJust (valBindEntryPoint valbind)) valbind - when (isJust $ valBindEntryPoint valbind) $ do - t <- - removeTypeVariablesInType $ - foldFunType - (map patternStructType (valBindParams valbind)) - $ unInfo $ valBindRetType valbind - (name, infer, valbind'') <- monomorphiseBinding True valbind' $ monoType t - tell $ Seq.singleton (name, valbind'' {valBindEntryPoint = valBindEntryPoint valbind}) - addLifted (valBindName valbind) (monoType t) (name, infer) + case valBindEntryPoint valbind of + Nothing -> pure () + Just (Info entry) -> do + t <- + removeTypeVariablesInType + $ foldFunType + (map patternStructType (valBindParams valbind)) + $ unInfo + $ valBindRetType valbind + (name, infer, valbind'') <- monomorphiseBinding True valbind' $ monoType t + entry' <- transformEntryPoint entry + tell $ Seq.singleton (name, valbind'' {valBindEntryPoint = Just $ Info entry'}) + addLifted (valBindName valbind) (monoType t) (name, infer) pure mempty {envPolyBindings = M.singleton (valBindName valbind) valbind'} diff --git a/src/Futhark/Internalise/TypesValues.hs b/src/Futhark/Internalise/TypesValues.hs --- a/src/Futhark/Internalise/TypesValues.hs +++ b/src/Futhark/Internalise/TypesValues.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE OverloadedStrings #-} module Futhark.Internalise.TypesValues ( -- * Internalising types @@ -19,8 +19,8 @@ ) where -import Control.Monad.Reader import Control.Monad.State +import Data.Bitraversable (bitraverse) import Data.List (delete, find, foldl') import qualified Data.Map.Strict as M import Data.Maybe @@ -35,23 +35,21 @@ newtype TypeState = TypeState {typeCounter :: Int} newtype InternaliseTypeM a - = InternaliseTypeM (StateT TypeState InternaliseM a) + = InternaliseTypeM (State TypeState a) deriving (Functor, Applicative, Monad, MonadState TypeState) -liftInternaliseM :: InternaliseM a -> InternaliseTypeM a -liftInternaliseM = InternaliseTypeM . lift - -runInternaliseTypeM :: InternaliseTypeM a -> InternaliseM a +runInternaliseTypeM :: InternaliseTypeM a -> a runInternaliseTypeM = runInternaliseTypeM' mempty -runInternaliseTypeM' :: [VName] -> InternaliseTypeM a -> InternaliseM a -runInternaliseTypeM' exts (InternaliseTypeM m) = evalStateT m $ TypeState (length exts) +runInternaliseTypeM' :: [VName] -> InternaliseTypeM a -> a +runInternaliseTypeM' exts (InternaliseTypeM m) = evalState m $ TypeState (length exts) internaliseParamTypes :: - [E.TypeBase (E.DimDecl VName) ()] -> + [E.TypeBase E.Size ()] -> InternaliseM [[I.TypeBase Shape Uniqueness]] internaliseParamTypes ts = - runInternaliseTypeM $ mapM (fmap (map onType) . internaliseTypeM mempty) ts + mapM (mapM mkAccCerts) . runInternaliseTypeM $ + mapM (fmap (map onType) . internaliseTypeM mempty) ts where onType = fromMaybe bad . hasStaticShape bad = error $ "internaliseParamTypes: " ++ pretty ts @@ -59,30 +57,44 @@ -- We need to fix up the arrays for any Acc return values or loop -- parameters. We look at the concrete types for this, since the Acc -- parameter name in the second list will just be something we made up. -fixupTypes :: [TypeBase shape1 u1] -> [TypeBase shape2 u2] -> [TypeBase shape2 u2] -fixupTypes = zipWith fixup +fixupKnownTypes :: [TypeBase shape1 u1] -> [TypeBase shape2 u2] -> [TypeBase shape2 u2] +fixupKnownTypes = zipWith fixup where fixup (Acc acc ispace ts _) (Acc _ _ _ u2) = Acc acc ispace ts u2 fixup _ t = t +-- Generate proper certificates for the placeholder accumulator +-- certificates produced by internaliseType (identified with tag 0). +-- Only needed when we cannot use 'fixupKnownTypes'. +mkAccCerts :: TypeBase shape u -> InternaliseM (TypeBase shape u) +mkAccCerts (Array pt shape u) = + pure $ Array pt shape u +mkAccCerts (Acc c shape ts u) = + Acc <$> c' <*> pure shape <*> pure ts <*> pure u + where + c' + | baseTag c == 0 = newVName "acc_cert" + | otherwise = pure c +mkAccCerts t = pure t + internaliseLoopParamType :: - E.TypeBase (E.DimDecl VName) () -> + E.TypeBase E.Size () -> [TypeBase shape u] -> InternaliseM [I.TypeBase Shape Uniqueness] internaliseLoopParamType et ts = - fixupTypes ts . concat <$> internaliseParamTypes [et] + fixupKnownTypes ts . concat <$> internaliseParamTypes [et] internaliseReturnType :: E.StructRetType -> [TypeBase shape u] -> - InternaliseM [I.TypeBase ExtShape Uniqueness] + [I.TypeBase ExtShape Uniqueness] internaliseReturnType (E.RetType dims et) ts = - fixupTypes ts <$> runInternaliseTypeM' dims (internaliseTypeM exts et) + fixupKnownTypes ts $ runInternaliseTypeM' dims (internaliseTypeM exts et) where exts = M.fromList $ zip dims [0 ..] internaliseLambdaReturnType :: - E.TypeBase (E.DimDecl VName) () -> + E.TypeBase E.Size () -> [TypeBase shape u] -> InternaliseM [I.TypeBase Shape NoUniqueness] internaliseLambdaReturnType et ts = @@ -92,7 +104,7 @@ -- tuple type piecemeal. internaliseEntryReturnType :: E.StructRetType -> - InternaliseM [[I.TypeBase ExtShape Uniqueness]] + [[I.TypeBase ExtShape Uniqueness]] internaliseEntryReturnType (E.RetType dims et) = runInternaliseTypeM' dims . mapM (internaliseTypeM exts) $ case E.isTupleRecord et of @@ -102,8 +114,8 @@ exts = M.fromList $ zip dims [0 ..] internaliseType :: - E.TypeBase (E.DimDecl VName) () -> - InternaliseM [I.TypeBase I.ExtShape Uniqueness] + E.TypeBase E.Size () -> + [I.TypeBase I.ExtShape Uniqueness] internaliseType = runInternaliseTypeM . internaliseTypeM mempty newId :: InternaliseTypeM Int @@ -114,21 +126,17 @@ internaliseDim :: M.Map VName Int -> - E.DimDecl VName -> + E.Size -> InternaliseTypeM ExtSize internaliseDim exts d = case d of - E.AnyDim _ -> Ext <$> newId - E.ConstDim n -> pure $ Free $ intConst I.Int64 $ toInteger n - E.NamedDim name -> namedDim name + E.AnySize _ -> Ext <$> newId + E.ConstSize n -> pure $ Free $ intConst I.Int64 $ toInteger n + E.NamedSize name -> pure $ namedDim name where namedDim (E.QualName _ name) - | Just x <- name `M.lookup` exts = pure $ I.Ext x - | otherwise = do - subst <- liftInternaliseM $ lookupSubst name - case subst of - Just [v] -> pure $ I.Free v - _ -> pure $ I.Free $ I.Var name + | Just x <- name `M.lookup` exts = I.Ext x + | otherwise = I.Free $ I.Var name internaliseTypeM :: M.Map VName Int -> @@ -149,14 +157,14 @@ | otherwise -> concat <$> mapM (internaliseTypeM exts . snd) (E.sortFields ets) E.Scalar (E.TypeVar _ u tn [E.TypeArgType arr_t _]) - | baseTag (E.typeLeaf tn) <= E.maxIntrinsicTag, - baseString (E.typeLeaf tn) == "acc" -> do + | baseTag (E.qualLeaf tn) <= E.maxIntrinsicTag, + baseString (E.qualLeaf tn) == "acc" -> do ts <- map (fromDecl . onAccType) <$> internaliseTypeM exts arr_t - acc_param <- liftInternaliseM $ newVName "acc_cert" - let acc_t = Acc acc_param (Shape [arraysSize 0 ts]) (map rowType ts) $ internaliseUniqueness u + let acc_param = VName "PLACEHOLDER" 0 -- See mkAccCerts. + acc_t = Acc acc_param (Shape [arraysSize 0 ts]) (map rowType ts) $ internaliseUniqueness u pure [acc_t] E.Scalar E.TypeVar {} -> - error "internaliseTypeM: cannot handle type variable." + error $ "internaliseTypeM: cannot handle type variable: " ++ pretty orig_t E.Scalar E.Arrow {} -> error $ "internaliseTypeM: cannot handle function type: " ++ pretty orig_t E.Scalar (E.Sum cs) -> do @@ -202,17 +210,17 @@ M.Map Name (Int, [Int]) ) internaliseSumType cs = - runInternaliseTypeM $ + bitraverse (mapM mkAccCerts) pure . runInternaliseTypeM $ internaliseConstructors <$> traverse (fmap concat . mapM (internaliseTypeM mempty)) cs -- | How many core language values are needed to represent one source -- language value of the given type? -internalisedTypeSize :: E.TypeBase (E.DimDecl VName) als -> InternaliseM Int +internalisedTypeSize :: E.TypeBase E.Size als -> Int -- A few special cases for performance. -internalisedTypeSize (E.Scalar (E.Prim _)) = pure 1 -internalisedTypeSize (E.Array _ _ _ (E.Prim _)) = pure 1 -internalisedTypeSize t = length <$> internaliseType (t `E.setAliases` ()) +internalisedTypeSize (E.Scalar (E.Prim _)) = 1 +internalisedTypeSize (E.Array _ _ _ (E.Prim _)) = 1 +internalisedTypeSize t = length $ internaliseType (t `E.setAliases` ()) -- | Convert an external primitive to an internal primitive. internalisePrimType :: E.PrimType -> I.PrimType diff --git a/src/Futhark/LSP/Compile.hs b/src/Futhark/LSP/Compile.hs --- a/src/Futhark/LSP/Compile.hs +++ b/src/Futhark/LSP/Compile.hs @@ -4,6 +4,8 @@ -- the old state around. module Futhark.LSP.Compile (tryTakeStateFromIORef, tryReCompile) where +import Colog.Core (logStringStderr, (<&)) +import Control.Lens.Getter (view) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.IORef (IORef, readIORef, writeIORef) import qualified Data.Map as M @@ -13,7 +15,6 @@ import Futhark.LSP.Diagnostic (diagnosticSource, maxDiagnostic, publishErrorDiagnostics, publishWarningDiagnostics) import Futhark.LSP.State (State (..), emptyState, updateStaleContent, updateStaleMapping) import Futhark.LSP.Tool (computeMapping) -import Futhark.Util (debug) import Language.Futhark.Warnings (listWarnings) import Language.LSP.Server (LspT, flushDiagnosticsBySource, getVirtualFile, getVirtualFiles) import Language.LSP.Types @@ -22,7 +23,7 @@ toNormalizedUri, uriToNormalizedFilePath, ) -import Language.LSP.VFS (VFS (vfsMap), virtualFileText) +import Language.LSP.VFS (VFS, vfsMap, virtualFileText) -- | Try to take state from IORef, if it's empty, try to compile. tryTakeStateFromIORef :: IORef State -> Maybe FilePath -> LspT () IO State @@ -40,8 +41,8 @@ state <- case file_path of Just file_path' | file_path' `notElem` files -> do - debug $ "File not part of program: " <> show file_path' - debug $ "Program contains: " <> show files + logStringStderr <& ("File not part of program: " <> show file_path') + logStringStderr <& ("Program contains: " <> show files) tryCompile old_state file_path noLoadedProg _ -> pure old_state liftIO $ writeIORef state_mvar state @@ -50,18 +51,18 @@ -- | Try to (re)-compile, replace old state if successful. tryReCompile :: IORef State -> Maybe FilePath -> LspT () IO () tryReCompile state_mvar file_path = do - debug "(Re)-compiling ..." + logStringStderr <& "(Re)-compiling ..." old_state <- liftIO $ readIORef state_mvar let loaded_prog = getLoadedProg old_state new_state <- tryCompile old_state file_path loaded_prog case stateProgram new_state of Nothing -> do - debug "Failed to (re)-compile, using old state or Nothing" - debug $ "Computing PositionMapping for: " <> show file_path + logStringStderr <& "Failed to (re)-compile, using old state or Nothing" + logStringStderr <& "Computing PositionMapping for: " <> show file_path mapping <- computeMapping old_state file_path liftIO $ writeIORef state_mvar $ updateStaleMapping file_path mapping old_state Just _ -> do - debug "(Re)-compile successful" + logStringStderr <& "(Re)-compile successful" liftIO $ writeIORef state_mvar new_state -- | Try to compile, publish diagnostics on warnings and errors, return newly compiled state. @@ -69,7 +70,7 @@ tryCompile :: State -> Maybe FilePath -> LoadedProg -> LspT () IO State tryCompile _ Nothing _ = pure emptyState tryCompile state (Just path) old_loaded_prog = do - debug $ "Reloading program from " <> show path + logStringStderr <& "Reloading program from " <> show path vfs <- getVirtualFiles res <- liftIO $ reloadProg old_loaded_prog [path] (transformVFS vfs) -- NOTE: vfs only keeps track of current opened files flushDiagnosticsBySource maxDiagnostic diagnosticSource @@ -85,7 +86,7 @@ -- But still might need an update on re-compile logic, don't discard all state afterwards, -- try to compile from root file, if there is a depencency relatetion, improve performance and provide more dignostic. Left prog_error -> do - debug "Compilation failed, publishing diagnostics" + logStringStderr <& "Compilation failed, publishing diagnostics" publishErrorDiagnostics prog_error pure emptyState @@ -101,7 +102,7 @@ M.insert (fromNormalizedFilePath file_path) (virtualFileText virtual_file) acc ) M.empty - (vfsMap vfs) + (view vfsMap vfs) getLoadedProg :: State -> LoadedProg getLoadedProg state = fromMaybe noLoadedProg (stateProgram state) diff --git a/src/Futhark/LSP/Diagnostic.hs b/src/Futhark/LSP/Diagnostic.hs --- a/src/Futhark/LSP/Diagnostic.hs +++ b/src/Futhark/LSP/Diagnostic.hs @@ -10,6 +10,7 @@ ) where +import Colog.Core (logStringStderr, (<&)) import Control.Lens ((^.)) import Data.Foldable (for_) import qualified Data.List.NonEmpty as NE @@ -17,7 +18,6 @@ import qualified Data.Text as T import Futhark.Compiler.Program (ProgError (..)) import Futhark.LSP.Tool (posToUri, rangeFromLoc, rangeFromSrcLoc) -import Futhark.Util (debug) import Futhark.Util.Loc (Loc (..), SrcLoc, locOf) import Futhark.Util.Pretty (Doc, prettyText) import Language.LSP.Diagnostics (partitionBySource) @@ -39,7 +39,8 @@ publish :: [(Uri, [Diagnostic])] -> LspT () IO () publish uri_diags_map = for_ uri_diags_map $ \(uri, diags) -> do doc <- getVersionedTextDoc $ TextDocumentIdentifier uri - debug $ "Publishing diagnostics for " ++ show uri ++ " Verion: " ++ show (doc ^. version) + logStringStderr + <& ("Publishing diagnostics for " ++ show uri ++ " Version: " ++ show (doc ^. version)) publishDiagnostics maxDiagnostic (toNormalizedUri uri) (doc ^. version) (partitionBySource diags) -- | Send warning diagnostics to the client. diff --git a/src/Futhark/LSP/Handlers.hs b/src/Futhark/LSP/Handlers.hs --- a/src/Futhark/LSP/Handlers.hs +++ b/src/Futhark/LSP/Handlers.hs @@ -3,6 +3,7 @@ -- | The handlers exposed by the language server. module Futhark.LSP.Handlers (handlers) where +import Colog.Core (logStringStderr, (<&)) import Control.Lens ((^.)) import Data.Aeson.Types (Value (Array, String)) import Data.IORef @@ -10,7 +11,6 @@ import Futhark.LSP.Compile (tryReCompile, tryTakeStateFromIORef) import Futhark.LSP.State (State (..)) import Futhark.LSP.Tool (findDefinitionRange, getHoverInfoFromState) -import Futhark.Util (debug) import Language.LSP.Server (Handlers, LspM, notificationHandler, requestHandler) import Language.LSP.Types import Language.LSP.Types.Lens (HasUri (uri)) @@ -32,23 +32,24 @@ ] onInitializeHandler :: Handlers (LspM ()) -onInitializeHandler = notificationHandler SInitialized $ \_msg -> debug "Initialized" +onInitializeHandler = notificationHandler SInitialized $ \_msg -> + logStringStderr <& "Initialized" onHoverHandler :: IORef State -> Handlers (LspM ()) onHoverHandler state_mvar = requestHandler STextDocumentHover $ \req responder -> do let RequestMessage _ _ _ (HoverParams doc pos _workDone) = req Position l c = pos file_path = uriToFilePath $ doc ^. uri - debug $ "Got hover request: " <> show (file_path, pos) + logStringStderr <& ("Got hover request: " <> show (file_path, pos)) state <- tryTakeStateFromIORef state_mvar file_path responder $ Right $ getHoverInfoFromState state file_path (fromEnum l + 1) (fromEnum c + 1) onDocumentFocusHandler :: IORef State -> Handlers (LspM ()) onDocumentFocusHandler state_mvar = notificationHandler (SCustomMethod "custom/onFocusTextDocument") $ \msg -> do - debug "Got custom request: onFocusTextDocument" + logStringStderr <& "Got custom request: onFocusTextDocument" let NotificationMessage _ _ (Array vector_param) = msg String focused_uri = V.head vector_param -- only one parameter passed from the client - debug $ show focused_uri + logStringStderr <& show focused_uri tryReCompile state_mvar (uriToFilePath (Uri focused_uri)) goToDefinitionHandler :: IORef State -> Handlers (LspM ()) @@ -56,19 +57,17 @@ let RequestMessage _ _ _ (DefinitionParams doc pos _workDone _partial) = req Position l c = pos file_path = uriToFilePath $ doc ^. uri - debug $ "Got goto definition: " <> show (file_path, pos) + logStringStderr <& ("Got goto definition: " <> show (file_path, pos)) state <- tryTakeStateFromIORef state_mvar file_path case findDefinitionRange state file_path (fromEnum l + 1) (fromEnum c + 1) of Nothing -> responder $ Right $ InR $ InL $ List [] - Just loc -> do - debug $ show loc - responder $ Right $ InL loc + Just loc -> responder $ Right $ InL loc onDocumentSaveHandler :: IORef State -> Handlers (LspM ()) onDocumentSaveHandler state_mvar = notificationHandler STextDocumentDidSave $ \msg -> do let NotificationMessage _ _ (DidSaveTextDocumentParams doc _text) = msg file_path = uriToFilePath $ doc ^. uri - debug $ "Saved document: " ++ show doc + logStringStderr <& ("Saved document: " ++ show doc) tryReCompile state_mvar file_path onDocumentChangeHandler :: IORef State -> Handlers (LspM ()) @@ -81,8 +80,9 @@ onDocumentOpenHandler state_mvar = notificationHandler STextDocumentDidOpen $ \msg -> do let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = msg file_path = uriToFilePath $ doc ^. uri - debug $ "Opened document: " ++ show (doc ^. uri) + logStringStderr <& ("Opened document: " ++ show (doc ^. uri)) tryReCompile state_mvar file_path onDocumentCloseHandler :: Handlers (LspM ()) -onDocumentCloseHandler = notificationHandler STextDocumentDidClose $ \_msg -> debug "Closed document" +onDocumentCloseHandler = notificationHandler STextDocumentDidClose $ \_msg -> + logStringStderr <& "Closed document" 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 @@ -93,7 +93,8 @@ -- inner loop updating this thread's accumulator (loop k in mmm_kernels). thd_acc <- forLoop tk [thd_res_merge] $ \k [acc_merge] -> - resultBodyM =<< letTupExp' "foo" + resultBodyM + =<< letTupExp' "foo" =<< eIf ( toExp $ if epilogue @@ -162,7 +163,8 @@ css <- forLoop ry [css_init] $ \i [css_merge] -> do css <- forLoop rx [css_merge] $ \j [css_merge'] -> - resultBodyM =<< letTupExp' "foo" + resultBodyM + =<< letTupExp' "foo" =<< eIf ( toExp $ if fits_ij @@ -174,8 +176,8 @@ le64 iii + le64 i + pe64 ry * le64 ltid_y .<. pe64 height_A - .&&. le64 jjj + le64 j + pe64 rx * le64 ltid_x - .<. pe64 width_B + .&&. le64 jjj + le64 j + pe64 rx * le64 ltid_x + .<. pe64 width_B ) ( do a <- index "a" as [i] @@ -529,7 +531,8 @@ -- build prologue. full_tiles <- letExp "full_tiles" $ - BasicOp $ BinOp (SQuot Int64 Unsafe) common_dim tk + BasicOp $ + BinOp (SQuot Int64 Unsafe) common_dim tk let ct_arg = ( (rx, ry, tx, ty, tk, tk_div_tx, tk_div_ty, tx_rx), @@ -736,7 +739,7 @@ (ty, ry) <- getParTiles ("Ty", "Ry") (ty_name, ry_name) height_A (tx, rx) <- getParTiles ("Tx", "Rx") (tx_name, rx_name) width_B - tk <- getSeqTile "Tk" tk_name common_dim ty tx + tk <- getSeqTile "Tk" tk_name common_dim tx ty tk_div_tx <- letSubExp "tk_div_tx" =<< ceilDiv tk tx tk_div_ty <- letSubExp "tk_div_ty" =<< ceilDiv tk ty @@ -874,10 +877,10 @@ if not branch_invariant then Nothing -- if i or j in branch_variant; return nothing else - if nameIn i variant_to && not (nameIn j variant_to) + if nameIn i variant_to && j `notNameIn` variant_to then Just 0 else - if nameIn j variant_to && not (nameIn i variant_to) + if nameIn j variant_to && i `notNameIn` variant_to then Just 1 else Nothing @@ -891,12 +894,12 @@ | Just (ss, tab) <- acc, [p] <- patElems patt, p_nm <- patElemName p, - nameIn p_nm arrs = + p_nm `nameIn` arrs = Just (ss, M.insert p_nm stm tab) processIndirections _ res_red_var acc stm'@(Let patt _ _) | Just (ss, tab) <- acc, ps <- patElems patt, - all (\p -> not (nameIn (patElemName p) res_red_var)) ps = + all (\p -> patElemName p `notNameIn` res_red_var) ps = Just (ss Seq.|> stm', tab) | otherwise = Nothing @@ -915,7 +918,7 @@ pure (t, r) getSeqTile :: String -> Name -> SubExp -> SubExp -> SubExp -> Builder GPU SubExp -getSeqTile tk_str tk_name len_dim ty tx = +getSeqTile tk_str tk_name len_dim tx ty = case (tx, ty) of (Constant (IntValue (Int64Value v_x)), Constant (IntValue (Int64Value v_y))) -> letSubExp tk_str . BasicOp . SubExp . constant $ @@ -1153,7 +1156,9 @@ res_nms <- letTupExp "Y_glb2loc" <=< renameExp $ - Op $ SegOp $ SegMap segthd_lvl segspace [Prim ptp_Y] body + Op $ + SegOp $ + SegMap segthd_lvl segspace [Prim ptp_Y] body let res_nm : _ = res_nms pure res_nm resultBodyM $ map Var loc_arr_merge2_nms' @@ -1177,7 +1182,8 @@ reg_arr_merge_nms' <- forLoop' rz reg_arr_merge_nms_slc $ \i reg_arr_mm_nms -> do letBindNames [gtid_z] =<< toExp (le64 ii + le64 i) - resultBodyM =<< letTupExp' "redomap_lam" + resultBodyM + =<< letTupExp' "redomap_lam" =<< eIf (toExp $ le64 gtid_z .<. pe64 d_M) ( do 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 @@ -235,7 +235,10 @@ local (addNameSubst pat' subpat) $ do let lets = [ Let (Pat [patElem']) (StmAux cs attrs edec) $ - BasicOp $ SubExp $ Var $ patElemName patElem + BasicOp $ + SubExp $ + Var $ + patElemName patElem | (name, patElem) <- zip (patNames pat') $ patElems subpat, let patElem' = patElem {patElemName = name} ] 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 @@ -245,7 +245,7 @@ in second (oneStm stm <>) <$> extractAllocOf bound' needle stms' where invariant Constant {} = True - invariant (Var v) = not $ v `nameIn` bound + invariant (Var v) = v `notNameIn` bound optimiseLoop :: Constraints rep inner => OptimiseLoop rep optimiseLoop pat merge body = do @@ -315,7 +315,8 @@ 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 + BasicOp $ + Copy arg -- We need to make this parameter unique to avoid invalid -- hoisting (see #1533), because we are invalidating the -- underlying memory. @@ -361,8 +362,10 @@ where params = map fst ctx_and_res loopVariant v = - v `nameIn` bound_in_loop - || v `elem` map (paramName . fst) ctx_and_res + v + `nameIn` bound_in_loop + || v + `elem` map (paramName . fst) ctx_and_res loopInvariantSize (Constant v) = Just (Constant v, True) @@ -467,7 +470,8 @@ summary = MemArray (elemType t) (arrayShape t) NoUniqueness $ ArrayIn bufname ixfun copystm = Let (Pat [PatElem copyname summary]) (defAux ()) $ - BasicOp $ Copy v + BasicOp $ + Copy v in (Just copystm, SubExpRes cs (Var copyname)) buffer _ _ se = (Nothing, se) 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 @@ -1,1135 +1,481 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | Perform horizontal and vertical fusion of SOACs. See the paper --- /A T2 Graph-Reduction Approach To Fusion/ for the basic idea (some --- extensions discussed in /Design and GPGPU Performance of Futhark’s --- Redomap Construct/). -module Futhark.Optimise.Fusion (fuseSOACs) where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import qualified Data.List as L -import qualified Data.Map.Strict as M -import Data.Maybe -import qualified Data.Set as S -import qualified Futhark.Analysis.Alias as Alias -import qualified Futhark.Analysis.HORep.SOAC as SOAC -import Futhark.Construct -import qualified Futhark.IR.Aliases as Aliases -import Futhark.IR.Prop.Aliases -import Futhark.IR.SOACS hiding (SOAC (..)) -import qualified Futhark.IR.SOACS as Futhark -import Futhark.IR.SOACS.Simplify -import Futhark.Optimise.Fusion.LoopKernel -import Futhark.Pass -import Futhark.Transform.Rename -import Futhark.Transform.Substitute -import Futhark.Util (maxinum) - -data VarEntry - = IsArray VName (NameInfo SOACS) Names SOAC.Input - | IsNotArray (NameInfo SOACS) - -varEntryType :: VarEntry -> NameInfo SOACS -varEntryType (IsArray _ dec _ _) = - dec -varEntryType (IsNotArray dec) = - dec - -varEntryAliases :: VarEntry -> Names -varEntryAliases (IsArray _ _ x _) = x -varEntryAliases _ = mempty - -data FusionGEnv = FusionGEnv - { -- | Mapping from variable name to its entire family. - soacs :: M.Map VName [VName], - varsInScope :: M.Map VName VarEntry, - fusedRes :: FusedRes - } - -lookupArr :: VName -> FusionGEnv -> Maybe SOAC.Input -lookupArr v env = asArray =<< M.lookup v (varsInScope env) - where - asArray (IsArray _ _ _ input) = Just input - asArray IsNotArray {} = Nothing - -newtype Error = Error String - -instance Show Error where - show (Error msg) = "Fusion error:\n" ++ msg - -newtype FusionGM a = FusionGM (ExceptT Error (StateT VNameSource (Reader FusionGEnv)) a) - deriving - ( Monad, - Applicative, - Functor, - MonadError Error, - MonadState VNameSource, - MonadReader FusionGEnv - ) - -instance MonadFreshNames FusionGM where - getNameSource = get - putNameSource = put - -instance HasScope SOACS FusionGM where - askScope = asks $ toScope . varsInScope - where - toScope = M.map varEntryType - ------------------------------------------------------------------------- ---- Monadic Helpers: bind/new/runFusionGatherM, etc ------------------------------------------------------------------------- - --- | Binds an array name to the set of used-array vars -bindVar :: FusionGEnv -> (Ident, Names) -> FusionGEnv -bindVar env (Ident name t, aliases) = - env {varsInScope = M.insert name entry $ varsInScope env} - where - entry = case t of - Array {} -> IsArray name (LetName t) aliases' $ SOAC.identInput $ Ident name t - _ -> IsNotArray $ LetName t - expand = maybe mempty varEntryAliases . flip M.lookup (varsInScope env) - aliases' = aliases <> mconcat (map expand $ namesToList aliases) - -bindVars :: FusionGEnv -> [(Ident, Names)] -> FusionGEnv -bindVars = foldl bindVar - -binding :: [(Ident, Names)] -> FusionGM a -> FusionGM a -binding vs = local (`bindVars` vs) - -gatherStmPat :: Pat Type -> Exp SOACS -> FusionGM FusedRes -> FusionGM FusedRes -gatherStmPat pat e = binding $ zip idents aliases - where - idents = patIdents pat - aliases = expAliases (Alias.analyseExp mempty e) - -bindingPat :: Pat Type -> 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 - --- | Binds an array name to the set of soac-produced vars -bindingFamilyVar :: [VName] -> FusionGEnv -> Ident -> FusionGEnv -bindingFamilyVar faml env (Ident nm t) = - env - { soacs = M.insert nm faml $ soacs env, - varsInScope = - M.insert - nm - ( IsArray nm (LetName t) mempty $ - SOAC.identInput $ Ident nm t - ) - $ varsInScope env - } - -varAliases :: VName -> FusionGM Names -varAliases v = - asks $ - (oneName v <>) . maybe mempty varEntryAliases - . M.lookup v - . varsInScope - -varsAliases :: Names -> FusionGM Names -varsAliases = fmap mconcat . mapM varAliases . namesToList - -updateKerInPlaces :: FusedRes -> ([VName], [VName]) -> FusionGM FusedRes -updateKerInPlaces res (ip_vs, other_infuse_vs) = do - res' <- foldM addVarToInfusible res (ip_vs ++ other_infuse_vs) - aliases <- mconcat <$> mapM varAliases ip_vs - let inspectKer k = k {inplace = aliases <> inplace k} - pure res' {kernels = M.map inspectKer $ kernels res'} - -checkForUpdates :: FusedRes -> Exp SOACS -> FusionGM FusedRes -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, []) -checkForUpdates res (BasicOp (UpdateAcc src slice _)) = do - let ifvs = namesToList $ freeIn slice - updateKerInPlaces res ([src], ifvs) -checkForUpdates res _ = pure res - --- | Updates the environment: (i) the @soacs@ (map) by binding each pattern --- element identifier to all pattern elements (identifiers) and (ii) the --- 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 :: Pat Type -> FusionGM FusedRes -> FusionGM FusedRes -bindingFamily pat = local bind - where - idents = patIdents pat - family = patNames pat - bind env = foldl (bindingFamilyVar family) env idents - -bindingTransform :: PatElem Type -> VName -> SOAC.ArrayTransform -> FusionGM a -> FusionGM a -bindingTransform pe srcname trns = local $ \env -> - case M.lookup srcname $ varsInScope env of - Just (IsArray src' _ aliases input) -> - env - { varsInScope = - M.insert - vname - ( IsArray src' (LetName dec) (oneName srcname <> aliases) $ - trns `SOAC.addTransform` input - ) - $ varsInScope env - } - _ -> bindVar env (patElemIdent pe, oneName vname) - where - vname = patElemName pe - dec = patElemDec pe - --- | Binds the fusion result to the environment. -bindRes :: FusedRes -> FusionGM a -> FusionGM a -bindRes rrr = local (\x -> x {fusedRes = rrr}) - --- | The fusion transformation runs in this monad. The mutable --- state refers to the fresh-names engine. --- The reader hides the vtable that associates ... to ... (fill in, please). --- The 'Either' monad is used for error handling. -runFusionGatherM :: - MonadFreshNames m => - FusionGM a -> - FusionGEnv -> - m (Either Error a) -runFusionGatherM (FusionGM a) env = - modifyNameSource $ \src -> runReader (runStateT (runExceptT a) src) env - ------------------------------------------------------------------------- ---- Fusion Entry Points: gather the to-be-fused kernels@pgm level --- ---- and fuse them in a second pass! --- ------------------------------------------------------------------------- - --- | The pass definition. -fuseSOACs :: Pass SOACS SOACS -fuseSOACs = - Pass - { passName = "Fuse SOACs", - passDescription = "Perform higher-order optimisation, i.e., fusion.", - passFunction = \prog -> - simplifySOACS =<< renameProg - =<< intraproceduralTransformationWithConsts - (fuseConsts (freeIn (progFuns prog))) - fuseFun - prog - } - -fuseConsts :: Names -> Stms SOACS -> PassM (Stms SOACS) -fuseConsts used_consts consts = - fuseStms mempty consts $ varsRes $ namesToList used_consts - -fuseFun :: Stms SOACS -> FunDef SOACS -> PassM (FunDef SOACS) -fuseFun consts fun = do - stms <- - fuseStms - (scopeOf consts <> scopeOfFParams (funDefParams fun)) - (bodyStms $ funDefBody fun) - (bodyResult $ funDefBody fun) - let body = (funDefBody fun) {bodyStms = stms} - pure fun {funDefBody = body} - -fuseStms :: Scope SOACS -> Stms SOACS -> Result -> PassM (Stms SOACS) -fuseStms scope stms res = do - let env = - FusionGEnv - { soacs = M.empty, - varsInScope = mempty, - fusedRes = mempty - } - k <- - cleanFusionResult - <$> liftEitherM - ( runFusionGatherM - (binding scope' $ fusionGatherStms mempty (stmsToList stms) res) - env - ) - if not $ rsucc k - then pure stms - else liftEitherM $ runFusionGatherM (binding scope' $ bindRes k $ fuseInStms stms) env - where - scope' = map toBind $ M.toList scope - toBind (k, t) = (Ident k $ typeOf t, mempty) - ---------------------------------------------------- ---------------------------------------------------- ----- RESULT's Data Structure ---------------------------------------------------- ---------------------------------------------------- - --- | A type used for (hopefully) uniquely referring a producer SOAC. --- The uniquely identifying value is the name of the first array --- returned from the SOAC. -newtype KernName = KernName {unKernName :: VName} - deriving (Eq, Ord, Show) - -data FusedRes = FusedRes - { -- | Whether we have fused something anywhere. - rsucc :: Bool, - -- | Associates an array to the name of the - -- SOAC kernel that has produced it. - outArr :: M.Map VName KernName, - -- | Associates an array to the names of the - -- SOAC kernels that uses it. These sets include - -- only the SOAC input arrays used as full variables, i.e., no `a[i]'. - inpArr :: M.Map VName (S.Set KernName), - -- | the (names of) arrays that are not fusible, i.e., - -- - -- 1. they are either used other than input to SOAC kernels, or - -- - -- 2. are used as input to at least two different kernels that - -- are not located on disjoint control-flow branches, or - -- - -- 3. are used in the lambda expression of SOACs - infusible :: Names, - -- | The map recording the uses - kernels :: M.Map KernName FusedKer - } - -instance Semigroup FusedRes where - res1 <> res2 = - FusedRes - (rsucc res1 || rsucc res2) - (outArr res1 `M.union` outArr res2) - (M.unionWith S.union (inpArr res1) (inpArr res2)) - (infusible res1 <> infusible res2) - (kernels res1 `M.union` kernels res2) - -instance Monoid FusedRes where - mempty = - FusedRes - { rsucc = False, - outArr = M.empty, - inpArr = M.empty, - infusible = mempty, - kernels = M.empty - } - -isInpArrInResModKers :: FusedRes -> S.Set KernName -> VName -> Bool -isInpArrInResModKers ress kers nm = - case M.lookup nm (inpArr ress) of - Nothing -> False - Just s -> not $ S.null $ s `S.difference` kers - -getKersWithInpArrs :: FusedRes -> [VName] -> S.Set KernName -getKersWithInpArrs ress = - S.unions . mapMaybe (`M.lookup` inpArr ress) - --- | extend the set of names to include all the names --- produced via SOACs (by querring the vtable's soac) -expandSoacInpArr :: [VName] -> FusionGM [VName] -expandSoacInpArr = - foldM - ( \y nm -> do - stm <- asks $ M.lookup nm . soacs - case stm of - Nothing -> pure (y ++ [nm]) - Just nns -> pure (y ++ nns) - ) - [] - ----------------------------------------------------------------------- ----------------------------------------------------------------------- - -soacInputs :: SOAC -> FusionGM ([VName], [VName]) -soacInputs soac = do - let (inp_idds, other_idds) = getIdentArr $ SOAC.inputs soac - (inp_nms0, other_nms0) = (inp_idds, other_idds) - inp_nms <- expandSoacInpArr inp_nms0 - other_nms <- expandSoacInpArr other_nms0 - pure (inp_nms, other_nms) - -addNewKerWithInfusible :: FusedRes -> ([Ident], StmAux (), SOAC, Names) -> Names -> FusionGM FusedRes -addNewKerWithInfusible res (idd, aux, soac, consumed) ufs = do - nm_ker <- KernName <$> newVName "ker" - scope <- askScope - let out_nms = map identName idd - new_ker = newKernel aux soac consumed out_nms scope - comb = M.unionWith S.union - os' = - M.fromList [(arr, nm_ker) | arr <- out_nms] - `M.union` outArr res - is' = - M.fromList - [ (arr, S.singleton nm_ker) - | arr <- map SOAC.inputArray $ SOAC.inputs soac - ] - `comb` inpArr res - pure $ - FusedRes - (rsucc res) - os' - is' - ufs - (M.insert nm_ker new_ker (kernels res)) - -lookupInput :: VName -> FusionGM (Maybe SOAC.Input) -lookupInput name = asks $ lookupArr name - -inlineSOACInput :: SOAC.Input -> FusionGM SOAC.Input -inlineSOACInput (SOAC.Input ts v t) = do - maybe_inp <- lookupInput v - case maybe_inp of - Nothing -> - pure $ SOAC.Input ts v t - Just (SOAC.Input ts2 v2 t2) -> - pure $ SOAC.Input (ts2 <> ts) v2 t2 - -inlineSOACInputs :: SOAC -> FusionGM SOAC -inlineSOACInputs soac = do - inputs' <- mapM inlineSOACInput $ SOAC.inputs soac - pure $ inputs' `SOAC.setInputs` soac - --- | Attempts to fuse between SOACs. Input: --- @rem_stms@ are the bindings remaining in the current body after @orig_soac@. --- @lam_used_nms@ the infusible names --- @res@ the fusion result (before processing the current soac) --- @orig_soac@ and @out_idds@ the current SOAC and its binding pattern --- @consumed@ is the set of names consumed by the SOAC. --- Output: a new Fusion Result (after processing the current SOAC binding) -greedyFuse :: - [Stm SOACS] -> - Names -> - FusedRes -> - (Pat Type, StmAux (), SOAC, Names) -> - FusionGM FusedRes -greedyFuse rem_stms 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 = patNames out_idds - isInfusible = (`nameIn` infusible res) - is_screma = case orig_soac of - SOAC.Screma _ form _ -> - (isJust (isRedomapSOAC form) || isJust (isScanomapSOAC form)) - && not (isJust (isReduceSOAC form) || isJust (isScanSOAC form)) - _ -> False - -- - -- Conditions for fusion: - -- If current soac is a replicate OR (current soac a redomap/scanomap AND - -- (i) none of @out_idds@ belongs to the infusible set) - -- THEN try applying producer-consumer fusion - -- ELSE try applying horizontal fusion - -- (without duplicating computation in both cases) - - (ok_kers_compat, fused_kers, fused_nms, old_kers, oldker_nms) <- - if is_screma || any isInfusible out_nms - then horizontGreedyFuse rem_stms res (out_idds, aux, soac, consumed) - else prodconsGreedyFuse res (out_idds, aux, soac, consumed) - -- - -- (ii) check whether fusing @soac@ will violate any in-place update - -- restriction, e.g., would move an input array past its in-place update. - all_used_names <- - fmap mconcat . mapM varAliases . namesToList $ - mconcat [lam_used_nms, namesFromList inp_nms, namesFromList other_nms] - let has_inplace ker = inplace ker `namesIntersect` all_used_names - ok_inplace = not $ any has_inplace old_kers - -- - -- (iii) there are some kernels that use some of `out_idds' as inputs - -- (iv) and producer-consumer or horizontal fusion succeeds with those. - let fusible_ker = not (null old_kers) && ok_inplace && ok_kers_compat - -- - -- Start constructing the fusion's result: - -- (i) inparr ids other than vars will be added to infusible list, - -- (ii) will also become part of the infusible set the inparr vars - -- that also appear as inparr of another kernel, - -- BUT which said kernel is not the one we are fusing with (now)! - let mod_kerS = if fusible_ker then S.fromList oldker_nms else mempty - let used_inps = filter (isInpArrInResModKers res mod_kerS) inp_nms - let ufs = - mconcat - [ infusible res, - namesFromList used_inps, - namesFromList other_nms - `namesSubtract` namesFromList (map SOAC.inputArray $ SOAC.inputs soac) - ] - let comb = M.unionWith S.union - - if not fusible_ker - 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 - let inpArr' = - foldl - ( \inpa (kold, knm) -> - S.foldl' - ( \inpp nm -> - case M.lookup nm inpp of - Nothing -> inpp - Just s -> - let new_set = S.delete knm s - in if S.null new_set - then M.delete nm inpp - else M.insert nm new_set inpp - ) - inpa - $ arrInputs kold - ) - (inpArr res) - (zip old_kers oldker_nms) - -- (ii) then add the inpArr bindings of the new kernel - let fused_ker_nms = zip fused_nms fused_kers - inpArr'' = - foldl - ( \inpa' (knm, knew) -> - M.fromList - [ (k, S.singleton knm) - | k <- S.toList $ arrInputs knew - ] - `comb` inpa' - ) - inpArr' - fused_ker_nms - -- Update the kernels map (why not delete the ones that have been fused?) - let kernels' = M.fromList fused_ker_nms `M.union` kernels res - -- nothing to do for `outArr' (since we have not added a new kernel) - -- DO IMPROVEMENT: attempt to fuse the resulting kernel AGAIN until it fails, - -- but make sure NOT to add a new kernel! - pure $ FusedRes True (outArr res) inpArr'' ufs kernels' - -prodconsGreedyFuse :: - FusedRes -> - (Pat Type, StmAux (), SOAC, Names) -> - FusionGM (Bool, [FusedKer], [KernName], [FusedKer], [KernName]) -prodconsGreedyFuse res (out_idds, aux, soac, consumed) = do - 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 - Nothing -> - throwError $ - Error - ( "In Fusion.hs, greedyFuse, comp of to_fuse_kers: " - ++ "kernel name not found in kernels field!" - ) - Just ker -> pure ker - to_fuse_kers <- mapM lookup_kern to_fuse_knms -- Get all consumer kernels - -- try producer-consumer fusion - (ok_kers_compat, fused_kers) <- do - kers <- - forM to_fuse_kers $ - attemptFusion mempty (patNames out_idds) soac consumed - case sequence kers of - Nothing -> pure (False, []) - Just kers' -> pure (True, map certifyKer kers') - pure (ok_kers_compat, fused_kers, to_fuse_knms, to_fuse_kers, to_fuse_knms) - where - certifyKer k = k {kerAux = kerAux k <> aux} - -horizontGreedyFuse :: - [Stm SOACS] -> - FusedRes -> - (Pat Type, StmAux (), SOAC, Names) -> - FusionGM (Bool, [FusedKer], [KernName], [FusedKer], [KernName]) -horizontGreedyFuse rem_stms res (out_idds, aux, soac, consumed) = do - (inp_nms, _) <- soacInputs soac - 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! - SOAC.Screma _ (ScremaForm scans reds _) _ -> - drop (scanResults scans + redResults reds) out_nms - SOAC.Stream _ _ _ nes _ -> drop (length nes) out_nms - _ -> out_nms - to_fuse_knms1 = S.toList $ getKersWithInpArrs res (out_arr_nms ++ inp_nms) - to_fuse_knms2 = getKersWithSameInpSize (SOAC.width soac) res - to_fuse_knms = S.toList $ S.fromList $ to_fuse_knms1 ++ to_fuse_knms2 - lookupKernel k = case M.lookup k (kernels res) of - Nothing -> - throwError $ - Error - ( "In Fusion.hs, greedyFuse, comp of to_fuse_kers: " - ++ "kernel name not found in kernels field!" - ) - Just ker -> pure ker - - -- For each kernel get the index in the bindings where the kernel is - -- 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 stm_nms = map (patNames . stmPat) rem_stms - kernminds <- forM to_fuse_knms $ \ker_nm -> do - ker <- lookupKernel ker_nm - case mapMaybe (\out_nm -> L.findIndex (elem out_nm) stm_nms) (outNames ker) of - [] -> pure Nothing - is -> pure $ Just (ker, ker_nm, maxinum is) - - scope <- askScope - let kernminds' = L.sortBy (\(_, _, i1) (_, _, i2) -> compare i1 i2) $ catMaybes kernminds - soac_kernel = newKernel aux soac consumed out_nms scope - - -- 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. - (_, ok_ind, _, fused_ker, _) <- - foldM - ( \(cur_ok, n, prev_ind, cur_ker, ufus_nms) (ker, _ker_nm, stm_ind) -> do - -- check that we still try fusion and that the intermediate - -- bindings do not use the results of cur_ker - let curker_outnms = outNames cur_ker - curker_outset = namesFromList curker_outnms - new_ufus_nms = namesFromList $ filter (`notNameIn` fusedConsumed ker) $ outNames ker ++ namesToList ufus_nms - ker_inp = SOAC.inputs $ fsoac ker - ker_inp_names = namesFromList (mapMaybe SOAC.isVarInput ker_inp) - - -- disable horizontal fusion in the case when an output array of - -- producer SOAC is a non-trivially transformed input of the consumer - out_transf_ok = - let unfuse1 = - namesFromList (map SOAC.inputArray ker_inp) - `namesSubtract` ker_inp_names - unfuse2 = namesIntersection curker_outset ufus_nms - in not $ unfuse1 `namesIntersect` unfuse2 - -- Disable horizontal fusion if consumer has any - -- output transforms. - cons_no_out_transf = SOAC.nullTransforms $ outputTransform ker - - -- 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_stms_ok = - cur_ok && consumer_ok && out_transf_ok && cons_no_out_transf - && foldl - ( \ok stm -> - ok - && not (curker_outset `namesIntersect` freeIn (stmExp stm)) - -- hardwired to False after first fail - -- (i) check that the in-between bindings do - -- not use the result of current kernel OR - || - -- (ii) that the pattern-binding corresponds to - -- the result of the consumer kernel; in the - -- latter case it means it corresponds to a - -- kernel that has been fused in the consumer, - -- hence it should be ignored - not - ( null $ - curker_outnms - `L.intersect` patNames (stmPat stm) - ) - ) - True - (drop (prev_ind + 1) $ take stm_ind rem_stms) - if not interm_stms_ok - then pure (False, n, stm_ind, cur_ker, mempty) - else do - -- Avoid keeping results that are consumed by the - -- consumer (#1613). The dance here is to still handle - -- horizontal fusion of scatter-scatter properly - -- (issue1284.fut). - let ufus_nms' = - ufus_nms `namesSubtract` (fusedConsumed ker `namesIntersection` ker_inp_names) - new_ker <- - attemptFusion - ufus_nms' - (outNames cur_ker) - (fsoac cur_ker) - (fusedConsumed cur_ker) - ker - case new_ker of - Nothing -> pure (False, n, stm_ind, cur_ker, mempty) - Just krn -> do - let krn' = krn {kerAux = aux <> kerAux krn} - pure (True, n + 1, stm_ind, krn', new_ufus_nms) - ) - (True, 0, 0, soac_kernel, infusible_nms) - kernminds' - - -- 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' - - pure (ok_ind > 0, [fused_ker], new_kernms, to_fuse_kers', to_fuse_knms') - where - getKersWithSameInpSize :: SubExp -> FusedRes -> [KernName] - getKersWithSameInpSize sz ress = - map fst $ filter (\(_, ker) -> sz == SOAC.width (fsoac ker)) $ M.toList $ kernels ress - ------------------------------------------------------------------------- ------------------------------------------------------------------------- ------------------------------------------------------------------------- ---- Fusion Gather for EXPRESSIONS and BODIES, --- ---- i.e., where work is being done: --- ---- i) bottom-up AbSyn traversal (backward analysis) --- ---- ii) soacs are fused greedily iff does not duplicate computation--- ---- E.g., (y1, y2, y3) = mapT(f, x1, x2[i]) --- ---- (z1, z2) = mapT(g1, y1, y2) --- ---- (q1, q2) = mapT(g2, y3, z1, a, y3) --- ---- res = reduce(op, ne, q1, q2, z2, y1, y3) --- ---- can be fused if y1,y2,y3, z1,z2, q1,q2 are not used elsewhere: --- ---- res = redomap(op, \(x1,x2i,a)-> --- ---- let (y1,y2,y3) = f (x1, x2i) in--- ---- let (z1,z2) = g1(y1, y2) in--- ---- let (q1,q2) = g2(y3, z1, a, y3) in--- ---- (q1, q2, z2, y1, y3) --- ---- x1, x2[i], a) --- ------------------------------------------------------------------------- ------------------------------------------------------------------------- ------------------------------------------------------------------------- - -fusionGatherBody :: FusedRes -> Body SOACS -> FusionGM FusedRes -fusionGatherBody fres (Body _ stms res) = - fusionGatherStms fres (stmsToList stms) res - -fusionGatherStms :: FusedRes -> [Stm SOACS] -> Result -> FusionGM FusedRes --- Some forms of do-loops can profitably be considered streamSeqs. We --- are careful to ensure that the generated nested loop cannot itself --- be considered a stream, to avoid infinite recursion. -fusionGatherStms - fres - (Let (Pat pes) stmtp (DoLoop merge (ForLoop i it w loop_vars) body) : stms) - res - | not $ null loop_vars, - -- We cannot turn a loop into a stream if it has variant sizes - -- in its parameters. - not $ any ((`nameIn` freeIn merge) . paramName . fst) merge = do - let (merge_params, merge_init) = unzip merge - (loop_params, loop_arrs) = unzip loop_vars - chunk_param <- newParam "chunk_size" $ Prim int64 - offset_param <- newParam "offset" $ Prim $ IntType it - let offset = paramName offset_param - chunk_size = paramName chunk_param - - acc_params <- forM merge_params $ \p -> - newParam (baseString (paramName p) ++ "_outer") (paramType p) - - chunked_params <- forM loop_vars $ \(p, arr) -> - newParam - (baseString arr ++ "_chunk") - (paramType p `arrayOfRow` Futhark.Var chunk_size) - - let lam_params = chunk_param : acc_params ++ [offset_param] ++ chunked_params - - lam_body <- runBodyBuilder $ - localScope (scopeOfLParams lam_params) $ do - let merge' = zip merge_params $ map (Futhark.Var . paramName) acc_params - j <- newVName "j" - loop_body <- runBodyBuilder $ do - forM_ (zip loop_params chunked_params) $ \(p, a_p) -> - letBindNames [paramName p] $ - BasicOp $ - Index (paramName a_p) $ - fullSlice (paramType a_p) [DimFix $ Futhark.Var j] - letBindNames [i] $ BasicOp $ BinOp (Add it OverflowUndef) (Futhark.Var offset) (Futhark.Var j) - pure body - eBody - [ pure $ - DoLoop merge' (ForLoop j it (Futhark.Var chunk_size) []) loop_body, - pure $ - BasicOp $ BinOp (Add Int64 OverflowUndef) (Futhark.Var offset) (Futhark.Var chunk_size) - ] - let lam = - Lambda - { lambdaParams = lam_params, - lambdaBody = lam_body, - lambdaReturnType = map paramType $ acc_params ++ [offset_param] - } - stream = Futhark.Stream w loop_arrs Sequential (merge_init ++ [intConst it 0]) lam - - -- It is important that the (discarded) final-offset is not the - -- first element in the pattern, as we use the first element to - -- identify the SOAC in the second phase of fusion. - discard <- newVName "discard" - let discard_pe = PatElem discard $ Prim int64 - - fusionGatherStms - fres - (Let (Pat (pes <> [discard_pe])) stmtp (Op stream) : stms) - res -fusionGatherStms fres (stm@(Let pat _ e) : stms) res = do - maybesoac <- SOAC.fromExp e - case maybesoac of - Right soac@(SOAC.Scatter _len lam _ivs _as) -> do - -- 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 $ 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 $ 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]) $ - concatMap scanNeutral scans <> concatMap redNeutral reds - Right soac@(SOAC.Stream _ form lam nes _) -> do - -- a redomap does not neccessarily start a new kernel, e.g., - -- @let a= reduce(+,0,A) in ... stms ... in let B = map(f,A)@ - -- can be fused into a redomap that replaces the @map@, if @a@ - -- and @B@ are defined in the same scope and @stms@ does not uses @a@. - -- a redomap always starts a new kernel - let lambdas = case form of - Parallel _ _ lout -> [lout, lam] - Sequential -> [lam] - reduceLike soac lambdas nes - _ - | Pat [pe] <- pat, - Just (src, trns) <- SOAC.transformFromExp (stmCerts stm) e -> - bindingTransform pe src trns $ fusionGatherStms fres stms res - | otherwise -> do - let pat_vars = map (BasicOp . SubExp . Var) $ patNames pat - bres <- gatherStmPat pat e $ fusionGatherStms fres stms res - bres' <- checkForUpdates bres e - foldM fusionGatherExp bres' (e : pat_vars) - where - aux = stmAux stm - rem_stms = stm : stms - consumed = consumedInExp $ Alias.analyseExp mempty e - - reduceLike soac lambdas nes = do - (used_lam, lres) <- foldM fusionGatherLam (mempty, fres) lambdas - bres <- bindingFamily pat $ fusionGatherStms lres stms res - bres' <- foldM fusionGatherSubExp bres nes - consumed' <- varsAliases consumed - greedyFuse rem_stms used_lam bres' (pat, aux, soac, consumed') - - mapLike fres' soac lambda = do - bres <- bindingFamily pat $ fusionGatherStms fres' stms res - (used_lam, blres) <- fusionGatherLam (mempty, bres) lambda - consumed' <- varsAliases consumed - greedyFuse rem_stms used_lam blres (pat, aux, soac, consumed') -fusionGatherStms fres [] res = - foldM fusionGatherExp fres $ map (BasicOp . SubExp . resSubExp) res - -fusionGatherExp :: FusedRes -> Exp SOACS -> FusionGM FusedRes -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 -> - Ident i (Prim (IntType it)) : map (paramIdent . fst) loopvars - WhileLoop {} -> [] - - new_res <- - 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 - let new_res' = new_res {infusible = infusible new_res <> mconcat (map oneName inp_arrs)} - -- merge new_res with fres' - pure $ new_res' <> fres' -fusionGatherExp fres (If cond e_then e_else _) = do - then_res <- fusionGatherBody mempty e_then - else_res <- fusionGatherBody mempty e_else - let both_res = then_res <> else_res - fres' <- fusionGatherSubExp fres cond - mergeFusionRes fres' both_res -fusionGatherExp fres (WithAcc inps lam) = do - (_, fres') <- fusionGatherLam (mempty, fres) lam - addNamesToInfusible fres' $ freeIn inps - ------------------------------------------------------------------------------------ ---- Errors: all SOACs, (because normalization ensures they appear ---- directly in let exp, i.e., let x = e) ------------------------------------------------------------------------------------ - -fusionGatherExp _ (Op Futhark.Screma {}) = errorIllegal "screma" -fusionGatherExp _ (Op Futhark.Scatter {}) = errorIllegal "write" -fusionGatherExp fres (Op (Futhark.VJP lam _ _)) = - snd <$> fusionGatherLam (mempty, fres) lam -fusionGatherExp fres (Op (Futhark.JVP lam _ _)) = - snd <$> fusionGatherLam (mempty, fres) lam --- -fusionGatherExp fres e = addNamesToInfusible fres $ freeIn e - -fusionGatherSubExp :: FusedRes -> SubExp -> FusionGM FusedRes -fusionGatherSubExp fres (Var idd) = addVarToInfusible fres idd -fusionGatherSubExp fres _ = pure fres - -addNamesToInfusible :: FusedRes -> Names -> FusionGM FusedRes -addNamesToInfusible fres = foldM addVarToInfusible fres . namesToList - -addVarToInfusible :: FusedRes -> VName -> FusionGM FusedRes -addVarToInfusible fres name = do - trns <- asks $ lookupArr name - let name' = case trns of - Nothing -> name - Just (SOAC.Input _ orig _) -> orig - pure fres {infusible = oneName name' <> infusible fres} - --- Lambdas create a new scope. Disallow fusing from outside lambda by --- adding inp_arrs to the infusible set. -fusionGatherLam :: (Names, FusedRes) -> Lambda SOACS -> FusionGM (Names, FusedRes) -fusionGatherLam (u_set, fres) (Lambda idds body _) = do - new_res <- bindingParams idds $ fusionGatherBody mempty body - -- make the inpArr infusible, so that they - -- cannot be fused from outside the lambda: - let inp_arrs = namesFromList $ M.keys $ inpArr new_res - let unfus = infusible new_res <> inp_arrs - stms <- asks $ M.keys . varsInScope - let unfus' = unfus `namesIntersection` namesFromList stms - -- merge fres with new_res' - let new_res' = new_res {infusible = unfus'} - -- merge new_res with fres' - pure (u_set <> unfus', new_res' <> fres) - -------------------------------------------------------------- -------------------------------------------------------------- ---- FINALLY, Substitute the kernels in function -------------------------------------------------------------- -------------------------------------------------------------- - -fuseInStms :: Stms SOACS -> FusionGM (Stms SOACS) -fuseInStms stms - | Just (Let pat aux e, stms') <- stmsHead stms = do - stms'' <- bindingPat pat $ fuseInStms stms' - soac_stms <- replaceSOAC pat aux e - pure $ soac_stms <> stms'' - | otherwise = - pure mempty - -fuseInBody :: Body SOACS -> FusionGM (Body SOACS) -fuseInBody (Body _ stms res) = - Body () <$> fuseInStms stms <*> pure res - -fuseInExp :: Exp SOACS -> FusionGM (Exp SOACS) --- Handle loop specially because we need to bind the types of the --- merge variables. -fuseInExp (DoLoop merge form loopbody) = - binding (zip form_idents $ repeat mempty) $ - bindingParams (map fst merge) $ - DoLoop merge form <$> fuseInBody loopbody - where - form_idents = case form of - WhileLoop {} -> [] - ForLoop i it _ loopvars -> - Ident i (Prim $ IntType it) : - map (paramIdent . fst) loopvars -fuseInExp e = mapExpM fuseIn e - -fuseIn :: Mapper SOACS SOACS FusionGM -fuseIn = - identityMapper - { mapOnBody = const fuseInBody, - mapOnOp = mapSOACM identitySOACMapper {mapOnSOACLambda = fuseInLambda} - } - -fuseInLambda :: Lambda SOACS -> FusionGM (Lambda SOACS) -fuseInLambda (Lambda params body rtp) = do - body' <- bindingParams params $ fuseInBody body - pure $ Lambda params body' rtp - -replaceSOAC :: Pat Type -> StmAux () -> Exp SOACS -> FusionGM (Stms SOACS) -replaceSOAC (Pat []) _ _ = pure mempty -replaceSOAC pat@(Pat (patElem : _)) aux e = do - fres <- asks fusedRes - let pat_nm = patElemName patElem - names = patIdents pat - case M.lookup pat_nm (outArr fres) of - Nothing -> - oneStm . Let pat aux <$> fuseInExp e - Just knm -> - case M.lookup knm (kernels fres) of - Nothing -> - throwError $ - Error - ( "In Fusion.hs, replaceSOAC, outArr in ker_name " - ++ "which is not in Res: " - ++ pretty (unKernName knm) - ) - Just ker -> do - when (null $ fusedVars ker) $ - throwError $ - Error - ( "In Fusion.hs, replaceSOAC, unfused kernel " - ++ "still in result: " - ++ pretty names - ) - insertKerSOAC aux (outNames ker) ker - -insertKerSOAC :: StmAux () -> [VName] -> FusedKer -> FusionGM (Stms SOACS) -insertKerSOAC aux names ker = do - new_soac' <- finaliseSOAC $ fsoac ker - 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 (basicPat validents) $ Op f_soac' - transformOutput (outputTransform ker) names validents - --- | Perform simplification and fusion inside the lambda(s) of a SOAC. -finaliseSOAC :: SOAC.SOAC SOACS -> FusionGM (SOAC.SOAC SOACS) -finaliseSOAC new_soac = - case new_soac of - SOAC.Screma w (ScremaForm scans reds map_lam) arrs -> do - scans' <- forM scans $ \(Scan scan_lam scan_nes) -> do - scan_lam' <- simplifyAndFuseInLambda scan_lam - pure $ Scan scan_lam' scan_nes - - reds' <- forM reds $ \(Reduce comm red_lam red_nes) -> do - red_lam' <- simplifyAndFuseInLambda red_lam - pure $ Reduce comm red_lam' red_nes - - map_lam' <- simplifyAndFuseInLambda map_lam - - pure $ SOAC.Screma w (ScremaForm scans' reds' map_lam') arrs - SOAC.Scatter w lam inps dests -> do - lam' <- simplifyAndFuseInLambda lam - pure $ SOAC.Scatter w lam' inps dests - SOAC.Hist w ops lam arrs -> do - lam' <- simplifyAndFuseInLambda lam - pure $ SOAC.Hist w ops lam' arrs - SOAC.Stream w form lam nes inps -> do - lam' <- simplifyAndFuseInLambda lam - pure $ SOAC.Stream w form lam' nes inps - -simplifyAndFuseInLambda :: Lambda SOACS -> FusionGM (Lambda SOACS) -simplifyAndFuseInLambda lam = do - lam' <- simplifyLambda lam - (_, nfres) <- fusionGatherLam (mempty, mkFreshFusionRes) lam' - let nfres' = cleanFusionResult nfres - bindRes nfres' $ fuseInLambda lam' - -copyNewlyConsumed :: - Names -> - Futhark.SOAC (Aliases.Aliases SOACS) -> - Builder SOACS (Futhark.SOAC SOACS) -copyNewlyConsumed was_consumed soac = - case soac of - Futhark.Screma w arrs (Futhark.ScremaForm scans reds map_lam) -> do - -- Copy any arrays that are consumed now, but were not in the - -- constituents. - arrs' <- mapM copyConsumedArr arrs - -- Any consumed free variables will have to be copied inside the - -- lambda, and we have to substitute the name of the copy for - -- the original. - map_lam' <- copyFreeInLambda map_lam - - let scans' = - map - ( \scan -> - scan - { scanLambda = - Aliases.removeLambdaAliases - (scanLambda scan) - } - ) - scans - - let reds' = - map - ( \red -> - red - { redLambda = - Aliases.removeLambdaAliases - (redLambda red) - } - ) - reds - - pure $ Futhark.Screma w arrs' $ Futhark.ScremaForm scans' reds' map_lam' - _ -> pure $ removeOpAliases soac - where - consumed = consumedInOp soac - newly_consumed = consumed `namesSubtract` was_consumed - - copyConsumedArr a - | a `nameIn` newly_consumed = - letExp (baseString a <> "_copy") $ BasicOp $ Copy a - | otherwise = pure a - - copyFreeInLambda lam = do - let free_consumed = - consumedByLambda lam - `namesSubtract` namesFromList (map paramName $ lambdaParams lam) - (stms, subst) <- - foldM copyFree (mempty, mempty) $ namesToList free_consumed - let lam' = Aliases.removeLambdaAliases lam - pure $ - if null stms - then lam' - else - lam' - { lambdaBody = - insertStms stms $ - substituteNames subst $ lambdaBody lam' - } - - copyFree (stms, subst) v = do - v_copy <- newVName $ baseString v <> "_copy" - copy <- mkLetNamesM [v_copy] $ BasicOp $ Copy v - pure (oneStm copy <> stms, M.insert v v_copy subst) - ---------------------------------------------------- ---------------------------------------------------- ----- HELPERS ---------------------------------------------------- ---------------------------------------------------- - --- | Get a new fusion result, i.e., for when entering a new scope, --- e.g., a new lambda or a new loop. -mkFreshFusionRes :: FusedRes -mkFreshFusionRes = - FusedRes - { rsucc = False, - outArr = M.empty, - inpArr = M.empty, - infusible = mempty, - kernels = M.empty - } - -mergeFusionRes :: FusedRes -> FusedRes -> FusionGM FusedRes -mergeFusionRes res1 res2 = do - let ufus_mres = infusible res1 <> infusible res2 - inp_both <- expandSoacInpArr $ M.keys $ inpArr res1 `M.intersection` inpArr res2 - let m_unfus = ufus_mres <> mconcat (map oneName inp_both) - pure $ - FusedRes - (rsucc res1 || rsucc res2) - (outArr res1 `M.union` outArr res2) - (M.unionWith S.union (inpArr res1) (inpArr res2)) - m_unfus - (kernels res1 `M.union` kernels res2) - --- | The expression arguments are supposed to be array-type exps. --- Returns a tuple, in which the arrays that are vars are in the --- first element of the tuple, and the one which are indexed or --- transposes (or otherwise transformed) should be in the second. --- --- E.g., for expression `mapT(f, a, b[i])', the result should be --- `([a],[b])' -getIdentArr :: [SOAC.Input] -> ([VName], [VName]) -getIdentArr = foldl comb ([], []) - where - comb (vs, os) (SOAC.Input ts idd _) - | SOAC.nullTransforms ts = (idd : vs, os) - comb (vs, os) inp = - (vs, SOAC.inputArray inp : os) - -cleanFusionResult :: FusedRes -> FusedRes -cleanFusionResult fres = - let newks = M.filter (not . null . fusedVars) (kernels fres) - newoa = M.filter (`M.member` newks) (outArr fres) - newia = M.map (S.filter (`M.member` newks)) (inpArr fres) - in fres {outArr = newoa, inpArr = newia, kernels = newks} - --------------- ---- Errors --- --------------- - -errorIllegal :: String -> FusionGM FusedRes -errorIllegal soac_name = - throwError $ - Error - ("In Fusion.hs, soac " ++ soac_name ++ " appears illegally in pgm!") + +-- | Perform horizontal and vertical fusion of SOACs. See the paper +-- /A T2 Graph-Reduction Approach To Fusion/ for the basic idea (some +-- extensions discussed in /Design and GPGPU Performance of Futhark’s +-- Redomap Construct/). +module Futhark.Optimise.Fusion (fuseSOACs) where + +import Control.Monad.Reader +import Control.Monad.State +import qualified Data.Graph.Inductive.Graph as G +import qualified Data.Graph.Inductive.Query.DFS as Q +import qualified Data.List as L +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Futhark.Analysis.Alias as Alias +import qualified Futhark.Analysis.HORep.SOAC as H +import Futhark.Construct +import Futhark.IR.Prop.Aliases +import Futhark.IR.SOACS hiding (SOAC (..)) +import qualified Futhark.IR.SOACS as Futhark +import Futhark.IR.SOACS.Simplify (simplifyLambda) +import Futhark.Optimise.Fusion.GraphRep +import qualified Futhark.Optimise.Fusion.TryFusion as TF +import Futhark.Pass +import Futhark.Transform.Rename +import Futhark.Transform.Substitute + +data FusionEnv = FusionEnv + { vNameSource :: VNameSource, + fusionCount :: Int, + fuseScans :: Bool + } + +freshFusionEnv :: FusionEnv +freshFusionEnv = + FusionEnv + { vNameSource = blankNameSource, + fusionCount = 0, + fuseScans = True + } + +newtype FusionM a = FusionM (ReaderT (Scope SOACS) (State FusionEnv) a) + deriving + ( Monad, + Applicative, + Functor, + MonadState FusionEnv, + HasScope SOACS, + LocalScope SOACS + ) + +instance MonadFreshNames FusionM where + getNameSource = gets vNameSource + putNameSource source = + modify (\env -> env {vNameSource = source}) + +runFusionM :: MonadFreshNames m => Scope SOACS -> FusionEnv -> FusionM a -> m a +runFusionM scope fenv (FusionM a) = modifyNameSource $ \src -> + let x = runReaderT a scope + (y, z) = runState x (fenv {vNameSource = src}) + in (y, vNameSource z) + +doFuseScans :: FusionM a -> FusionM a +doFuseScans m = do + fs <- gets fuseScans + modify (\s -> s {fuseScans = True}) + r <- m + modify (\s -> s {fuseScans = fs}) + pure r + +dontFuseScans :: FusionM a -> FusionM a +dontFuseScans m = do + fs <- gets fuseScans + modify (\s -> s {fuseScans = False}) + r <- m + modify (\s -> s {fuseScans = fs}) + pure r + +unreachableEitherDir :: DepGraph -> G.Node -> G.Node -> Bool +unreachableEitherDir g a b = + not (reachable g a b || reachable g b a) + +isNotVarInput :: [H.Input] -> [H.Input] +isNotVarInput = filter (isNothing . H.isVarInput) + +finalizeNode :: (HasScope SOACS m, MonadFreshNames m) => NodeT -> m (Stms SOACS) +finalizeNode nt = case nt of + StmNode stm -> pure $ oneStm stm + SoacNode ots outputs soac aux -> runBuilder_ $ do + untransformed_outputs <- mapM newName $ patNames outputs + auxing aux $ letBindNames untransformed_outputs . Op =<< H.toSOAC soac + forM_ (zip (patNames outputs) untransformed_outputs) $ \(output, v) -> + letBindNames [output] . BasicOp . SubExp . Var =<< H.applyTransforms ots v + ResNode _ -> pure mempty + FreeNode _ -> pure mempty + DoNode stm lst -> do + lst' <- mapM (finalizeNode . fst) lst + pure $ mconcat lst' <> oneStm stm + IfNode stm lst -> do + lst' <- mapM (finalizeNode . fst) lst + pure $ mconcat lst' <> oneStm stm + FinalNode stms1 nt' stms2 -> do + stms' <- finalizeNode nt' + pure $ stms1 <> stms' <> stms2 + +linearizeGraph :: (HasScope SOACS m, MonadFreshNames m) => DepGraph -> m (Stms SOACS) +linearizeGraph dg = + fmap mconcat $ mapM finalizeNode $ reverse $ Q.topsort' (dgGraph dg) + +fusedSomething :: NodeT -> FusionM (Maybe NodeT) +fusedSomething x = do + modify $ \s -> s {fusionCount = 1 + fusionCount s} + pure $ Just x + +-- | For each node, find what came before, attempt to fuse them +-- horizontally. This means we only perform horizontal fusion for +-- SOACs that use the same input in some way. +horizontalFusionOnNode :: G.Node -> DepGraphAug FusionM +horizontalFusionOnNode node dg@DepGraph {dgGraph = g} = + applyAugs (map (uncurry hTryFuseNodesInGraph) pairs) dg + where + incoming_nodes = map fst $ filter (isDep . snd) $ G.lpre g node + pairs = [(x, y) | x <- incoming_nodes, y <- incoming_nodes, x < y] + +vFusionFeasability :: DepGraph -> G.Node -> G.Node -> Bool +vFusionFeasability dg@DepGraph {dgGraph = g} n1 n2 = + not (any isInf (edgesBetween dg n1 n2)) + && not (any (reachable dg n2) (filter (/= n2) (G.pre g n1))) + +hFusionFeasability :: DepGraph -> G.Node -> G.Node -> Bool +hFusionFeasability = unreachableEitherDir + +tryFuseNodeInGraph :: DepNode -> DepGraphAug FusionM +tryFuseNodeInGraph node_to_fuse dg@DepGraph {dgGraph = g} = + if G.gelem node_to_fuse_id g + then applyAugs (map (vTryFuseNodesInGraph node_to_fuse_id) fuses_with) dg + else pure dg + where + fuses_with = map fst $ filter (isDep . snd) $ G.lpre g (nodeFromLNode node_to_fuse) + node_to_fuse_id = nodeFromLNode node_to_fuse + +vTryFuseNodesInGraph :: G.Node -> G.Node -> DepGraphAug FusionM +-- find the neighbors -> verify that fusion causes no cycles -> fuse +vTryFuseNodesInGraph node_1 node_2 dg@DepGraph {dgGraph = g} + | not (G.gelem node_1 g && G.gelem node_2 g) = pure dg + | vFusionFeasability dg node_1 node_2 = do + let (ctx1, ctx2) = (G.context g node_1, G.context g node_2) + fres <- vFuseContexts edgs infusable_nodes ctx1 ctx2 + case fres of + Just (inputs, _, nodeT, outputs) -> do + nodeT' <- + if null fusedC + then pure nodeT + else do + let (_, _, _, deps_1) = ctx1 + (_, _, _, deps_2) = ctx2 + -- make copies of everything that was not + -- previously consumed + old_cons = map (getName . fst) $ filter (isCons . fst) (deps_1 <> deps_2) + makeCopiesOfFusedExcept old_cons nodeT + contractEdge node_2 (inputs, node_1, nodeT', outputs) dg + Nothing -> pure dg + | otherwise = pure dg + where + edgs = map G.edgeLabel $ edgesBetween dg node_1 node_2 + fusedC = map getName $ filter isCons edgs + infusable_nodes = + map + depsFromEdge + (concatMap (edgesBetween dg node_1) (filter (/= node_2) $ G.pre g node_1)) + +hTryFuseNodesInGraph :: G.Node -> G.Node -> DepGraphAug FusionM +hTryFuseNodesInGraph node_1 node_2 dg@DepGraph {dgGraph = g} + | not (G.gelem node_1 g && G.gelem node_2 g) = pure dg + | hFusionFeasability dg node_1 node_2 = do + fres <- hFuseContexts (G.context g node_1) (G.context g node_2) + case fres of + Just ctx -> contractEdge node_2 ctx dg + Nothing -> pure dg + | otherwise = pure dg + +hFuseContexts :: DepContext -> DepContext -> FusionM (Maybe DepContext) +hFuseContexts + c1@(_, _, nodeT1, _) + c2@(_, _, nodeT2, _) = do + fres <- hFuseNodeT nodeT1 nodeT2 + case fres of + Just nodeT -> pure $ Just (mergedContext nodeT c1 c2) + Nothing -> pure Nothing + +vFuseContexts :: [EdgeT] -> [VName] -> DepContext -> DepContext -> FusionM (Maybe DepContext) +vFuseContexts + edgs + infusable + c1@(i1, n1, nodeT1, o1) + c2@(_i2, n2, nodeT2, o2) = do + fres <- + vFuseNodeT + edgs + infusable + (nodeT1, map fst $ filter ((/=) n2 . snd) i1, map fst o1) + (nodeT2, map fst $ filter ((/=) n1 . snd) o2) + case fres of + Just nodeT -> pure $ Just (mergedContext nodeT c1 c2) + Nothing -> pure Nothing + +makeCopiesOfFusedExcept :: + (LocalScope SOACS m, MonadFreshNames m) => + [VName] -> + NodeT -> + m NodeT +makeCopiesOfFusedExcept noCopy (SoacNode ots pats soac aux) = do + let lam = H.lambda soac + localScope (scopeOf lam) $ do + fused_inner <- + filterM (fmap (not . isAcc) . lookupType) . namesToList . consumedByLambda $ + Alias.analyseLambda mempty lam + lam' <- makeCopiesInLambda (fused_inner L.\\ noCopy) lam + pure $ SoacNode ots pats (H.setLambda lam' soac) aux +makeCopiesOfFusedExcept _ nodeT = pure nodeT + +makeCopiesInLambda :: + (LocalScope SOACS m, MonadFreshNames m) => + [VName] -> + Lambda SOACS -> + m (Lambda SOACS) +makeCopiesInLambda toCopy lam = do + (copies, nameMap) <- makeCopyStms toCopy + let l_body = lambdaBody lam + newBody = insertStms copies (substituteNames nameMap l_body) + newLambda = lam {lambdaBody = newBody} + pure newLambda + +makeCopyStms :: + (LocalScope SOACS m, MonadFreshNames m) => + [VName] -> + m (Stms SOACS, M.Map VName VName) +makeCopyStms vs = do + vs' <- mapM makeNewName vs + copies <- forM (zip vs vs') $ \(name, name') -> + mkLetNames [name'] $ BasicOp $ Copy name + pure (stmsFromList copies, M.fromList $ zip vs vs') + where + makeNewName name = newVName $ baseString name <> "_copy" + +okToFuseProducer :: H.SOAC SOACS -> FusionM Bool +okToFuseProducer (H.Screma _ form _) = do + let is_scan = isJust $ Futhark.isScanomapSOAC form + gets $ (not is_scan ||) . fuseScans +okToFuseProducer _ = pure True + +-- First node is producer, second is consumer. +vFuseNodeT :: [EdgeT] -> [VName] -> (NodeT, [EdgeT], [EdgeT]) -> (NodeT, [EdgeT]) -> FusionM (Maybe NodeT) +vFuseNodeT _ infusible (s1, _, e1s) (IfNode stm2 dfused, _) + | isRealNode s1, + null infusible = + pure $ Just $ IfNode stm2 $ (s1, e1s) : dfused +vFuseNodeT _ infusible (StmNode stm1, _, _) (SoacNode ots2 pats2 soac2 aux2, _) + | null infusible, + [stm1_out] <- patNames $ stmPat stm1, + Just (stm1_in, tr) <- + H.transformFromExp (stmAuxCerts (stmAux stm1)) (stmExp stm1) = do + stm1_in_t <- lookupType stm1_in + let onInput inp + | H.inputArray inp == stm1_out = + H.Input (tr H.<| H.inputTransforms inp) stm1_in stm1_in_t + | otherwise = + inp + soac2' = map onInput (H.inputs soac2) `H.setInputs` soac2 + pure $ Just $ SoacNode ots2 pats2 soac2' aux2 +vFuseNodeT + _ + _ + (SoacNode ots1 pats1 soac1 aux1, i1s, _e1s) + (SoacNode ots2 pats2 soac2 aux2, _e2s) = do + let ker = + TF.FusedSOAC + { TF.fsSOAC = soac2, + TF.fsOutputTransform = ots2, + TF.fsOutNames = patNames pats2 + } + preserveEdge InfDep {} = True + preserveEdge e = isDep e + preserve = namesFromList $ map getName $ filter preserveEdge i1s + ok <- okToFuseProducer soac1 + r <- + if ok && ots1 == mempty + then TF.attemptFusion preserve (patNames pats1) soac1 ker + else pure Nothing + case r of + Just ker' -> do + let pats2' = + zipWith PatElem (TF.fsOutNames ker') (H.typeOf (TF.fsSOAC ker')) + fusedSomething $ + SoacNode + (TF.fsOutputTransform ker') + (Pat pats2') + (TF.fsSOAC ker') + (aux1 <> aux2) + Nothing -> pure Nothing +vFuseNodeT _ _ _ _ = pure Nothing + +resFromLambda :: Lambda rep -> Result +resFromLambda = bodyResult . lambdaBody + +hasNoDifferingInputs :: [H.Input] -> [H.Input] -> Bool +hasNoDifferingInputs is1 is2 = + let (vs1, vs2) = (isNotVarInput is1, isNotVarInput $ is2 L.\\ is1) + in null $ vs1 `L.intersect` vs2 + +hFuseNodeT :: NodeT -> NodeT -> FusionM (Maybe NodeT) +hFuseNodeT (SoacNode ots1 pats1 soac1 aux1) (SoacNode ots2 pats2 soac2 aux2) + | ots1 == mempty, + ots2 == mempty, + hasNoDifferingInputs (H.inputs soac1) (H.inputs soac2) = do + let ker = + TF.FusedSOAC + { TF.fsSOAC = soac2, + TF.fsOutputTransform = mempty, + TF.fsOutNames = patNames pats2 + } + preserve = namesFromList $ patNames pats1 + r <- TF.attemptFusion preserve (patNames pats1) soac1 ker + case r of + Just ker' -> do + let pats2' = + zipWith PatElem (TF.fsOutNames ker') (H.typeOf (TF.fsSOAC ker')) + fusedSomething $ SoacNode mempty (Pat pats2') (TF.fsSOAC ker') (aux1 <> aux2) + Nothing -> pure Nothing +hFuseNodeT _ _ = pure Nothing + +removeOutputsExcept :: [VName] -> NodeT -> NodeT +removeOutputsExcept toKeep s = case s of + SoacNode ots (Pat pats1) soac@(H.Screma _ (ScremaForm scans_1 red_1 lam_1) _) aux1 -> + SoacNode ots (Pat $ pats_unchanged <> pats_new) (H.setLambda lam_new soac) aux1 + where + scan_output_size = Futhark.scanResults scans_1 + red_output_size = Futhark.redResults red_1 + + (pats_unchanged, pats_toChange) = splitAt (scan_output_size + red_output_size) pats1 + (res_unchanged, res_toChange) = splitAt (scan_output_size + red_output_size) (zip (resFromLambda lam_1) (lambdaReturnType lam_1)) + + (pats_new, other) = unzip $ filter (\(x, _) -> patElemName x `elem` toKeep) (zip pats_toChange res_toChange) + (results, types) = unzip (res_unchanged ++ other) + lam_new = + lam_1 + { lambdaReturnType = types, + lambdaBody = (lambdaBody lam_1) {bodyResult = results} + } + node -> node + +vNameFromAdj :: G.Node -> (EdgeT, G.Node) -> VName +vNameFromAdj n1 (edge, n2) = depsFromEdge (n2, n1, edge) + +removeUnusedOutputsFromContext :: DepContext -> FusionM DepContext +removeUnusedOutputsFromContext (incoming, n1, nodeT, outgoing) = + pure (incoming, n1, nodeT', outgoing) + where + toKeep = map (vNameFromAdj n1) incoming + nodeT' = removeOutputsExcept toKeep nodeT + +removeUnusedOutputs :: DepGraphAug FusionM +removeUnusedOutputs = mapAcross removeUnusedOutputsFromContext + +doVerticalFusion :: DepGraphAug FusionM +doVerticalFusion dg = applyAugs (map tryFuseNodeInGraph $ reverse $ G.labNodes (dgGraph dg)) dg + +doHorizontalFusion :: DepGraphAug FusionM +doHorizontalFusion dg = applyAugs (map horizontalFusionOnNode (G.nodes (dgGraph dg))) dg + +doInnerFusion :: DepGraphAug FusionM +doInnerFusion = mapAcross runInnerFusionOnContext + +-- Fixed-point iteration. +keepTrying :: DepGraphAug FusionM -> DepGraphAug FusionM +keepTrying f g = do + prev_fused <- gets fusionCount + g' <- f g + aft_fused <- gets fusionCount + if prev_fused /= aft_fused then keepTrying f g' else pure g' + +doAllFusion :: DepGraphAug FusionM +doAllFusion = + applyAugs + [ keepTrying . applyAugs $ + [ doVerticalFusion, + doHorizontalFusion, + doInnerFusion + ], + removeUnusedOutputs + ] + +runInnerFusionOnContext :: DepContext -> FusionM DepContext +runInnerFusionOnContext c@(incoming, node, nodeT, outgoing) = case nodeT of + DoNode (Let pat aux (DoLoop params form body)) to_fuse -> + doFuseScans . localScope (scopeOfFParams (map fst params) <> scopeOf form) $ do + b <- doFusionWithDelayed body to_fuse + pure (incoming, node, DoNode (Let pat aux (DoLoop params form b)) [], outgoing) + IfNode (Let pat aux (If sz b1 b2 dec)) to_fuse -> doFuseScans $ do + b1' <- doFusionWithDelayed b1 to_fuse + b2' <- doFusionWithDelayed b2 to_fuse + rb2' <- renameBody b2' + pure (incoming, node, IfNode (Let pat aux (If sz b1' rb2' dec)) [], outgoing) + StmNode (Let pat aux (Op (Futhark.VJP lam args vec))) -> doFuseScans $ do + lam' <- doFusionLambda lam + pure (incoming, node, StmNode (Let pat aux (Op (Futhark.VJP lam' args vec))), outgoing) + StmNode (Let pat aux (Op (Futhark.JVP lam args vec))) -> doFuseScans $ do + lam' <- doFusionLambda lam + pure (incoming, node, StmNode (Let pat aux (Op (Futhark.JVP lam' args vec))), outgoing) + StmNode (Let pat aux (WithAcc inputs lam)) -> doFuseScans $ do + lam' <- doFusionLambda lam + pure (incoming, node, StmNode (Let pat aux (WithAcc inputs lam')), outgoing) + SoacNode ots pat soac aux -> do + let lam = H.lambda soac + lam' <- localScope (scopeOf lam) $ case soac of + H.Stream _ Sequential {} _ _ _ -> + dontFuseScans $ doFusionLambda lam + _ -> + doFuseScans $ doFusionLambda lam + let nodeT' = SoacNode ots pat (H.setLambda lam' soac) aux + pure (incoming, node, nodeT', outgoing) + _ -> pure c + where + doFusionWithDelayed :: Body SOACS -> [(NodeT, [EdgeT])] -> FusionM (Body SOACS) + doFusionWithDelayed (Body () stms res) extraNodes = localScope (scopeOf stms) $ do + stm_node <- mapM (finalizeNode . fst) extraNodes + stms' <- fuseGraph (mkBody (mconcat stm_node <> stms) res) + pure $ Body () stms' res + doFusionBody :: Body SOACS -> FusionM (Body SOACS) + doFusionBody body = do + stms' <- fuseGraph body + pure $ body {bodyStms = stms'} + doFusionLambda :: Lambda SOACS -> FusionM (Lambda SOACS) + doFusionLambda lam = do + -- To clean up previous instances of fusion. + lam' <- simplifyLambda lam + prev_count <- gets fusionCount + newbody <- localScope (scopeOf lam') $ doFusionBody $ lambdaBody lam' + aft_count <- gets fusionCount + -- To clean up any inner fusion. + (if prev_count /= aft_count then simplifyLambda else pure) + lam' {lambdaBody = newbody} + +-- main fusion function. +fuseGraph :: Body SOACS -> FusionM (Stms SOACS) +fuseGraph body = localScope (scopeOf (bodyStms body)) $ do + graph_not_fused <- mkDepGraph body + graph_fused <- doAllFusion graph_not_fused + linearizeGraph graph_fused + +fuseConsts :: [VName] -> Stms SOACS -> PassM (Stms SOACS) +fuseConsts outputs stms = + runFusionM + (scopeOf stms) + freshFusionEnv + (fuseGraph (mkBody stms (varsRes outputs))) + +fuseFun :: Stms SOACS -> FunDef SOACS -> PassM (FunDef SOACS) +fuseFun consts fun = do + fun_stms' <- + runFusionM + (scopeOf fun <> scopeOf consts) + freshFusionEnv + (fuseGraph (funDefBody fun)) + pure fun {funDefBody = (funDefBody fun) {bodyStms = fun_stms'}} + +-- | The pass definition. +{-# NOINLINE fuseSOACs #-} +fuseSOACs :: Pass SOACS SOACS +fuseSOACs = + Pass + { passName = "Fuse SOACs", + passDescription = "Perform higher-order optimisation, i.e., fusion.", + passFunction = \p -> + intraproceduralTransformationWithConsts + (fuseConsts (namesToList $ freeIn (progFuns p))) + fuseFun + p + } 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 @@ -119,7 +119,8 @@ originputmap = lam1inputmap `M.union` lam2inputmap' outins = uncurry (outParams $ map fst out1) $ - unzip $ M.toList lam2inputmap' + unzip $ + M.toList lam2inputmap' outstms = filterOutParams out1 outins (inputmap, makeCopies) = removeDuplicateInputs $ originputmap `M.difference` outins @@ -259,7 +260,8 @@ res_body' = res_body { bodyResult = - p_lam_scan_res ++ res_lam_scan_res + p_lam_scan_res + ++ res_lam_scan_res ++ p_lam_red_res ++ res_lam_red_res ++ res_lam_map_res @@ -269,7 +271,8 @@ { lambdaParams = accpars ++ lambdaParams res_lam, lambdaBody = res_body', lambdaReturnType = - p_lam_scan_ts ++ res_lam_scan_ts + p_lam_scan_ts + ++ res_lam_scan_ts ++ p_lam_red_ts ++ res_lam_red_ts ++ res_lam_map_ts diff --git a/src/Futhark/Optimise/Fusion/GraphRep.hs b/src/Futhark/Optimise/Fusion/GraphRep.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Optimise/Fusion/GraphRep.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | A graph representation of a sequence of Futhark statements +-- (i.e. a 'Body'), built to handle fusion. Could perhaps be made +-- more general. An important property is that it does not handle +-- "nested bodies" (e.g. 'If'); these are represented as single nodes. +-- +-- This is all implemented on top of the graph representation provided +-- by the @fgl@ package ("Data.Graph.Inductive"). The graph provided +-- by this package allows nodes and edges to have arbitrarily-typed +-- "labels". It is these labels ('EdgeT', 'NodeT') that we use to +-- contain Futhark-specific information. An edge goes *from* uses of +-- variables to the node that produces that variable. There are also +-- edges that do not represent normal data dependencies, but other +-- things. This means that a node can have multiple edges for the +-- same name, indicating different kinds of dependencies. +module Futhark.Optimise.Fusion.GraphRep + ( -- * Data structure + EdgeT (..), + NodeT (..), + DepContext, + DepGraphAug, + DepGraph (..), + DepNode, + + -- * Queries + getName, + nodeFromLNode, + mergedContext, + mapAcross, + edgesBetween, + reachable, + applyAugs, + depsFromEdge, + contractEdge, + isRealNode, + isCons, + isDep, + isInf, + + -- * Construction + mkDepGraph, + pprg, + ) +where + +import Data.Bifunctor (bimap) +import Data.Foldable (foldlM) +import qualified Data.Graph.Inductive.Dot as G +import qualified Data.Graph.Inductive.Graph as G +import qualified Data.Graph.Inductive.Query.DFS as Q +import qualified Data.Graph.Inductive.Tree as G +import qualified Data.List as L +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Futhark.Analysis.Alias as Alias +import qualified Futhark.Analysis.HORep.SOAC as H +import Futhark.IR.Prop.Aliases +import Futhark.IR.SOACS hiding (SOAC (..)) +import qualified Futhark.IR.SOACS as Futhark +import Futhark.Util (nubOrd) + +-- | Information associated with an edge in the graph. +data EdgeT + = Alias VName + | InfDep VName + | Dep VName + | Cons VName + | Fake VName + | Res VName + deriving (Eq, Ord) + +-- | Information associated with a node in the graph. +data NodeT + = StmNode (Stm SOACS) + | SoacNode H.ArrayTransforms (Pat Type) (H.SOAC SOACS) (StmAux (ExpDec SOACS)) + | -- | Node corresponding to a result of the entire computation + -- (i.e. the 'Result' of a body). Any node that is not + -- transitively reachable from one of these can be considered + -- dead. + ResNode VName + | -- | Node corresponding to a free variable. + -- Unclear whether we actually need these. + FreeNode VName + | FinalNode (Stms SOACS) NodeT (Stms SOACS) + | IfNode (Stm SOACS) [(NodeT, [EdgeT])] + | DoNode (Stm SOACS) [(NodeT, [EdgeT])] + deriving (Eq) + +instance Show EdgeT where + show (Dep vName) = "Dep " <> pretty vName + show (InfDep vName) = "iDep " <> pretty vName + show (Cons _) = "Cons" + show (Fake _) = "Fake" + show (Res _) = "Res" + show (Alias _) = "Alias" + +instance Show NodeT where + show (StmNode (Let pat _ _)) = L.intercalate ", " $ map pretty $ patNames pat + show (SoacNode _ pat _ _) = pretty pat + show (FinalNode _ nt _) = show nt + show (ResNode name) = pretty $ "Res: " ++ pretty name + show (FreeNode name) = pretty $ "Input: " ++ pretty name + show (IfNode stm _) = "If: " ++ L.intercalate ", " (map pretty $ stmNames stm) + show (DoNode stm _) = "Do: " ++ L.intercalate ", " (map pretty $ stmNames stm) + +-- | The name that this edge depends on. +getName :: EdgeT -> VName +getName edgeT = case edgeT of + Alias vn -> vn + InfDep vn -> vn + Dep vn -> vn + Cons vn -> vn + Fake vn -> vn + Res vn -> vn + +-- | Does the node acutally represent something in the program? A +-- "non-real" node represents things like fake nodes inserted to +-- express ordering due to consumption. +isRealNode :: NodeT -> Bool +isRealNode ResNode {} = False +isRealNode FreeNode {} = False +isRealNode _ = True + +-- | Prettyprint dependency graph. +pprg :: DepGraph -> String +pprg = G.showDot . G.fglToDotString . G.nemap show show . dgGraph + +-- | A pair of a 'G.Node' and the node label. +type DepNode = G.LNode NodeT + +type DepEdge = G.LEdge EdgeT + +-- | A tuple with four parts: inbound links to the node, the node +-- itself, the 'NodeT' "label", and outbound links from the node. +-- This type is used to modify the graph in 'mapAcross'. +type DepContext = G.Context NodeT EdgeT + +-- | A dependency graph. Edges go from *consumers* to *producers* +-- (i.e. from usage to definition). That means the incoming edges of +-- a node are the dependents of that node, and the outgoing edges are +-- the dependencies of that node. +data DepGraph = DepGraph + { dgGraph :: G.Gr NodeT EdgeT, + dgProducerMapping :: ProducerMapping, + -- | A table mapping VNames to VNames that are aliased to it. + dgAliasTable :: AliasTable + } + +-- | A "graph augmentation" is a monadic action that modifies the graph. +type DepGraphAug m = DepGraph -> m DepGraph + +-- | For each node, what producer should the node depend on and what +-- type is it. +type EdgeGenerator = NodeT -> [(VName, EdgeT)] + +-- | A mapping from variable name to the graph node that produces +-- it. +type ProducerMapping = M.Map VName G.Node + +makeMapping :: Monad m => DepGraphAug m +makeMapping dg@(DepGraph {dgGraph = g}) = + pure dg {dgProducerMapping = M.fromList $ concatMap gen_dep_list (G.labNodes g)} + where + gen_dep_list :: DepNode -> [(VName, G.Node)] + gen_dep_list (i, node) = [(name, i) | name <- getOutputs node] + +-- make a table to handle transitive aliases +makeAliasTable :: Monad m => Stms SOACS -> DepGraphAug m +makeAliasTable stms dg = do + let (_, (aliasTable', _)) = Alias.analyseStms mempty stms + pure $ dg {dgAliasTable = aliasTable'} + +-- | Apply several graph augmentations in sequence. +applyAugs :: Monad m => [DepGraphAug m] -> DepGraphAug m +applyAugs augs g = foldlM (flip ($)) g augs + +-- | Creates deps for the given nodes on the graph using the 'EdgeGenerator'. +genEdges :: Monad m => [DepNode] -> EdgeGenerator -> DepGraphAug m +genEdges l_stms edge_fun dg = + depGraphInsertEdges (concatMap (genEdge (dgProducerMapping dg)) l_stms) dg + where + -- statements -> mapping from declared array names to soac index + genEdge :: M.Map VName G.Node -> DepNode -> [G.LEdge EdgeT] + genEdge name_map (from, node) = do + (dep, edgeT) <- edge_fun node + Just to <- [M.lookup dep name_map] + pure $ G.toLEdge (from, to) edgeT + +depGraphInsertEdges :: Monad m => [DepEdge] -> DepGraphAug m +depGraphInsertEdges edgs dg = pure $ dg {dgGraph = G.insEdges edgs $ dgGraph dg} + +-- | Monadically modify every node of the graph. +mapAcross :: Monad m => (DepContext -> m DepContext) -> DepGraphAug m +mapAcross f dg = do + g' <- foldlM (flip helper) (dgGraph dg) (G.nodes (dgGraph dg)) + pure $ dg {dgGraph = g'} + where + helper n g' = case G.match n g' of + (Just c, g_new) -> do + c' <- f c + pure $ c' G.& g_new + (Nothing, _) -> pure g' + +stmFromNode :: NodeT -> Stms SOACS -- do not use outside of edge generation +stmFromNode (StmNode x) = oneStm x +stmFromNode _ = mempty + +-- | Get the underlying @fgl@ node. +nodeFromLNode :: DepNode -> G.Node +nodeFromLNode = fst + +-- | Get the variable name that this edge refers to. +depsFromEdge :: DepEdge -> VName +depsFromEdge = getName . G.edgeLabel + +-- | Find all the edges connecting the two nodes. +edgesBetween :: DepGraph -> G.Node -> G.Node -> [DepEdge] +edgesBetween dg n1 n2 = G.labEdges $ G.subgraph [n1, n2] $ dgGraph dg + +-- | @reachable dg from to@ is true if @to@ is reachable from @from@. +reachable :: DepGraph -> G.Node -> G.Node -> Bool +reachable dg source target = target `elem` Q.reachable source (dgGraph dg) + +-- Utility func for augs +augWithFun :: Monad m => EdgeGenerator -> DepGraphAug m +augWithFun f dg = genEdges (G.labNodes (dgGraph dg)) f dg + +addDeps :: Monad m => DepGraphAug m +addDeps = augWithFun toDep + where + toDep stmt = + let (fusible, infusible) = + bimap (map fst) (map fst) + . L.partition ((== SOACInput) . snd) + . S.toList + $ foldMap stmInputs (stmFromNode stmt) + mkDep vname = (vname, Dep vname) + mkInfDep vname = (vname, InfDep vname) + in map mkDep fusible <> map mkInfDep infusible + +addConsAndAliases :: Monad m => DepGraphAug m +addConsAndAliases = augWithFun edges + where + edges (StmNode s) = consEdges e <> aliasEdges e + where + e = Alias.analyseExp mempty $ stmExp s + edges _ = mempty + consEdges e = zip names (map Cons names) + where + names = namesToList $ consumedInExp e + aliasEdges = + map (\vname -> (vname, Alias vname)) + . namesToList + . mconcat + . expAliases + +-- extra dependencies mask the fact that consuming nodes "depend" on all other +-- nodes coming before it (now also adds fake edges to aliases - hope this +-- fixes asymptotic complexity guarantees) +addExtraCons :: Monad m => DepGraphAug m +addExtraCons dg = + depGraphInsertEdges (concatMap makeEdge (G.labEdges g)) dg + where + g = dgGraph dg + alias_table = dgAliasTable dg + mapping = dgProducerMapping dg + makeEdge (from, to, Cons cname) = do + let aliases = namesToList $ M.findWithDefault mempty cname alias_table + to' = map (mapping M.!) aliases + p (tonode, toedge) = + tonode /= from && getName toedge `elem` (cname : aliases) + (to2, _) <- filter p $ concatMap (G.lpre g) to' <> G.lpre g to + pure $ G.toLEdge (from, to2) (Fake cname) + makeEdge _ = [] + +mapAcrossNodeTs :: Monad m => (NodeT -> m NodeT) -> DepGraphAug m +mapAcrossNodeTs f = mapAcross f' + where + f' (ins, n, nodeT, outs) = do + nodeT' <- f nodeT + pure (ins, n, nodeT', outs) + +nodeToSoacNode :: (HasScope SOACS m, Monad m) => NodeT -> m NodeT +nodeToSoacNode n@(StmNode s@(Let pat aux op)) = case op of + Op {} -> do + maybeSoac <- H.fromExp op + case maybeSoac of + Right hsoac -> pure $ SoacNode mempty pat hsoac aux + Left H.NotSOAC -> pure n + DoLoop {} -> + pure $ DoNode s [] + If {} -> + pure $ IfNode s [] + _ -> pure n +nodeToSoacNode n = pure n + +convertGraph :: (HasScope SOACS m, Monad m) => DepGraphAug m +convertGraph = mapAcrossNodeTs nodeToSoacNode + +initialGraphConstruction :: (HasScope SOACS m, Monad m) => DepGraphAug m +initialGraphConstruction = + applyAugs + [ addDeps, + addConsAndAliases, + addExtraCons, + addResEdges, + convertGraph -- Must be done after adding edges + ] + +-- | Construct a graph with only nodes, but no edges. +emptyGraph :: Body SOACS -> DepGraph +emptyGraph body = + DepGraph + { dgGraph = G.mkGraph (labelNodes (stmnodes <> resnodes <> inputnodes)) [], + dgProducerMapping = mempty, + dgAliasTable = mempty + } + where + labelNodes = zip [0 ..] + stmnodes = map StmNode $ stmsToList $ bodyStms body + resnodes = map ResNode $ namesToList $ freeIn $ bodyResult body + inputnodes = map FreeNode $ namesToList $ freeIn body + +-- | Make a dependency graph corresponding to a 'Body'. +mkDepGraph :: (HasScope SOACS m, Monad m) => Body SOACS -> m DepGraph +mkDepGraph body = applyAugs augs $ emptyGraph body + where + augs = + [ makeMapping, + makeAliasTable (bodyStms body), + initialGraphConstruction + ] + +-- | Merges two contexts. +mergedContext :: Ord b => a -> G.Context a b -> G.Context a b -> G.Context a b +mergedContext mergedlabel (inp1, n1, _, out1) (inp2, n2, _, out2) = + let new_inp = filter (\n -> snd n /= n1 && snd n /= n2) (nubOrd (inp1 <> inp2)) + new_out = filter (\n -> snd n /= n1 && snd n /= n2) (nubOrd (out1 <> out2)) + in (new_inp, n1, mergedlabel, new_out) + +-- | Remove the given node, and insert the 'DepContext' into the +-- graph, replacing any existing information about the node contained +-- in the 'DepContext'. +contractEdge :: Monad m => G.Node -> DepContext -> DepGraphAug m +contractEdge n2 ctx dg = do + let n1 = G.node' ctx -- n1 remains + pure $ dg {dgGraph = ctx G.& G.delNodes [n1, n2] (dgGraph dg)} + +addResEdges :: Monad m => DepGraphAug m +addResEdges = augWithFun getStmRes + +-- Utils for fusibility/infusibility +-- find dependencies - either fusible or infusible. edges are generated based on these + +-- | A classification of a free variable. +data Classification + = -- | Used as array input to a SOAC (meaning fusible). + SOACInput + | -- | Used in some other way. + Other + deriving (Eq, Ord, Show) + +type Classifications = S.Set (VName, Classification) + +freeClassifications :: FreeIn a => a -> Classifications +freeClassifications = + S.fromList . (`zip` repeat Other) . namesToList . freeIn + +stmInputs :: Stm SOACS -> Classifications +stmInputs (Let pat aux e) = + freeClassifications (pat, aux) <> expInputs e + +bodyInputs :: Body SOACS -> Classifications +bodyInputs (Body _ stms res) = foldMap stmInputs stms <> freeClassifications res + +expInputs :: Exp SOACS -> Classifications +expInputs (If cond b1 b2 attr) = + bodyInputs b1 <> bodyInputs b2 <> freeClassifications (cond, attr) +expInputs (DoLoop params form b1) = + freeClassifications (params, form) <> bodyInputs b1 +expInputs (Op soac) = case soac of + Futhark.Screma w is form -> inputs is <> freeClassifications (w, form) + Futhark.Hist w is ops lam -> inputs is <> freeClassifications (w, ops, lam) + Futhark.Scatter w is lam iws -> inputs is <> freeClassifications (w, lam, iws) + Futhark.Stream w is form nes lam -> + inputs is <> freeClassifications (w, form, nes, lam) + Futhark.JVP {} -> freeClassifications soac + Futhark.VJP {} -> freeClassifications soac + where + inputs = S.fromList . (`zip` repeat SOACInput) +expInputs e + | Just (arr, _) <- H.transformFromExp mempty e = + S.singleton (arr, SOACInput) + <> freeClassifications (freeIn e `namesSubtract` oneName arr) + | otherwise = freeClassifications e + +stmNames :: Stm SOACS -> [VName] +stmNames = patNames . stmPat + +getStmRes :: EdgeGenerator +getStmRes (ResNode name) = [(name, Res name)] +getStmRes _ = [] + +getOutputs :: NodeT -> [VName] +getOutputs node = case node of + (StmNode stm) -> stmNames stm + (ResNode _) -> [] + (FreeNode name) -> [name] + (IfNode stm _) -> stmNames stm + (DoNode stm _) -> stmNames stm + FinalNode {} -> error "Final nodes cannot generate edges" + (SoacNode _ pat _ _) -> patNames pat + +-- | Is there a possibility of fusion? +isDep :: EdgeT -> Bool +isDep (Dep _) = True +isDep (Res _) = True +isDep _ = False + +-- | Is this an infusible edge? +isInf :: (G.Node, G.Node, EdgeT) -> Bool +isInf (_, _, e) = case e of + InfDep _ -> True + Fake _ -> True -- this is infusible to avoid simultaneous cons/dep edges + _ -> False + +-- | Is this a 'Cons' edge? +isCons :: EdgeT -> Bool +isCons (Cons _) = True +isCons _ = False diff --git a/src/Futhark/Optimise/Fusion/LoopKernel.hs b/src/Futhark/Optimise/Fusion/LoopKernel.hs deleted file mode 100644 --- a/src/Futhark/Optimise/Fusion/LoopKernel.hs +++ /dev/null @@ -1,937 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module Futhark.Optimise.Fusion.LoopKernel - ( FusedKer (..), - newKernel, - inputs, - setInputs, - arrInputs, - transformOutput, - attemptFusion, - SOAC, - MapNest, - ) -where - -import Control.Applicative -import Control.Arrow (first) -import Control.Monad -import Control.Monad.Reader -import Control.Monad.State -import Data.List (find, tails, (\\)) -import qualified Data.Map.Strict as M -import Data.Maybe -import qualified Data.Set as S -import qualified Futhark.Analysis.HORep.MapNest as MapNest -import qualified Futhark.Analysis.HORep.SOAC as SOAC -import Futhark.Construct -import Futhark.IR.SOACS hiding (SOAC (..)) -import qualified Futhark.IR.SOACS as Futhark -import Futhark.Optimise.Fusion.Composing -import Futhark.Pass.ExtractKernels.ISRWIM (rwimPossible) -import Futhark.Transform.Rename (renameLambda) -import Futhark.Transform.Substitute -import Futhark.Util (splitAt3) - -newtype TryFusion a - = TryFusion - ( ReaderT - (Scope SOACS) - (StateT VNameSource Maybe) - a - ) - deriving - ( Functor, - Applicative, - Alternative, - Monad, - MonadFail, - MonadFreshNames, - HasScope SOACS, - LocalScope SOACS - ) - -tryFusion :: - MonadFreshNames m => - TryFusion a -> - Scope SOACS -> - m (Maybe a) -tryFusion (TryFusion m) types = modifyNameSource $ \src -> - case runStateT (runReaderT m types) src of - Just (x, src') -> (Just x, src') - Nothing -> (Nothing, src) - -liftMaybe :: Maybe a -> TryFusion a -liftMaybe Nothing = fail "Nothing" -liftMaybe (Just x) = pure x - -type SOAC = SOAC.SOAC SOACS - -type MapNest = MapNest.MapNest SOACS - --- XXX: This function is very gross. -transformOutput :: - SOAC.ArrayTransforms -> - [VName] -> - [Ident] -> - Builder SOACS () -transformOutput ts names = descend ts - where - descend ts' validents = - case SOAC.viewf ts' of - SOAC.EmptyF -> - forM_ (zip names validents) $ \(k, valident) -> - letBindNames [k] $ BasicOp $ SubExp $ Var $ identName valident - t SOAC.:< ts'' -> do - let (es, css) = unzip $ map (applyTransform t) validents - 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, Certs) -applyTransform (SOAC.Rearrange cs perm) v = - (Rearrange perm' $ identName v, cs) - where - perm' = perm ++ drop (length perm) [0 .. arrayRank (identType v) - 1] -applyTransform (SOAC.Reshape cs shape) v = - (Reshape shape $ identName v, cs) -applyTransform (SOAC.ReshapeOuter cs shape) v = - let shapes = reshapeOuter shape 1 $ arrayShape $ identType v - in (Reshape shapes $ identName v, cs) -applyTransform (SOAC.ReshapeInner cs shape) v = - let shapes = reshapeInner shape 1 $ arrayShape $ identType v - in (Reshape shapes $ identName v, cs) -applyTransform (SOAC.Replicate cs n) v = - (Replicate n $ Var $ identName v, cs) - -inputToOutput :: SOAC.Input -> Maybe (SOAC.ArrayTransform, SOAC.Input) -inputToOutput (SOAC.Input ts ia iat) = - case SOAC.viewf ts of - t SOAC.:< ts' -> Just (t, SOAC.Input ts' ia iat) - SOAC.EmptyF -> Nothing - -data FusedKer = FusedKer - { -- | the SOAC expression, e.g., mapT( f(a,b), x, y ) - fsoac :: SOAC, - -- | Variables used in in-place updates in the kernel itself, as - -- well as on the path to the kernel from the current position. - -- This is used to avoid fusion that would violate in-place - -- restrictions. - inplace :: Names, - -- | whether at least a fusion has been performed. - fusedVars :: [VName], - -- | The set of variables that were consumed by the SOACs - -- contributing to this kernel. Note that, by the type rules, the - -- final SOAC may actually consume _more_ than its original - -- contributors, which implies the need for 'Copy' expressions. - fusedConsumed :: Names, - -- | The names in scope at the kernel. - kernelScope :: Scope SOACS, - outputTransform :: SOAC.ArrayTransforms, - outNames :: [VName], - kerAux :: StmAux () - } - deriving (Show) - -newKernel :: StmAux () -> SOAC -> Names -> [VName] -> Scope SOACS -> FusedKer -newKernel aux soac consumed out_nms scope = - FusedKer - { fsoac = soac, - inplace = consumed, - fusedVars = [], - fusedConsumed = consumed, - outputTransform = SOAC.noTransforms, - outNames = out_nms, - kernelScope = scope, - kerAux = aux - } - -arrInputs :: FusedKer -> S.Set VName -arrInputs = S.fromList . map SOAC.inputArray . inputs - -inputs :: FusedKer -> [SOAC.Input] -inputs = SOAC.inputs . fsoac - -setInputs :: [SOAC.Input] -> FusedKer -> FusedKer -setInputs inps ker = ker {fsoac = inps `SOAC.setInputs` fsoac ker} - -tryOptimizeSOAC :: - Names -> - [VName] -> - SOAC -> - Names -> - FusedKer -> - TryFusion FusedKer -tryOptimizeSOAC unfus_nms outVars soac consumed ker = do - (soac', ots) <- optimizeSOAC Nothing soac mempty - let ker' = map (addInitialTransformIfRelevant ots) (inputs ker) `setInputs` ker - outIdents = zipWith Ident outVars $ SOAC.typeOf soac' - ker'' = fixInputTypes outIdents ker' - applyFusionRules unfus_nms outVars soac' consumed ker'' - where - addInitialTransformIfRelevant ots inp - | SOAC.inputArray inp `elem` outVars = - SOAC.addInitialTransforms ots inp - | otherwise = - inp - -tryOptimizeKernel :: - Names -> - [VName] -> - SOAC -> - Names -> - FusedKer -> - TryFusion FusedKer -tryOptimizeKernel unfus_nms outVars soac consumed ker = do - ker' <- optimizeKernel (Just outVars) ker - applyFusionRules unfus_nms outVars soac consumed ker' - -tryExposeInputs :: - Names -> - [VName] -> - SOAC -> - Names -> - FusedKer -> - TryFusion FusedKer -tryExposeInputs unfus_nms outVars soac consumed ker = do - (ker', ots) <- exposeInputs outVars ker - if SOAC.nullTransforms ots - then fuseSOACwithKer unfus_nms outVars soac consumed ker' - else do - (soac', ots') <- pullOutputTransforms soac ots - let outIdents = zipWith Ident outVars $ SOAC.typeOf soac' - ker'' = fixInputTypes outIdents ker' - if SOAC.nullTransforms ots' - then applyFusionRules unfus_nms outVars soac' consumed ker'' - else fail "tryExposeInputs could not pull SOAC transforms" - -fixInputTypes :: [Ident] -> FusedKer -> FusedKer -fixInputTypes outIdents ker = - ker {fsoac = fixInputTypes' $ fsoac ker} - where - fixInputTypes' soac = - map fixInputType (SOAC.inputs soac) `SOAC.setInputs` soac - fixInputType (SOAC.Input ts v _) - | Just v' <- find ((== v) . identName) outIdents = - SOAC.Input ts v $ identType v' - fixInputType inp = inp - -applyFusionRules :: - Names -> - [VName] -> - SOAC -> - Names -> - FusedKer -> - TryFusion FusedKer -applyFusionRules unfus_nms outVars soac consumed ker = - tryOptimizeSOAC unfus_nms outVars soac consumed ker - <|> tryOptimizeKernel unfus_nms outVars soac consumed ker - <|> fuseSOACwithKer unfus_nms outVars soac consumed ker - <|> tryExposeInputs unfus_nms outVars soac consumed ker - -attemptFusion :: - MonadFreshNames m => - Names -> - [VName] -> - SOAC -> - Names -> - FusedKer -> - m (Maybe FusedKer) -attemptFusion unfus_nms outVars soac consumed ker = - fmap removeUnusedParamsFromKer - <$> tryFusion - (applyFusionRules unfus_nms outVars soac consumed ker) - (kernelScope ker) - -removeUnusedParamsFromKer :: FusedKer -> FusedKer -removeUnusedParamsFromKer ker = - case soac of - SOAC.Screma {} -> ker {fsoac = soac'} - _ -> ker - where - soac = fsoac ker - l = SOAC.lambda soac - inps = SOAC.inputs soac - (l', inps') = removeUnusedParams l inps - soac' = - l' - `SOAC.setLambda` (inps' `SOAC.setInputs` soac) - -removeUnusedParams :: Lambda SOACS -> [SOAC.Input] -> (Lambda SOACS, [SOAC.Input]) -removeUnusedParams l inps = - (l {lambdaParams = ps'}, inps') - where - pInps = zip (lambdaParams l) inps - (ps', inps') = case (unzip $ filter (used . fst) pInps, pInps) of - (([], []), (p, inp) : _) -> ([p], [inp]) - ((ps_, inps_), _) -> (ps_, inps_) - used p = paramName p `nameIn` freeVars - freeVars = freeIn $ lambdaBody l - --- | Check that the consumer uses at least one output of the producer --- unmodified. -mapFusionOK :: [VName] -> FusedKer -> Bool -mapFusionOK outVars ker = any (`elem` inpIds) outVars - where - inpIds = mapMaybe SOAC.isVarishInput (inputs ker) - --- | Check that the consumer uses all the outputs of the producer unmodified. -mapWriteFusionOK :: [VName] -> FusedKer -> Bool -mapWriteFusionOK outVars ker = all (`elem` inpIds) outVars - where - inpIds = mapMaybe SOAC.isVarishInput (inputs ker) - --- | The brain of this module: Fusing a SOAC with a Kernel. -fuseSOACwithKer :: - Names -> - [VName] -> - SOAC -> - Names -> - FusedKer -> - TryFusion FusedKer -fuseSOACwithKer unfus_set outVars soac_p soac_p_consumed ker = do - -- We are fusing soac_p into soac_c, i.e, the output of soac_p is going - -- into soac_c. - let soac_c = fsoac ker - inp_p_arr = SOAC.inputs soac_p - horizFuse = - unfus_set /= mempty - && SOAC.width soac_p == SOAC.width soac_c - inp_c_arr = SOAC.inputs soac_c - lam_p = SOAC.lambda soac_p - lam_c = SOAC.lambda soac_c - w = SOAC.width soac_p - returned_outvars = filter (`nameIn` unfus_set) outVars - success res_outnms res_soac = do - let fusedVars_new = fusedVars ker ++ outVars - -- Avoid name duplication, because the producer lambda is not - -- removed from the program until much later. - uniq_lam <- renameLambda $ SOAC.lambda res_soac - pure $ - ker - { fsoac = uniq_lam `SOAC.setLambda` res_soac, - fusedVars = fusedVars_new, - inplace = inplace ker <> soac_p_consumed, - fusedConsumed = fusedConsumed ker <> soac_p_consumed, - outNames = res_outnms - } - - outPairs <- forM (zip outVars $ map rowType $ SOAC.typeOf soac_p) $ \(outVar, t) -> do - outVar' <- newVName $ baseString outVar ++ "_elem" - pure (outVar, Ident outVar' t) - - let mapLikeFusionCheck = - let (res_lam, new_inp) = fuseMaps unfus_set lam_p inp_p_arr outPairs lam_c inp_c_arr - (extra_nms, extra_rtps) = - unzip $ - filter ((`nameIn` unfus_set) . fst) $ - zip outVars $ map (stripArray 1) $ SOAC.typeOf soac_p - res_lam' = res_lam {lambdaReturnType = lambdaReturnType res_lam ++ extra_rtps} - in (extra_nms, res_lam', new_inp) - - when (horizFuse && not (SOAC.nullTransforms $ outputTransform ker)) $ - fail "Horizontal fusion is invalid in the presence of output transforms." - - case (soac_c, soac_p) of - _ | SOAC.width soac_p /= SOAC.width soac_c -> fail "SOAC widths must match." - ( SOAC.Screma _ (ScremaForm scans_c reds_c _) _, - SOAC.Screma _ (ScremaForm scans_p reds_p _) _ - ) - | mapFusionOK (drop (Futhark.scanResults scans_p + Futhark.redResults reds_p) outVars) ker - || horizFuse -> do - let red_nes_p = concatMap redNeutral reds_p - red_nes_c = concatMap redNeutral reds_c - scan_nes_p = concatMap scanNeutral scans_p - scan_nes_c = concatMap scanNeutral scans_c - (res_lam', new_inp) = - fuseRedomap - unfus_set - outVars - lam_p - scan_nes_p - red_nes_p - inp_p_arr - outPairs - lam_c - scan_nes_c - red_nes_c - inp_c_arr - (soac_p_scanout, soac_p_redout, _soac_p_mapout) = - splitAt3 (length scan_nes_p) (length red_nes_p) outVars - (soac_c_scanout, soac_c_redout, soac_c_mapout) = - splitAt3 (length scan_nes_c) (length red_nes_c) $ outNames ker - unfus_arrs = returned_outvars \\ (soac_p_scanout ++ soac_p_redout) - success - ( soac_p_scanout ++ soac_c_scanout - ++ soac_p_redout - ++ soac_c_redout - ++ soac_c_mapout - ++ unfus_arrs - ) - $ SOAC.Screma - w - (ScremaForm (scans_p ++ scans_c) (reds_p ++ reds_c) res_lam') - new_inp - - ------------------ - -- Scatter fusion -- - ------------------ - - -- Map-Scatter fusion. - -- - -- The 'inplace' mechanism for kernels already takes care of - -- checking that the Scatter is not writing to any array used in - -- the Map. - ( SOAC.Scatter _len _lam _ivs dests, - SOAC.Screma _ form _ - ) - | isJust $ isMapSOAC form, - -- 1. all arrays produced by the map are ONLY used (consumed) - -- by the scatter, i.e., not used elsewhere. - not (any (`nameIn` unfus_set) outVars), - -- 2. all arrays produced by the map are input to the scatter. - mapWriteFusionOK outVars ker -> do - let (extra_nms, res_lam', new_inp) = mapLikeFusionCheck - success (outNames ker ++ extra_nms) $ - SOAC.Scatter w res_lam' new_inp dests - - -- Map-Hist fusion. - -- - -- The 'inplace' mechanism for kernels already takes care of - -- checking that the Hist is not writing to any array used in - -- the Map. - ( SOAC.Hist _ ops _ _, - SOAC.Screma _ form _ - ) - | isJust $ isMapSOAC form, - -- 1. all arrays produced by the map are ONLY used (consumed) - -- by the hist, i.e., not used elsewhere. - not (any (`nameIn` unfus_set) outVars), - -- 2. all arrays produced by the map are input to the scatter. - mapWriteFusionOK outVars ker -> do - let (extra_nms, res_lam', new_inp) = mapLikeFusionCheck - success (outNames ker ++ extra_nms) $ - SOAC.Hist w ops res_lam' new_inp - - -- Hist-Hist fusion - ( SOAC.Hist _ ops_c _ _, - SOAC.Hist _ ops_p _ _ - ) - | horizFuse -> do - let p_num_buckets = length ops_p - c_num_buckets = length ops_c - (body_p, body_c) = (lambdaBody lam_p, lambdaBody lam_c) - body' = - Body - { bodyDec = bodyDec body_p, -- body_p and body_c have the same decorations - bodyStms = bodyStms body_p <> bodyStms body_c, - bodyResult = - take c_num_buckets (bodyResult body_c) - ++ take p_num_buckets (bodyResult body_p) - ++ drop c_num_buckets (bodyResult body_c) - ++ drop p_num_buckets (bodyResult body_p) - } - lam' = - Lambda - { lambdaParams = lambdaParams lam_c ++ lambdaParams lam_p, - lambdaBody = body', - lambdaReturnType = - replicate (c_num_buckets + p_num_buckets) (Prim int64) - ++ drop c_num_buckets (lambdaReturnType lam_c) - ++ drop p_num_buckets (lambdaReturnType lam_p) - } - success (outNames ker ++ returned_outvars) $ - SOAC.Hist w (ops_c <> ops_p) lam' (inp_c_arr <> inp_p_arr) - - -- Scatter-write fusion. - ( SOAC.Scatter _len_c _lam_c ivs_c as_c, - SOAC.Scatter _len_p _lam_p ivs_p as_p - ) - | horizFuse -> do - let zipW as_xs xs as_ys ys = xs_indices ++ ys_indices ++ xs_vals ++ ys_vals - where - (xs_indices, xs_vals) = splitScatterResults as_xs xs - (ys_indices, ys_vals) = splitScatterResults as_ys ys - let (body_p, body_c) = (lambdaBody lam_p, lambdaBody lam_c) - let body' = - Body - { bodyDec = bodyDec body_p, -- body_p and body_c have the same decorations - bodyStms = bodyStms body_p <> bodyStms body_c, - bodyResult = zipW as_c (bodyResult body_c) as_p (bodyResult body_p) - } - let lam' = - Lambda - { lambdaParams = lambdaParams lam_c ++ lambdaParams lam_p, - lambdaBody = body', - lambdaReturnType = zipW as_c (lambdaReturnType lam_c) as_p (lambdaReturnType lam_p) - } - success (outNames ker ++ returned_outvars) $ - SOAC.Scatter w lam' (ivs_c ++ ivs_p) (as_c ++ as_p) - (SOAC.Scatter {}, _) -> - fail "Cannot fuse a write with anything else than a write or a map" - (_, SOAC.Scatter {}) -> - fail "Cannot fuse a write with anything else than a write or a map" - ---------------------------- - -- Stream-Stream Fusions: -- - ---------------------------- - (SOAC.Stream _ Sequential _ _ _, SOAC.Stream _ Sequential _ nes _) - | mapFusionOK (drop (length nes) outVars) ker || horizFuse -> do - -- fuse two SEQUENTIAL streams - (res_nms, res_stream) <- fuseStreamHelper (outNames ker) unfus_set outVars outPairs soac_c soac_p - success res_nms res_stream - (SOAC.Stream _ Sequential _ _ _, SOAC.Stream _ Sequential _ _ _) -> - fail "Fusion conditions not met for two SEQ streams!" - (SOAC.Stream _ Sequential _ _ _, SOAC.Stream {}) -> - fail "Cannot fuse a parallel with a sequential Stream!" - (SOAC.Stream {}, SOAC.Stream _ Sequential _ _ _) -> - fail "Cannot fuse a parallel with a sequential Stream!" - (SOAC.Stream {}, SOAC.Stream _ _ _ nes _) - | mapFusionOK (drop (length nes) outVars) ker || horizFuse -> do - -- fuse two PARALLEL streams - (res_nms, res_stream) <- fuseStreamHelper (outNames ker) unfus_set outVars outPairs soac_c soac_p - success res_nms res_stream - (SOAC.Stream {}, SOAC.Stream {}) -> - fail "Fusion conditions not met for two PAR streams!" - ------------------------------------------------------------------- - --- If one is a stream, translate the other to a stream as well.--- - --- This does not get in trouble (infinite computation) because --- - --- scan's translation to Stream introduces a hindrance to --- - --- (horizontal fusion), hence repeated application is for the--- - --- moment impossible. However, if with a dependence-graph rep--- - --- we could run in an infinite recursion, i.e., repeatedly --- - --- fusing map o scan into an infinity of Stream levels! --- - ------------------------------------------------------------------- - (SOAC.Stream _ form2 _ _ _, _) -> do - -- If this rule is matched then soac_p is NOT a stream. - -- To fuse a stream kernel, we transform soac_p to a stream, which - -- borrows the sequential/parallel property of the soac_c Stream, - -- and recursively perform stream-stream fusion. - (soac_p', newacc_ids) <- SOAC.soacToStream soac_p - soac_p'' <- case form2 of - Sequential {} -> toSeqStream soac_p' - _ -> pure soac_p' - if soac_p' == soac_p - then fail "SOAC could not be turned into stream." - else fuseSOACwithKer unfus_set (map identName newacc_ids ++ outVars) soac_p'' soac_p_consumed ker - (_, SOAC.Screma _ form _) | Just _ <- Futhark.isScanSOAC form -> do - -- A Scan soac can be currently only fused as a (sequential) stream, - -- hence it is first translated to a (sequential) Stream and then - -- fusion with a kernel is attempted. - (soac_p', newacc_ids) <- SOAC.soacToStream soac_p - if soac_p' /= soac_p - then fuseSOACwithKer unfus_set (map identName newacc_ids ++ outVars) soac_p' soac_p_consumed ker - else fail "SOAC could not be turned into stream." - (_, SOAC.Stream _ form_p _ _ _) -> do - -- If it reached this case then soac_c is NOT a Stream kernel, - -- hence transform the kernel's soac to a stream and attempt - -- stream-stream fusion recursivelly. - -- The newly created stream corresponding to soac_c borrows the - -- sequential/parallel property of the soac_p stream. - (soac_c', newacc_ids) <- SOAC.soacToStream soac_c - when (soac_c' == soac_c) $ fail "SOAC could not be turned into stream." - soac_c'' <- case form_p of - Sequential -> toSeqStream soac_c' - _ -> pure soac_c' - - fuseSOACwithKer unfus_set outVars soac_p soac_p_consumed $ - ker {fsoac = soac_c'', outNames = map identName newacc_ids ++ outNames ker} - - --------------------------------- - --- DEFAULT, CANNOT FUSE CASE --- - --------------------------------- - _ -> fail "Cannot fuse" - -getStreamOrder :: StreamForm rep -> StreamOrd -getStreamOrder (Parallel o _ _) = o -getStreamOrder Sequential = InOrder - -fuseStreamHelper :: - [VName] -> - Names -> - [VName] -> - [(VName, Ident)] -> - SOAC -> - SOAC -> - TryFusion ([VName], SOAC) -fuseStreamHelper - out_kernms - unfus_set - outVars - outPairs - (SOAC.Stream w2 form2 lam2 nes2 inp2_arr) - (SOAC.Stream _ form1 lam1 nes1 inp1_arr) = - if getStreamOrder form2 /= getStreamOrder form1 - then fail "fusion conditions not met!" - else do - -- very similar to redomap o redomap composition, but need - -- to remove first the `chunk' parameters of streams' - -- lambdas and put them in the resulting stream lambda. - let chunk1 = head $ lambdaParams lam1 - chunk2 = head $ lambdaParams lam2 - hmnms = M.fromList [(paramName chunk2, paramName chunk1)] - lam20 = substituteNames hmnms lam2 - lam1' = lam1 {lambdaParams = tail $ lambdaParams lam1} - lam2' = lam20 {lambdaParams = tail $ lambdaParams lam20} - (res_lam', new_inp) = - fuseRedomap - unfus_set - outVars - lam1' - [] - nes1 - inp1_arr - outPairs - lam2' - [] - nes2 - inp2_arr - res_lam'' = res_lam' {lambdaParams = chunk1 : lambdaParams res_lam'} - unfus_accs = take (length nes1) outVars - unfus_arrs = filter (`notElem` unfus_accs) $ filter (`nameIn` unfus_set) outVars - res_form <- mergeForms form2 form1 - pure - ( unfus_accs ++ out_kernms ++ unfus_arrs, - SOAC.Stream w2 res_form res_lam'' (nes1 ++ nes2) new_inp - ) - where - mergeForms Sequential Sequential = pure Sequential - mergeForms (Parallel _ comm2 lam2r) (Parallel o1 comm1 lam1r) = - pure $ Parallel o1 (comm1 <> comm2) (mergeReduceOps lam1r lam2r) - mergeForms _ _ = fail "Fusing sequential to parallel stream disallowed!" -fuseStreamHelper _ _ _ _ _ _ = fail "Cannot Fuse Streams!" - --- | If a Stream is passed as argument then it converts it to a --- Sequential Stream; Otherwise it FAILS! -toSeqStream :: SOAC -> TryFusion SOAC -toSeqStream s@(SOAC.Stream _ Sequential _ _ _) = pure s -toSeqStream (SOAC.Stream w Parallel {} l acc inps) = - pure $ SOAC.Stream w Sequential l acc inps -toSeqStream _ = fail "toSeqStream expects a stream, but given a SOAC." - --- Here follows optimizations and transforms to expose fusability. - -optimizeKernel :: Maybe [VName] -> FusedKer -> TryFusion FusedKer -optimizeKernel inp ker = do - (soac, resTrans) <- optimizeSOAC inp (fsoac ker) startTrans - pure $ - ker - { fsoac = soac, - outputTransform = resTrans - } - where - startTrans = outputTransform ker - -optimizeSOAC :: - Maybe [VName] -> - SOAC -> - SOAC.ArrayTransforms -> - TryFusion (SOAC, SOAC.ArrayTransforms) -optimizeSOAC inp soac os = do - res <- foldM comb (False, soac, os) optimizations - case res of - (False, _, _) -> fail "No optimisation applied" - (True, soac', os') -> pure (soac', os') - where - comb (changed, soac', os') f = - do - (soac'', os'') <- f inp soac' os - pure (True, soac'', os'') - <|> pure (changed, soac', os') - -type Optimization = - Maybe [VName] -> - SOAC -> - SOAC.ArrayTransforms -> - TryFusion (SOAC, SOAC.ArrayTransforms) - -optimizations :: [Optimization] -optimizations = [iswim] - -iswim :: - Maybe [VName] -> - SOAC -> - SOAC.ArrayTransforms -> - TryFusion (SOAC, SOAC.ArrayTransforms) -iswim _ (SOAC.Screma w form arrs) ots - | Just [Futhark.Scan scan_fun nes] <- Futhark.isScanSOAC form, - Just (map_pat, map_cs, map_w, map_fun) <- rwimPossible scan_fun, - Just nes_names <- mapM subExpVar nes = do - let nes_idents = zipWith Ident nes_names $ lambdaReturnType scan_fun - map_nes = map SOAC.identInput nes_idents - map_arrs' = map_nes ++ map (SOAC.transposeInput 0 1) arrs - (scan_acc_params, scan_elem_params) = - splitAt (length arrs) $ lambdaParams scan_fun - map_params = - map removeParamOuterDim scan_acc_params - ++ map (setParamOuterDimTo w) scan_elem_params - map_rettype = map (`setOuterSize` w) $ lambdaReturnType scan_fun - - scan_params = lambdaParams map_fun - scan_body = lambdaBody map_fun - scan_rettype = lambdaReturnType map_fun - scan_fun' = Lambda scan_params scan_body scan_rettype - nes' = map Var $ take (length map_nes) $ map paramName map_params - arrs' = drop (length map_nes) $ map paramName map_params - - scan_form <- scanSOAC [Futhark.Scan scan_fun' nes'] - - let map_body = - mkBody - ( oneStm $ - Let (setPatOuterDimTo w map_pat) (defAux ()) $ - Op $ Futhark.Screma w arrs' scan_form - ) - $ varsRes $ patNames map_pat - map_fun' = Lambda map_params map_body map_rettype - perm = case lambdaReturnType map_fun of - [] -> [] - t : _ -> 1 : 0 : [2 .. arrayRank t] - - pure - ( SOAC.Screma map_w (ScremaForm [] [] map_fun') map_arrs', - ots SOAC.|> SOAC.Rearrange map_cs perm - ) -iswim _ _ _ = - fail "ISWIM does not apply." - -removeParamOuterDim :: LParam SOACS -> LParam SOACS -removeParamOuterDim param = - let t = rowType $ paramType param - in param {paramDec = t} - -setParamOuterDimTo :: SubExp -> LParam SOACS -> LParam SOACS -setParamOuterDimTo w param = - let t = paramType param `setOuterSize` w - in param {paramDec = t} - -setPatOuterDimTo :: SubExp -> Pat Type -> Pat Type -setPatOuterDimTo w = fmap (`setOuterSize` w) - --- Now for fiddling with transpositions... - -commonTransforms :: - [VName] -> - [SOAC.Input] -> - (SOAC.ArrayTransforms, [SOAC.Input]) -commonTransforms interesting inps = commonTransforms' inps' - where - inps' = - [ (SOAC.inputArray inp `elem` interesting, inp) - | inp <- inps - ] - -commonTransforms' :: [(Bool, SOAC.Input)] -> (SOAC.ArrayTransforms, [SOAC.Input]) -commonTransforms' inps = - case foldM inspect (Nothing, []) inps of - Just (Just mot, inps') -> first (mot SOAC.<|) $ commonTransforms' $ reverse inps' - _ -> (SOAC.noTransforms, map snd inps) - where - inspect (mot, prev) (True, inp) = - case (mot, inputToOutput inp) of - (Nothing, Just (ot, inp')) -> Just (Just ot, (True, inp') : prev) - (Just ot1, Just (ot2, inp')) - | ot1 == ot2 -> Just (Just ot2, (True, inp') : prev) - _ -> Nothing - inspect (mot, prev) inp = Just (mot, inp : prev) - -mapDepth :: MapNest -> Int -mapDepth (MapNest.MapNest _ lam levels _) = - min resDims (length levels) + 1 - where - resDims = minDim $ case levels of - [] -> lambdaReturnType lam - nest : _ -> MapNest.nestingReturnType nest - minDim [] = 0 - minDim (t : ts) = foldl min (arrayRank t) $ map arrayRank ts - -pullRearrange :: - SOAC -> - SOAC.ArrayTransforms -> - TryFusion (SOAC, SOAC.ArrayTransforms) -pullRearrange soac ots = do - nest <- liftMaybe =<< MapNest.fromSOAC soac - SOAC.Rearrange cs perm SOAC.:< ots' <- pure $ SOAC.viewf ots - if rearrangeReach perm <= mapDepth nest - then do - let -- Expand perm to cover the full extent of the input dimensionality - perm' inp = take r perm ++ [length perm .. r - 1] - where - r = SOAC.inputRank inp - addPerm inp = SOAC.addTransform (SOAC.Rearrange cs $ perm' inp) inp - inputs' = map addPerm $ MapNest.inputs nest - soac' <- - MapNest.toSOAC $ - inputs' `MapNest.setInputs` rearrangeReturnTypes nest perm - pure (soac', ots') - else fail "Cannot pull transpose" - -pushRearrange :: - [VName] -> - SOAC -> - SOAC.ArrayTransforms -> - TryFusion (SOAC, SOAC.ArrayTransforms) -pushRearrange inpIds soac ots = do - nest <- liftMaybe =<< MapNest.fromSOAC soac - (perm, inputs') <- liftMaybe $ fixupInputs inpIds $ MapNest.inputs nest - if rearrangeReach perm <= mapDepth nest - then do - let invertRearrange = SOAC.Rearrange mempty $ rearrangeInverse perm - soac' <- - MapNest.toSOAC $ - inputs' - `MapNest.setInputs` rearrangeReturnTypes nest perm - pure (soac', invertRearrange SOAC.<| ots) - else fail "Cannot push transpose" - --- | Actually also rearranges indices. -rearrangeReturnTypes :: MapNest -> [Int] -> MapNest -rearrangeReturnTypes nest@(MapNest.MapNest w body nestings inps) perm = - MapNest.MapNest - w - body - ( zipWith - setReturnType - nestings - $ drop 1 $ iterate (map rowType) ts - ) - inps - where - origts = MapNest.typeOf nest - -- The permutation may be deeper than the rank of the type, - -- but it is required that it is an identity permutation - -- beyond that. This is supposed to be checked as an - -- invariant by whoever calls rearrangeReturnTypes. - rearrangeType' t = rearrangeType (take (arrayRank t) perm) t - ts = map rearrangeType' origts - - setReturnType nesting t' = - nesting {MapNest.nestingReturnType = t'} - -fixupInputs :: [VName] -> [SOAC.Input] -> Maybe ([Int], [SOAC.Input]) -fixupInputs inpIds inps = - case mapMaybe inputRearrange $ filter exposable inps of - perm : _ -> do - inps' <- mapM (fixupInput (rearrangeReach perm) perm) inps - pure (perm, inps') - _ -> Nothing - where - exposable = (`elem` inpIds) . SOAC.inputArray - - inputRearrange (SOAC.Input ts _ _) - | _ SOAC.:> SOAC.Rearrange _ perm <- SOAC.viewl ts = Just perm - inputRearrange _ = Nothing - - fixupInput d perm inp - | r <- SOAC.inputRank inp, - r >= d = - Just $ SOAC.addTransform (SOAC.Rearrange mempty $ take r perm) inp - | otherwise = Nothing - -pullReshape :: SOAC -> SOAC.ArrayTransforms -> TryFusion (SOAC, SOAC.ArrayTransforms) -pullReshape (SOAC.Screma _ form inps) ots - | Just maplam <- Futhark.isMapSOAC form, - SOAC.Reshape cs shape SOAC.:< ots' <- SOAC.viewf ots, - all primType $ lambdaReturnType maplam = do - let mapw' = case reverse $ newDims shape of - [] -> intConst Int64 0 - d : _ -> d - inputs' = map (SOAC.addTransform $ SOAC.ReshapeOuter cs shape) inps - inputTypes = map SOAC.inputType inputs' - - let outersoac :: - ([SOAC.Input] -> SOAC) -> - (SubExp, [SubExp]) -> - TryFusion ([SOAC.Input] -> SOAC) - outersoac inner (w, outershape) = do - let addDims t = arrayOf t (Shape outershape) NoUniqueness - retTypes = map addDims $ lambdaReturnType maplam - - ps <- forM inputTypes $ \inpt -> - newParam "pullReshape_param" $ - stripArray (length shape - length outershape) inpt - - inner_body <- - runBodyBuilder $ - eBody [SOAC.toExp $ inner $ map (SOAC.identInput . paramIdent) ps] - let inner_fun = - Lambda - { lambdaParams = ps, - lambdaReturnType = retTypes, - lambdaBody = inner_body - } - pure $ SOAC.Screma w $ Futhark.mapSOAC inner_fun - - op' <- - foldM outersoac (SOAC.Screma mapw' $ Futhark.mapSOAC maplam) $ - zip (drop 1 $ reverse $ newDims shape) $ - drop 1 $ reverse $ drop 1 $ tails $ newDims shape - pure (op' inputs', ots') -pullReshape _ _ = fail "Cannot pull reshape" - --- Tie it all together in exposeInputs (for making inputs to a --- consumer available) and pullOutputTransforms (for moving --- output-transforms of a producer to its inputs instead). - -exposeInputs :: - [VName] -> - FusedKer -> - TryFusion (FusedKer, SOAC.ArrayTransforms) -exposeInputs inpIds ker = - (exposeInputs' =<< pushRearrange') - <|> (exposeInputs' =<< pullRearrange') - <|> exposeInputs' ker - where - ot = outputTransform ker - - pushRearrange' = do - (soac', ot') <- pushRearrange inpIds (fsoac ker) ot - pure - ker - { fsoac = soac', - outputTransform = ot' - } - - pullRearrange' = do - (soac', ot') <- pullRearrange (fsoac ker) ot - unless (SOAC.nullTransforms ot') $ - fail "pullRearrange was not enough" - pure - ker - { fsoac = soac', - outputTransform = SOAC.noTransforms - } - - exposeInputs' ker' = - case commonTransforms inpIds $ inputs ker' of - (ot', inps') - | all exposed inps' -> - pure (ker' {fsoac = inps' `SOAC.setInputs` fsoac ker'}, ot') - _ -> fail "Cannot expose" - - exposed (SOAC.Input ts _ _) - | SOAC.nullTransforms ts = True - exposed inp = SOAC.inputArray inp `notElem` inpIds - -outputTransformPullers :: [SOAC -> SOAC.ArrayTransforms -> TryFusion (SOAC, SOAC.ArrayTransforms)] -outputTransformPullers = [pullRearrange, pullReshape] - -pullOutputTransforms :: - SOAC -> - SOAC.ArrayTransforms -> - TryFusion (SOAC, SOAC.ArrayTransforms) -pullOutputTransforms = attempt outputTransformPullers - where - attempt [] _ _ = fail "Cannot pull anything" - attempt (p : ps) soac ots = - do - (soac', ots') <- p soac ots - if SOAC.nullTransforms ots' - then pure (soac', SOAC.noTransforms) - else pullOutputTransforms soac' ots' <|> pure (soac', ots') - <|> attempt ps soac ots diff --git a/src/Futhark/Optimise/Fusion/TryFusion.hs b/src/Futhark/Optimise/Fusion/TryFusion.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Optimise/Fusion/TryFusion.hs @@ -0,0 +1,856 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Facilities for fusing two SOACs. +-- +-- When the fusion algorithm decides that it's worth fusing two SOAC +-- statements, this is the module that tries to see if that's +-- possible. May involve massaging either producer or consumer in +-- various ways. +module Futhark.Optimise.Fusion.TryFusion + ( FusedSOAC (..), + attemptFusion, + ) +where + +import Control.Applicative +import Control.Arrow (first) +import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Data.List (find, tails, (\\)) +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Futhark.Analysis.HORep.MapNest as MapNest +import qualified Futhark.Analysis.HORep.SOAC as SOAC +import Futhark.Construct +import Futhark.IR.SOACS hiding (SOAC (..)) +import qualified Futhark.IR.SOACS as Futhark +import Futhark.Optimise.Fusion.Composing +import Futhark.Pass.ExtractKernels.ISRWIM (rwimPossible) +import Futhark.Transform.Rename (renameLambda) +import Futhark.Transform.Substitute +import Futhark.Util (splitAt3) + +newtype TryFusion a + = TryFusion + ( ReaderT + (Scope SOACS) + (StateT VNameSource Maybe) + a + ) + deriving + ( Functor, + Applicative, + Alternative, + Monad, + MonadFail, + MonadFreshNames, + HasScope SOACS, + LocalScope SOACS + ) + +tryFusion :: + MonadFreshNames m => + TryFusion a -> + Scope SOACS -> + m (Maybe a) +tryFusion (TryFusion m) types = modifyNameSource $ \src -> + case runStateT (runReaderT m types) src of + Just (x, src') -> (Just x, src') + Nothing -> (Nothing, src) + +liftMaybe :: Maybe a -> TryFusion a +liftMaybe Nothing = fail "Nothing" +liftMaybe (Just x) = pure x + +type SOAC = SOAC.SOAC SOACS + +type MapNest = MapNest.MapNest SOACS + +inputToOutput :: SOAC.Input -> Maybe (SOAC.ArrayTransform, SOAC.Input) +inputToOutput (SOAC.Input ts ia iat) = + case SOAC.viewf ts of + t SOAC.:< ts' -> Just (t, SOAC.Input ts' ia iat) + SOAC.EmptyF -> Nothing + +-- | A fused SOAC contains a bit of extra information. +data FusedSOAC = FusedSOAC + { -- | The actual SOAC. + fsSOAC :: SOAC, + -- | A transformation to be applied to *all* results of the SOAC. + fsOutputTransform :: SOAC.ArrayTransforms, + -- | The outputs of the SOAC (i.e. the names in the pattern that + -- the result of this SOAC should be bound to). + fsOutNames :: [VName] + } + deriving (Show) + +inputs :: FusedSOAC -> [SOAC.Input] +inputs = SOAC.inputs . fsSOAC + +setInputs :: [SOAC.Input] -> FusedSOAC -> FusedSOAC +setInputs inps ker = ker {fsSOAC = inps `SOAC.setInputs` fsSOAC ker} + +tryOptimizeSOAC :: + Names -> + [VName] -> + SOAC -> + FusedSOAC -> + TryFusion FusedSOAC +tryOptimizeSOAC unfus_nms outVars soac ker = do + (soac', ots) <- optimizeSOAC Nothing soac mempty + let ker' = map (addInitialTransformIfRelevant ots) (inputs ker) `setInputs` ker + outIdents = zipWith Ident outVars $ SOAC.typeOf soac' + ker'' = fixInputTypes outIdents ker' + applyFusionRules unfus_nms outVars soac' ker'' + where + addInitialTransformIfRelevant ots inp + | SOAC.inputArray inp `elem` outVars = + SOAC.addInitialTransforms ots inp + | otherwise = + inp + +tryOptimizeKernel :: + Names -> + [VName] -> + SOAC -> + FusedSOAC -> + TryFusion FusedSOAC +tryOptimizeKernel unfus_nms outVars soac ker = do + ker' <- optimizeKernel (Just outVars) ker + applyFusionRules unfus_nms outVars soac ker' + +tryExposeInputs :: + Names -> + [VName] -> + SOAC -> + FusedSOAC -> + TryFusion FusedSOAC +tryExposeInputs unfus_nms outVars soac ker = do + (ker', ots) <- exposeInputs outVars ker + if SOAC.nullTransforms ots + then fuseSOACwithKer unfus_nms outVars soac ker' + else do + guard $ unfus_nms == mempty + (soac', ots') <- pullOutputTransforms soac ots + let outIdents = zipWith Ident outVars $ SOAC.typeOf soac' + ker'' = fixInputTypes outIdents ker' + if SOAC.nullTransforms ots' + then applyFusionRules unfus_nms outVars soac' ker'' + else fail "tryExposeInputs could not pull SOAC transforms" + +fixInputTypes :: [Ident] -> FusedSOAC -> FusedSOAC +fixInputTypes outIdents ker = + ker {fsSOAC = fixInputTypes' $ fsSOAC ker} + where + fixInputTypes' soac = + map fixInputType (SOAC.inputs soac) `SOAC.setInputs` soac + fixInputType (SOAC.Input ts v _) + | Just v' <- find ((== v) . identName) outIdents = + SOAC.Input ts v $ identType v' + fixInputType inp = inp + +applyFusionRules :: + Names -> + [VName] -> + SOAC -> + FusedSOAC -> + TryFusion FusedSOAC +applyFusionRules unfus_nms outVars soac ker = + tryOptimizeSOAC unfus_nms outVars soac ker + <|> tryOptimizeKernel unfus_nms outVars soac ker + <|> fuseSOACwithKer unfus_nms outVars soac ker + <|> tryExposeInputs unfus_nms outVars soac ker + +-- | Attempt fusing the producer into the consumer. +attemptFusion :: + (HasScope SOACS m, MonadFreshNames m) => + -- | Outputs of the producer that should still be output by the + -- fusion result (corresponding to "diagonal fusion"). + Names -> + -- | The outputs of the SOAC. + [VName] -> + SOAC -> + FusedSOAC -> + m (Maybe FusedSOAC) +attemptFusion unfus_nms outVars soac ker = do + scope <- askScope + tryFusion (applyFusionRules unfus_nms outVars soac ker) scope + +-- | Check that the consumer does not use any scan or reduce results. +scremaFusionOK :: ([VName], [VName]) -> FusedSOAC -> Bool +scremaFusionOK (nonmap_outs, _map_outs) ker = + all (`notElem` nonmap_outs) $ mapMaybe SOAC.isVarishInput (inputs ker) + +-- | Check that the consumer uses all the outputs of the producer unmodified. +mapWriteFusionOK :: [VName] -> FusedSOAC -> Bool +mapWriteFusionOK outVars ker = all (`elem` inpIds) outVars + where + inpIds = mapMaybe SOAC.isVarishInput (inputs ker) + +-- | The brain of this module: Fusing a SOAC with a Kernel. +fuseSOACwithKer :: + Names -> + [VName] -> + SOAC -> + FusedSOAC -> + TryFusion FusedSOAC +fuseSOACwithKer unfus_set outVars soac_p ker = do + -- We are fusing soac_p into soac_c, i.e, the output of soac_p is going + -- into soac_c. + let soac_c = fsSOAC ker + inp_p_arr = SOAC.inputs soac_p + horizFuse = unfus_set /= mempty + inp_c_arr = SOAC.inputs soac_c + lam_p = SOAC.lambda soac_p + lam_c = SOAC.lambda soac_c + w = SOAC.width soac_p + returned_outvars = filter (`nameIn` unfus_set) outVars + success res_outnms res_soac = do + -- Avoid name duplication, because the producer lambda is not + -- removed from the program until much later. + uniq_lam <- renameLambda $ SOAC.lambda res_soac + pure $ + ker + { fsSOAC = uniq_lam `SOAC.setLambda` res_soac, + fsOutNames = res_outnms + } + + -- Can only fuse SOACs with same width. + guard $ SOAC.width soac_p == SOAC.width soac_c + + -- If we are getting rid of a producer output, then it must be used + -- without any transformation. + let bare_inputs = mapMaybe SOAC.isVarishInput (inputs ker) + ker_inputs = map SOAC.inputArray (inputs ker) + inputOrUnfus v = v `elem` bare_inputs || v `notElem` ker_inputs + + guard $ all inputOrUnfus outVars + + outPairs <- forM (zip outVars $ map rowType $ SOAC.typeOf soac_p) $ \(outVar, t) -> do + outVar' <- newVName $ baseString outVar ++ "_elem" + pure (outVar, Ident outVar' t) + + let mapLikeFusionCheck = + let (res_lam, new_inp) = fuseMaps unfus_set lam_p inp_p_arr outPairs lam_c inp_c_arr + (extra_nms, extra_rtps) = + unzip $ + filter ((`nameIn` unfus_set) . fst) $ + zip outVars $ + map (stripArray 1) $ + SOAC.typeOf soac_p + res_lam' = res_lam {lambdaReturnType = lambdaReturnType res_lam ++ extra_rtps} + in (extra_nms, res_lam', new_inp) + + when (horizFuse && not (SOAC.nullTransforms $ fsOutputTransform ker)) $ + fail "Horizontal fusion is invalid in the presence of output transforms." + + case (soac_c, soac_p) of + _ | SOAC.width soac_p /= SOAC.width soac_c -> fail "SOAC widths must match." + ( SOAC.Screma _ (ScremaForm scans_c reds_c _) _, + SOAC.Screma _ (ScremaForm scans_p reds_p _) _ + ) + | scremaFusionOK (splitAt (Futhark.scanResults scans_p + Futhark.redResults reds_p) outVars) ker -> do + let red_nes_p = concatMap redNeutral reds_p + red_nes_c = concatMap redNeutral reds_c + scan_nes_p = concatMap scanNeutral scans_p + scan_nes_c = concatMap scanNeutral scans_c + (res_lam', new_inp) = + fuseRedomap + unfus_set + outVars + lam_p + scan_nes_p + red_nes_p + inp_p_arr + outPairs + lam_c + scan_nes_c + red_nes_c + inp_c_arr + (soac_p_scanout, soac_p_redout, _soac_p_mapout) = + splitAt3 (length scan_nes_p) (length red_nes_p) outVars + (soac_c_scanout, soac_c_redout, soac_c_mapout) = + splitAt3 (length scan_nes_c) (length red_nes_c) $ fsOutNames ker + unfus_arrs = returned_outvars \\ (soac_p_scanout ++ soac_p_redout) + success + ( soac_p_scanout + ++ soac_c_scanout + ++ soac_p_redout + ++ soac_c_redout + ++ soac_c_mapout + ++ unfus_arrs + ) + $ SOAC.Screma + w + (ScremaForm (scans_p ++ scans_c) (reds_p ++ reds_c) res_lam') + new_inp + + ------------------ + -- Scatter fusion -- + ------------------ + + -- Map-Scatter fusion. + -- + -- The 'inplace' mechanism for kernels already takes care of + -- checking that the Scatter is not writing to any array used in + -- the Map. + ( SOAC.Scatter _len _lam _ivs dests, + SOAC.Screma _ form _ + ) + | isJust $ isMapSOAC form, + -- 1. all arrays produced by the map are ONLY used (consumed) + -- by the scatter, i.e., not used elsewhere. + all (`notNameIn` unfus_set) outVars, + -- 2. all arrays produced by the map are input to the scatter. + mapWriteFusionOK outVars ker -> do + let (extra_nms, res_lam', new_inp) = mapLikeFusionCheck + success (fsOutNames ker ++ extra_nms) $ + SOAC.Scatter w res_lam' new_inp dests + + -- Map-Hist fusion. + -- + -- The 'inplace' mechanism for kernels already takes care of + -- checking that the Hist is not writing to any array used in + -- the Map. + ( SOAC.Hist _ ops _ _, + SOAC.Screma _ form _ + ) + | isJust $ isMapSOAC form, + -- 1. all arrays produced by the map are ONLY used (consumed) + -- by the hist, i.e., not used elsewhere. + all (`notNameIn` unfus_set) outVars, + -- 2. all arrays produced by the map are input to the scatter. + mapWriteFusionOK outVars ker -> do + let (extra_nms, res_lam', new_inp) = mapLikeFusionCheck + success (fsOutNames ker ++ extra_nms) $ + SOAC.Hist w ops res_lam' new_inp + + -- Hist-Hist fusion + ( SOAC.Hist _ ops_c _ _, + SOAC.Hist _ ops_p _ _ + ) + | horizFuse -> do + let p_num_buckets = length ops_p + c_num_buckets = length ops_c + (body_p, body_c) = (lambdaBody lam_p, lambdaBody lam_c) + body' = + Body + { bodyDec = bodyDec body_p, -- body_p and body_c have the same decorations + bodyStms = bodyStms body_p <> bodyStms body_c, + bodyResult = + take c_num_buckets (bodyResult body_c) + ++ take p_num_buckets (bodyResult body_p) + ++ drop c_num_buckets (bodyResult body_c) + ++ drop p_num_buckets (bodyResult body_p) + } + lam' = + Lambda + { lambdaParams = lambdaParams lam_c ++ lambdaParams lam_p, + lambdaBody = body', + lambdaReturnType = + replicate (c_num_buckets + p_num_buckets) (Prim int64) + ++ drop c_num_buckets (lambdaReturnType lam_c) + ++ drop p_num_buckets (lambdaReturnType lam_p) + } + success (fsOutNames ker ++ returned_outvars) $ + SOAC.Hist w (ops_c <> ops_p) lam' (inp_c_arr <> inp_p_arr) + + -- Scatter-write fusion. + ( SOAC.Scatter _len_c _lam_c ivs_c as_c, + SOAC.Scatter _len_p _lam_p ivs_p as_p + ) + | horizFuse -> do + let zipW as_xs xs as_ys ys = xs_indices ++ ys_indices ++ xs_vals ++ ys_vals + where + (xs_indices, xs_vals) = splitScatterResults as_xs xs + (ys_indices, ys_vals) = splitScatterResults as_ys ys + let (body_p, body_c) = (lambdaBody lam_p, lambdaBody lam_c) + let body' = + Body + { bodyDec = bodyDec body_p, -- body_p and body_c have the same decorations + bodyStms = bodyStms body_p <> bodyStms body_c, + bodyResult = zipW as_c (bodyResult body_c) as_p (bodyResult body_p) + } + let lam' = + Lambda + { lambdaParams = lambdaParams lam_c ++ lambdaParams lam_p, + lambdaBody = body', + lambdaReturnType = zipW as_c (lambdaReturnType lam_c) as_p (lambdaReturnType lam_p) + } + success (fsOutNames ker ++ returned_outvars) $ + SOAC.Scatter w lam' (ivs_c ++ ivs_p) (as_c ++ as_p) + (SOAC.Scatter {}, _) -> + fail "Cannot fuse a write with anything else than a write or a map" + (_, SOAC.Scatter {}) -> + fail "Cannot fuse a write with anything else than a write or a map" + ---------------------------- + -- Stream-Stream Fusions: -- + ---------------------------- + (SOAC.Stream _ Sequential _ _ _, SOAC.Stream _ Sequential _ _ _) -> do + -- fuse two SEQUENTIAL streams + (res_nms, res_stream) <- fuseStreamHelper (fsOutNames ker) unfus_set outVars outPairs soac_c soac_p + success res_nms res_stream + (SOAC.Stream {}, SOAC.Stream {}) -> do + -- fuse two PARALLEL streams + (res_nms, res_stream) <- fuseStreamHelper (fsOutNames ker) unfus_set outVars outPairs soac_c soac_p + success res_nms res_stream + ------------------------------------------------------------------- + --- If one is a stream, translate the other to a stream as well.--- + --- This does not get in trouble (infinite computation) because --- + --- scan's translation to Stream introduces a hindrance to --- + --- (horizontal fusion), hence repeated application is for the--- + --- moment impossible. However, if with a dependence-graph rep--- + --- we could run in an infinite recursion, i.e., repeatedly --- + --- fusing map o scan into an infinity of Stream levels! --- + ------------------------------------------------------------------- + (SOAC.Stream _ form2 _ _ _, _) -> do + -- If this rule is matched then soac_p is NOT a stream. + -- To fuse a stream kernel, we transform soac_p to a stream, which + -- borrows the sequential/parallel property of the soac_c Stream, + -- and recursively perform stream-stream fusion. + (soac_p', newacc_ids) <- SOAC.soacToStream soac_p + soac_p'' <- case form2 of + Sequential {} -> maybe (fail "not a stream") pure (toSeqStream soac_p') + _ -> pure soac_p' + if soac_p' == soac_p + then fail "SOAC could not be turned into stream." + else + fuseSOACwithKer + (namesFromList (map identName newacc_ids) <> unfus_set) + (map identName newacc_ids ++ outVars) + soac_p'' + ker + (_, SOAC.Screma _ form _) | Just _ <- Futhark.isScanomapSOAC form -> do + -- A Scan soac can be currently only fused as a (sequential) stream, + -- hence it is first translated to a (sequential) Stream and then + -- fusion with a kernel is attempted. + (soac_p', newacc_ids) <- SOAC.soacToStream soac_p + if soac_p' /= soac_p + then + fuseSOACwithKer + (namesFromList (map identName newacc_ids) <> unfus_set) + (map identName newacc_ids ++ outVars) + soac_p' + ker + else fail "SOAC could not be turned into stream." + (_, SOAC.Stream _ form_p _ _ _) -> do + -- If it reached this case then soac_c is NOT a Stream kernel, + -- hence transform the kernel's soac to a stream and attempt + -- stream-stream fusion recursivelly. + -- The newly created stream corresponding to soac_c borrows the + -- sequential/parallel property of the soac_p stream. + (soac_c', newacc_ids) <- SOAC.soacToStream soac_c + when (soac_c' == soac_c) $ fail "SOAC could not be turned into stream." + soac_c'' <- case form_p of + Sequential -> maybe (fail "not a stream") pure (toSeqStream soac_c') + _ -> pure soac_c' + + fuseSOACwithKer + (namesFromList (map identName newacc_ids) <> unfus_set) + outVars + soac_p + $ ker {fsSOAC = soac_c'', fsOutNames = map identName newacc_ids ++ fsOutNames ker} + + --------------------------------- + --- DEFAULT, CANNOT FUSE CASE --- + --------------------------------- + _ -> fail "Cannot fuse" + +getStreamOrder :: StreamForm rep -> StreamOrd +getStreamOrder (Parallel o _ _) = o +getStreamOrder Sequential = InOrder + +fuseStreamHelper :: + [VName] -> + Names -> + [VName] -> + [(VName, Ident)] -> + SOAC -> + SOAC -> + TryFusion ([VName], SOAC) +fuseStreamHelper + out_kernms + unfus_set + outVars + outPairs + (SOAC.Stream w2 form2 lam2 nes2 inp2_arr) + (SOAC.Stream _ form1 lam1 nes1 inp1_arr) = + if getStreamOrder form2 /= getStreamOrder form1 + then fail "fusion conditions not met!" + else do + -- very similar to redomap o redomap composition, but need + -- to remove first the `chunk' parameters of streams' + -- lambdas and put them in the resulting stream lambda. + let chunk1 = head $ lambdaParams lam1 + chunk2 = head $ lambdaParams lam2 + hmnms = M.fromList [(paramName chunk2, paramName chunk1)] + lam20 = substituteNames hmnms lam2 + lam1' = lam1 {lambdaParams = tail $ lambdaParams lam1} + lam2' = lam20 {lambdaParams = tail $ lambdaParams lam20} + (res_lam', new_inp) = + fuseRedomap + unfus_set + outVars + lam1' + [] + nes1 + inp1_arr + outPairs + lam2' + [] + nes2 + inp2_arr + res_lam'' = res_lam' {lambdaParams = chunk1 : lambdaParams res_lam'} + unfus_accs = take (length nes1) outVars + unfus_arrs = filter (`notElem` unfus_accs) $ filter (`nameIn` unfus_set) outVars + let res_form = mergeForms form2 form1 + pure + ( unfus_accs ++ out_kernms ++ unfus_arrs, + SOAC.Stream w2 res_form res_lam'' (nes1 ++ nes2) new_inp + ) +fuseStreamHelper _ _ _ _ _ _ = fail "Cannot Fuse Streams!" + +mergeForms :: StreamForm SOACS -> StreamForm SOACS -> StreamForm SOACS +mergeForms Sequential Sequential = Sequential +mergeForms (Parallel _ comm2 lam2r) (Parallel o1 comm1 lam1r) = + Parallel o1 (comm1 <> comm2) (mergeReduceOps lam1r lam2r) +mergeForms _ _ = error "Fusing sequential to parallel stream disallowed!" + +-- | If a Stream is passed as argument then it converts it to a +-- Sequential Stream. +toSeqStream :: SOAC -> Maybe SOAC +toSeqStream s@(SOAC.Stream _ Sequential _ _ _) = Just s +toSeqStream (SOAC.Stream w Parallel {} l acc inps) = + Just $ SOAC.Stream w Sequential l acc inps +toSeqStream _ = Nothing + +-- Here follows optimizations and transforms to expose fusability. + +optimizeKernel :: Maybe [VName] -> FusedSOAC -> TryFusion FusedSOAC +optimizeKernel inp ker = do + (soac, resTrans) <- optimizeSOAC inp (fsSOAC ker) (fsOutputTransform ker) + pure $ ker {fsSOAC = soac, fsOutputTransform = resTrans} + +optimizeSOAC :: + Maybe [VName] -> + SOAC -> + SOAC.ArrayTransforms -> + TryFusion (SOAC, SOAC.ArrayTransforms) +optimizeSOAC inp soac os = do + res <- foldM comb (False, soac, os) optimizations + case res of + (False, _, _) -> fail "No optimisation applied" + (True, soac', os') -> pure (soac', os') + where + comb (changed, soac', os') f = + do + (soac'', os'') <- f inp soac' os + pure (True, soac'', os'') + <|> pure (changed, soac', os') + +type Optimization = + Maybe [VName] -> + SOAC -> + SOAC.ArrayTransforms -> + TryFusion (SOAC, SOAC.ArrayTransforms) + +optimizations :: [Optimization] +optimizations = [iswim] + +iswim :: + Maybe [VName] -> + SOAC -> + SOAC.ArrayTransforms -> + TryFusion (SOAC, SOAC.ArrayTransforms) +iswim _ (SOAC.Screma w form arrs) ots + | Just [Futhark.Scan scan_fun nes] <- Futhark.isScanSOAC form, + Just (map_pat, map_cs, map_w, map_fun) <- rwimPossible scan_fun, + Just nes_names <- mapM subExpVar nes = do + let nes_idents = zipWith Ident nes_names $ lambdaReturnType scan_fun + map_nes = map SOAC.identInput nes_idents + map_arrs' = map_nes ++ map (SOAC.transposeInput 0 1) arrs + (scan_acc_params, scan_elem_params) = + splitAt (length arrs) $ lambdaParams scan_fun + map_params = + map removeParamOuterDim scan_acc_params + ++ map (setParamOuterDimTo w) scan_elem_params + map_rettype = map (`setOuterSize` w) $ lambdaReturnType scan_fun + + scan_params = lambdaParams map_fun + scan_body = lambdaBody map_fun + scan_rettype = lambdaReturnType map_fun + scan_fun' = Lambda scan_params scan_body scan_rettype + nes' = map Var $ take (length map_nes) $ map paramName map_params + arrs' = drop (length map_nes) $ map paramName map_params + + scan_form <- scanSOAC [Futhark.Scan scan_fun' nes'] + + let map_body = + mkBody + ( oneStm $ + Let (setPatOuterDimTo w map_pat) (defAux ()) $ + Op $ + Futhark.Screma w arrs' scan_form + ) + $ varsRes + $ patNames map_pat + map_fun' = Lambda map_params map_body map_rettype + perm = case lambdaReturnType scan_fun of -- instead of map_fun + [] -> [] + t : _ -> 1 : 0 : [2 .. arrayRank t] + + pure + ( SOAC.Screma map_w (ScremaForm [] [] map_fun') map_arrs', + ots SOAC.|> SOAC.Rearrange map_cs perm + ) +iswim _ _ _ = + fail "ISWIM does not apply." + +removeParamOuterDim :: LParam SOACS -> LParam SOACS +removeParamOuterDim param = + let t = rowType $ paramType param + in param {paramDec = t} + +setParamOuterDimTo :: SubExp -> LParam SOACS -> LParam SOACS +setParamOuterDimTo w param = + let t = paramType param `setOuterSize` w + in param {paramDec = t} + +setPatOuterDimTo :: SubExp -> Pat Type -> Pat Type +setPatOuterDimTo w = fmap (`setOuterSize` w) + +-- Now for fiddling with transpositions... + +commonTransforms :: + [VName] -> + [SOAC.Input] -> + (SOAC.ArrayTransforms, [SOAC.Input]) +commonTransforms interesting inps = commonTransforms' inps' + where + inps' = + [ (SOAC.inputArray inp `elem` interesting, inp) + | inp <- inps + ] + +commonTransforms' :: [(Bool, SOAC.Input)] -> (SOAC.ArrayTransforms, [SOAC.Input]) +commonTransforms' inps = + case foldM inspect (Nothing, []) inps of + Just (Just mot, inps') -> first (mot SOAC.<|) $ commonTransforms' $ reverse inps' + _ -> (SOAC.noTransforms, map snd inps) + where + inspect (mot, prev) (True, inp) = + case (mot, inputToOutput inp) of + (Nothing, Just (ot, inp')) -> Just (Just ot, (True, inp') : prev) + (Just ot1, Just (ot2, inp')) + | ot1 == ot2 -> Just (Just ot2, (True, inp') : prev) + _ -> Nothing + inspect (mot, prev) inp = Just (mot, inp : prev) + +mapDepth :: MapNest -> Int +mapDepth (MapNest.MapNest _ lam levels _) = + min resDims (length levels) + 1 + where + resDims = minDim $ case levels of + [] -> lambdaReturnType lam + nest : _ -> MapNest.nestingReturnType nest + minDim [] = 0 + minDim (t : ts) = foldl min (arrayRank t) $ map arrayRank ts + +pullRearrange :: + SOAC -> + SOAC.ArrayTransforms -> + TryFusion (SOAC, SOAC.ArrayTransforms) +pullRearrange soac ots = do + nest <- liftMaybe =<< MapNest.fromSOAC soac + SOAC.Rearrange cs perm SOAC.:< ots' <- pure $ SOAC.viewf ots + if rearrangeReach perm <= mapDepth nest + then do + let -- Expand perm to cover the full extent of the input dimensionality + perm' inp = take r perm ++ [length perm .. r - 1] + where + r = SOAC.inputRank inp + addPerm inp = SOAC.addTransform (SOAC.Rearrange cs $ perm' inp) inp + inputs' = map addPerm $ MapNest.inputs nest + soac' <- + MapNest.toSOAC $ + inputs' `MapNest.setInputs` rearrangeReturnTypes nest perm + pure (soac', ots') + else fail "Cannot pull transpose" + +pushRearrange :: + [VName] -> + SOAC -> + SOAC.ArrayTransforms -> + TryFusion (SOAC, SOAC.ArrayTransforms) +pushRearrange inpIds soac ots = do + nest <- liftMaybe =<< MapNest.fromSOAC soac + (perm, inputs') <- liftMaybe $ fixupInputs inpIds $ MapNest.inputs nest + if rearrangeReach perm <= mapDepth nest + then do + let invertRearrange = SOAC.Rearrange mempty $ rearrangeInverse perm + soac' <- + MapNest.toSOAC $ + inputs' + `MapNest.setInputs` rearrangeReturnTypes nest perm + pure (soac', invertRearrange SOAC.<| ots) + else fail "Cannot push transpose" + +-- | Actually also rearranges indices. +rearrangeReturnTypes :: MapNest -> [Int] -> MapNest +rearrangeReturnTypes nest@(MapNest.MapNest w body nestings inps) perm = + MapNest.MapNest + w + body + ( zipWith + setReturnType + nestings + $ drop 1 + $ iterate (map rowType) ts + ) + inps + where + origts = MapNest.typeOf nest + -- The permutation may be deeper than the rank of the type, + -- but it is required that it is an identity permutation + -- beyond that. This is supposed to be checked as an + -- invariant by whoever calls rearrangeReturnTypes. + rearrangeType' t = rearrangeType (take (arrayRank t) perm) t + ts = map rearrangeType' origts + + setReturnType nesting t' = + nesting {MapNest.nestingReturnType = t'} + +fixupInputs :: [VName] -> [SOAC.Input] -> Maybe ([Int], [SOAC.Input]) +fixupInputs inpIds inps = + case mapMaybe inputRearrange $ filter exposable inps of + perm : _ -> do + inps' <- mapM (fixupInput (rearrangeReach perm) perm) inps + pure (perm, inps') + _ -> Nothing + where + exposable = (`elem` inpIds) . SOAC.inputArray + + inputRearrange (SOAC.Input ts _ _) + | _ SOAC.:> SOAC.Rearrange _ perm <- SOAC.viewl ts = Just perm + inputRearrange _ = Nothing + + fixupInput d perm inp + | r <- SOAC.inputRank inp, + r >= d = + Just $ SOAC.addTransform (SOAC.Rearrange mempty $ take r perm) inp + | otherwise = Nothing + +pullReshape :: SOAC -> SOAC.ArrayTransforms -> TryFusion (SOAC, SOAC.ArrayTransforms) +pullReshape (SOAC.Screma _ form inps) ots + | Just maplam <- Futhark.isMapSOAC form, + SOAC.Reshape cs shape SOAC.:< ots' <- SOAC.viewf ots, + all primType $ lambdaReturnType maplam = do + let mapw' = case reverse $ newDims shape of + [] -> intConst Int64 0 + d : _ -> d + trInput inp + | arrayRank (SOAC.inputType inp) == 1 = + SOAC.addTransform (SOAC.Reshape cs shape) inp + | otherwise = + SOAC.addTransform (SOAC.ReshapeOuter cs shape) inp + inputs' = map trInput inps + inputTypes = map SOAC.inputType inputs' + + let outersoac :: + ([SOAC.Input] -> SOAC) -> + (SubExp, [SubExp]) -> + TryFusion ([SOAC.Input] -> SOAC) + outersoac inner (w, outershape) = do + let addDims t = arrayOf t (Shape outershape) NoUniqueness + retTypes = map addDims $ lambdaReturnType maplam + + ps <- forM inputTypes $ \inpt -> + newParam "pullReshape_param" $ + stripArray (length shape - length outershape) inpt + + inner_body <- + runBodyBuilder $ + eBody [SOAC.toExp $ inner $ map (SOAC.identInput . paramIdent) ps] + let inner_fun = + Lambda + { lambdaParams = ps, + lambdaReturnType = retTypes, + lambdaBody = inner_body + } + pure $ SOAC.Screma w $ Futhark.mapSOAC inner_fun + + op' <- + foldM outersoac (SOAC.Screma mapw' $ Futhark.mapSOAC maplam) $ + zip (drop 1 $ reverse $ newDims shape) $ + drop 1 $ + reverse $ + drop 1 $ + tails $ + newDims shape + pure (op' inputs', ots') +pullReshape _ _ = fail "Cannot pull reshape" + +-- Tie it all together in exposeInputs (for making inputs to a +-- consumer available) and pullOutputTransforms (for moving +-- output-transforms of a producer to its inputs instead). + +exposeInputs :: + [VName] -> + FusedSOAC -> + TryFusion (FusedSOAC, SOAC.ArrayTransforms) +exposeInputs inpIds ker = + (exposeInputs' =<< pushRearrange') + <|> (exposeInputs' =<< pullRearrange') + <|> exposeInputs' ker + where + ot = fsOutputTransform ker + + pushRearrange' = do + (soac', ot') <- pushRearrange inpIds (fsSOAC ker) ot + pure + ker + { fsSOAC = soac', + fsOutputTransform = ot' + } + + pullRearrange' = do + (soac', ot') <- pullRearrange (fsSOAC ker) ot + unless (SOAC.nullTransforms ot') $ + fail "pullRearrange was not enough" + pure + ker + { fsSOAC = soac', + fsOutputTransform = SOAC.noTransforms + } + + exposeInputs' ker' = + case commonTransforms inpIds $ inputs ker' of + (ot', inps') + | all exposed inps' -> + pure (ker' {fsSOAC = inps' `SOAC.setInputs` fsSOAC ker'}, ot') + _ -> fail "Cannot expose" + + exposed (SOAC.Input ts _ _) + | SOAC.nullTransforms ts = True + exposed inp = SOAC.inputArray inp `notElem` inpIds + +outputTransformPullers :: [SOAC -> SOAC.ArrayTransforms -> TryFusion (SOAC, SOAC.ArrayTransforms)] +outputTransformPullers = [pullRearrange, pullReshape] + +pullOutputTransforms :: + SOAC -> + SOAC.ArrayTransforms -> + TryFusion (SOAC, SOAC.ArrayTransforms) +pullOutputTransforms = attempt outputTransformPullers + where + attempt [] _ _ = fail "Cannot pull anything" + attempt (p : ps) soac ots = + do + (soac', ots') <- p soac ots + if SOAC.nullTransforms ots' + then pure (soac', SOAC.noTransforms) + else pullOutputTransforms soac' ots' <|> pure (soac', ots') + <|> attempt ps soac ots diff --git a/src/Futhark/Optimise/GenRedOpt.hs b/src/Futhark/Optimise/GenRedOpt.hs --- a/src/Futhark/Optimise/GenRedOpt.hs +++ b/src/Futhark/Optimise/GenRedOpt.hs @@ -210,7 +210,7 @@ -- is a subexp invariant to a gid of a parallel dimension? isSeInvar2 variance gid (Var x) = let x_deps = M.findWithDefault mempty x variance - in gid /= x && not (nameIn gid x_deps) + in gid /= x && gid `notNameIn` x_deps isSeInvar2 _ _ _ = True -- is a DimIndex invar to a gid of a parallel dimension? isDimIdxInvar2 variance gid (DimFix d) = @@ -224,7 +224,7 @@ isTileable :: VName -> [(VName, SubExp)] -> VarianceTable -> VName -> Stm GPU -> Bool isTileable seq_gid gid_dims variance acc_nm (Let (Pat [pel]) _ (BasicOp (Index _ slc))) | acc_deps <- M.findWithDefault mempty acc_nm variance, - nameIn (patElemName pel) acc_deps = + patElemName pel `nameIn` acc_deps = let invar_par = isSliceInvar2 variance slc (map fst gid_dims) invar_seq = isSliceInvar2 variance slc [seq_gid] in invar_par || invar_seq @@ -261,7 +261,7 @@ transposeFV (tab, Let pat aux (BasicOp (Index arr slc))) | dims <- unSlice slc, all isFixDim dims, - nameIn arr fvs, + arr `nameIn` fvs, iis <- L.findIndices depOnGid dims, [ii] <- iis, -- generalize below: treat any rearange and add to tab if not there. @@ -318,7 +318,7 @@ Maybe (VName, Int) isInvarToParDim branch_variant kspace variance acc_inds = let ker_gids = map fst $ unSegSpace kspace - branch_invariant = not $ any (`nameIn` branch_variant) ker_gids + branch_invariant = all (`notNameIn` branch_variant) ker_gids allvar2 = allvariant2 acc_inds ker_gids last_invar_dim = foldl (lastNotIn allvar2) Nothing $ @@ -336,7 +336,7 @@ allvariant2 ind_ses kids = namesFromList $ concatMap (`variant2` kids) ind_ses lastNotIn allvar2 acc (kid, k) = - if nameIn kid allvar2 then acc else Just (kid, k) + if kid `nameIn` allvar2 then acc else Just (kid, k) allGoodReturns :: [KernelResult] -> Maybe ([VName], [SubExp]) allGoodReturns kres @@ -405,7 +405,9 @@ costBody :: Body GPU -> Cost costBody bdy = foldl addCosts (Small 0) $ - map costRedundantStmt $ stmsToList $ bodyStms bdy + map costRedundantStmt $ + stmsToList $ + bodyStms bdy costRedundantStmt :: Stm GPU -> Cost costRedundantStmt (Let _ _ (Op _)) = Big diff --git a/src/Futhark/Optimise/HistAccs.hs b/src/Futhark/Optimise/HistAccs.hs --- a/src/Futhark/Optimise/HistAccs.hs +++ b/src/Futhark/Optimise/HistAccs.hs @@ -75,9 +75,13 @@ vs <- forM arrs $ \arr -> do arr_t <- lookupType arr letSubExp (baseString arr <> "_elem") $ - BasicOp $ Index arr $ fullSlice arr_t $ map (DimFix . Var) gtids + BasicOp $ + Index arr $ + fullSlice arr_t $ + map (DimFix . Var) gtids letExp (baseString acc <> "_upd") $ - BasicOp $ UpdateAcc acc (map Var gtids) vs + BasicOp $ + UpdateAcc acc (map Var gtids) vs acc_t <- lookupType acc pure . Op . SegOp . SegMap lvl space [acc_t] $ 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 @@ -148,7 +148,7 @@ -- XXX: unfortunate that we cannot handle duplicate update values. -- Would be good to improve this. See inplacelowering6.fut. case nubByOrd (comparing updateValue) - . filter (not . (`nameIn` bottomUpSeen bup) . updateSource) -- (9) + . filter ((`notNameIn` bottomUpSeen bup) . updateSource) -- (9) . filter ((`elem` boundHere) . updateValue) $ forwardThese bup of [] -> do @@ -213,7 +213,10 @@ stms <- deepen $ optimiseStms (stmsToList (kernelBodyStms kbody)) $ - mapM_ seenVar $ namesToList $ freeIn $ kernelBodyResult kbody + mapM_ seenVar $ + namesToList $ + freeIn $ + kernelBodyResult kbody pure kbody {kernelBodyStms = stmsFromList stms} mapSegOpM mapper op 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 @@ -58,7 +58,8 @@ pure $ prestms ++ [ certify (stmAuxCerts aux) $ - mkLet pat' $ DoLoop merge' form body' + mkLet pat' $ + DoLoop merge' form body' ] ++ poststms lowerUpdate @@ -70,7 +71,9 @@ in Just . pure $ [ certify (stmAuxCerts aux <> cs) $ mkLet [Ident bindee_nm $ typeOf bindee_dec] $ - BasicOp $ Update Unsafe v is' $ Var val + BasicOp $ + Update Unsafe v is' $ + Var val ] lowerUpdate _ _ _ = Nothing @@ -87,8 +90,8 @@ (pat', kbody', poststms) <- mk let cs = stmAuxCerts aux <> foldMap updateCerts updates pure $ - certify cs (Let pat' aux $ Op $ SegOp $ SegMap lvl space ts kbody') : - stmsToList poststms + certify cs (Let pat' aux $ Op $ SegOp $ SegMap lvl space ts kbody') + : stmsToList poststms where -- This check is a bit more conservative than ideal. In a perfect -- world, we would allow indexing a[i,j] if the update is also @@ -148,7 +151,8 @@ (slice', bodystms) <- flip runBuilderT scope $ traverse (toSubExp "index") $ - fixSlice (fmap pe64 slice) $ map (pe64 . Var) gtids + fixSlice (fmap pe64 slice) $ + map (pe64 . Var) gtids let res_dims = take (length slice') $ arrayDims $ snd bindee_dec ret' = WriteReturns cs (Shape res_dims) src [(Slice $ map DimFix slice', se)] @@ -218,7 +222,7 @@ -- Safety condition (8). forM_ (zip val $ bodyAliases body) $ \((p, _), als) -> - guard $ not $ paramName p `nameIn` als + guard $ paramName p `notNameIn` als mk_in_place_map <- summariseLoop scope updates usedInBody resmap val @@ -252,12 +256,13 @@ let source_t = snd $ updateType update elm_t = source_t `setArrayDims` sliceDims (updateIndices update) tell - ( [ mkLet [Ident source source_t] . BasicOp $ - Update + ( [ mkLet [Ident source source_t] . BasicOp + $ Update Unsafe (updateSource update) (fullSlice source_t $ unSlice $ updateIndices update) - $ snd $ mergeParam summary + $ snd + $ mergeParam summary ], [ mkLet [Ident precopy elm_t] . BasicOp $ Index 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 @@ -68,7 +68,8 @@ [v'] <- patNames pat = do src' <- letExp (baseString v' <> "_subst") $ - BasicOp $ Rotate (replicate (arrayRank src_t - length rots) zero ++ rots) src + BasicOp $ + Rotate (replicate (arrayRank src_t - length rots) zero ++ rots) src src_t' <- lookupType src' pure $ (v', (cs, src', src_t', is)) : substs where @@ -99,7 +100,9 @@ v' <- certifying cs $ letExp (baseString src <> "_op_idx") $ - BasicOp $ Index src $ fullSlice (typeOf src_dec) is + BasicOp $ + Index src $ + fullSlice (typeOf src_dec) is pure $ M.singleton v v' pure $ Op $ substituteNames var_substs op substituteIndicesInExp substs e = do @@ -119,7 +122,9 @@ row <- certifying cs2 $ letExp (baseString v ++ "_row") $ - BasicOp $ Index src2 $ fullSlice (typeOf src2dec) (unSlice is2) + BasicOp $ + Index src2 $ + fullSlice (typeOf src2dec) (unSlice is2) row_copy <- letExp (baseString v ++ "_row_copy") $ BasicOp $ Copy row pure $ @@ -157,11 +162,16 @@ substituteIndicesInVar substs v | Just (cs2, src2, _, Slice []) <- lookup v substs = certifying cs2 $ - letExp (baseString src2) $ BasicOp $ SubExp $ Var src2 + letExp (baseString src2) $ + BasicOp $ + SubExp $ + Var src2 | Just (cs2, src2, src2_dec, Slice is2) <- lookup v substs = certifying cs2 $ letExp (baseString src2 <> "_v_idx") $ - BasicOp $ Index src2 $ fullSlice (typeOf src2_dec) is2 + BasicOp $ + Index src2 $ + fullSlice (typeOf src2_dec) is2 | otherwise = pure v @@ -173,10 +183,12 @@ substituteIndicesInBody substs (Body _ stms res) = do (substs', stms') <- inScopeOf stms $ - collectStms $ substituteIndicesInStms substs stms + collectStms $ + substituteIndicesInStms substs stms (res', res_stms) <- inScopeOf stms' $ - collectStms $ mapM (onSubExpRes substs') res + collectStms $ + mapM (onSubExpRes substs') res mkBodyM (stms' <> res_stms) res' where onSubExpRes substs' (SubExpRes cs se) = 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 @@ -59,10 +59,12 @@ Prog SOACS -> m (Prog SOACS) inlineFunctions simplify_rate cg what_should_be_inlined prog = do - let Prog consts funs = prog + let consts = progConsts prog + funs = progFuns prog vtable = ST.fromScope (addScopeWisdom (scopeOf consts)) - uncurry Prog <$> recurse (1, vtable) (consts, funs) what_should_be_inlined + (consts', funs') <- recurse (1, vtable) (consts, funs) what_should_be_inlined + pure $ prog {progConsts = consts', progFuns = funs'} where fdmap fds = M.fromList $ zip (map funDefName fds) fds @@ -112,8 +114,10 @@ inlineBecauseTiny = foldMap onFunDef . progFuns where onFunDef fd - | length (bodyStms (funDefBody fd)) < 2 - || "inline" `inAttrs` funDefAttrs fd = + | length (bodyStms (funDefBody fd)) + < 2 + || "inline" + `inAttrs` funDefAttrs fd = S.singleton (funDefName fd) | otherwise = mempty @@ -164,7 +168,8 @@ body_stms = addLocations (stmAuxAttrs aux) safety (filter notmempty (loc : locs)) $ - bodyStms $ funDefBody fun + 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 diff --git a/src/Futhark/Optimise/ReduceDeviceSyncs.hs b/src/Futhark/Optimise/ReduceDeviceSyncs.hs --- a/src/Futhark/Optimise/ReduceDeviceSyncs.hs +++ b/src/Futhark/Optimise/ReduceDeviceSyncs.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | This module implements an optimization that migrates host -- statements into 'GPUBody' kernels to reduce the number of -- host-device synchronizations that occur when a scalar variable is @@ -8,10 +10,9 @@ module Futhark.Optimise.ReduceDeviceSyncs (reduceDeviceSyncs) where import Control.Monad -import Control.Monad.Trans.Class -import qualified Control.Monad.Trans.Reader as R -import Control.Monad.Trans.State.Strict hiding (State) -import Control.Parallel.Strategies (parMap, rpar) +import Control.Monad.Reader +import Control.Monad.State hiding (State) +import Data.Bifunctor (second) import Data.Foldable import qualified Data.IntMap.Strict as IM import Data.List (unzip4, zip4) @@ -20,9 +21,8 @@ import qualified Data.Text as T import Futhark.Construct (fullSlice, sliceDim) import Futhark.Error -import qualified Futhark.FreshNames as FN import Futhark.IR.GPU -import Futhark.MonadFreshNames (VNameSource, getNameSource, putNameSource) +import Futhark.MonadFreshNames import Futhark.Optimise.ReduceDeviceSyncs.MigrationTable import Futhark.Pass import Futhark.Transform.Substitute @@ -34,28 +34,23 @@ Pass "reduce device synchronizations" "Move host statements to device to reduce blocking memory operations." - run + $ \prog -> do + let hof = hostOnlyFunDefs $ progFuns prog + consts_mt = analyseConsts hof (progFuns prog) (progConsts prog) + consts <- onConsts consts_mt $ progConsts prog + funs <- parPass (onFun hof consts_mt) (progFuns prog) + pure $ prog {progConsts = consts, progFuns = funs} where - run prog = do - ns <- getNameSource - let mt = analyseProg prog - let st = initialState ns - let (prog', st') = R.runReader (runStateT (optimizeProgram prog) st) mt - putNameSource (stateNameSource st') - pure prog' + onConsts consts_mt stms = + runReduceM consts_mt (optimizeStms stms) + onFun hof consts_mt fd = do + let mt = consts_mt <> analyseFunDef hof fd + runReduceM mt (optimizeFunDef fd) -------------------------------------------------------------------------------- -- AD HOC OPTIMIZATION -- -------------------------------------------------------------------------------- --- | Optimize a whole program. The type signatures of top-level functions will --- remain unchanged. -optimizeProgram :: Prog GPU -> ReduceM (Prog GPU) -optimizeProgram (Prog consts funs) = do - consts' <- optimizeStms consts - funs' <- sequence $ parMap rpar optimizeFunDef funs - pure (Prog consts' funs') - -- | Optimize a function definition. Its type signature will remain unchanged. optimizeFunDef :: FunDef GPU -> ReduceM (FunDef GPU) optimizeFunDef fd = do @@ -372,8 +367,23 @@ -------------------------------------------------------------------------------- -- | The monad used to perform migration-based synchronization reductions. -type ReduceM = StateT State (R.Reader MigrationTable) +newtype ReduceM a = ReduceM (StateT State (Reader MigrationTable) a) + deriving + ( Functor, + Applicative, + Monad, + MonadState State, + MonadReader MigrationTable + ) +runReduceM :: MonadFreshNames m => MigrationTable -> ReduceM a -> m a +runReduceM mt (ReduceM m) = modifyNameSource $ \src -> + second stateNameSource (runReader (runStateT m (initialState src)) mt) + +instance MonadFreshNames ReduceM where + getNameSource = gets stateNameSource + putNameSource src = modify $ \s -> s {stateNameSource = src} + -- | The state used by a 'ReduceM' monad. data State = State { -- | A source to generate new 'VName's from. @@ -403,14 +413,6 @@ stateGPUBodyOk = True } --- | Retrieve a function of the current environment. -asks :: (MigrationTable -> a) -> ReduceM a -asks = lift . R.asks - --- | Fetch the value of the environment. -ask :: ReduceM MigrationTable -ask = lift R.ask - -- | Perform non-migration optimizations without introducing any GPUBody -- kernels. noGPUBody :: ReduceM a -> ReduceM a @@ -421,15 +423,6 @@ modify $ \st -> st {stateGPUBodyOk = prev} pure res --- | Produce a fresh name, using the given name as a template. -newName :: VName -> ReduceM VName -newName n = do - st <- get - let ns = stateNameSource st - let (n', ns') = FN.newName ns n - put (st {stateNameSource = ns'}) - pure n' - -- | Create a 'PatElem' that binds the array of a migrated variable binding. arrayizePatElem :: PatElem Type -> ReduceM (PatElem Type) arrayizePatElem (PatElem n t) = do @@ -474,7 +467,7 @@ -- provided statements and be returned. useScalar :: Stms GPU -> VName -> ReduceM (Stms GPU, VName) useScalar stms n = do - entry <- IM.lookup (baseTag n) <$> gets stateMigrated + entry <- gets $ IM.lookup (baseTag n) . stateMigrated case entry of Nothing -> pure (stms, n) @@ -499,7 +492,7 @@ storedScalar :: SubExp -> ReduceM (Maybe VName) storedScalar (Constant _) = pure Nothing storedScalar (Var n) = do - entry <- IM.lookup (baseTag n) <$> gets stateMigrated + entry <- gets $ IM.lookup (baseTag n) . stateMigrated pure $ fmap (\(_, _, arr, _) -> arr) entry -- | @storeScalar stms se t@ returns a variable that binds a single element @@ -510,7 +503,7 @@ storeScalar :: Stms GPU -> SubExp -> Type -> ReduceM (Stms GPU, VName) storeScalar stms se t = do entry <- case se of - Var n -> IM.lookup (baseTag n) <$> gets stateMigrated + Var n -> gets $ IM.lookup (baseTag n) . stateMigrated _ -> pure Nothing case entry of Just (_, _, arr, _) -> pure (stms, arr) @@ -553,7 +546,7 @@ -- host, the name of a single element array containing its value. resolveName :: VName -> ReduceM VName resolveName n = do - entry <- IM.lookup (baseTag n) <$> gets stateMigrated + entry <- gets $ IM.lookup (baseTag n) . stateMigrated case entry of Nothing -> pure n Just (_, _, _, True) -> pure n diff --git a/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs b/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs --- a/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs +++ b/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs @@ -32,7 +32,9 @@ -- Børgesen (2022). module Futhark.Optimise.ReduceDeviceSyncs.MigrationTable ( -- * Analysis - analyseProg, + analyseFunDef, + analyseConsts, + hostOnlyFunDefs, -- * Types MigrationTable, @@ -56,7 +58,6 @@ import qualified Control.Monad.Trans.Reader as R import Control.Monad.Trans.State.Strict () import Control.Monad.Trans.State.Strict hiding (State) -import Control.Parallel.Strategies (parMap, rpar) import Data.Bifunctor (first, second) import Data.Foldable import qualified Data.IntMap.Strict as IM @@ -104,6 +105,9 @@ -- all such statements have been moved. newtype MigrationTable = MigrationTable (IM.IntMap MigrationStatus) +instance Semigroup MigrationTable where + MigrationTable a <> MigrationTable b = MigrationTable (a `IM.union` b) + -- | Where should the value bound by this name be computed? statusOf :: VName -> MigrationTable -> MigrationStatus statusOf n (MigrationTable mt) = @@ -141,10 +145,6 @@ usedOnHost :: VName -> MigrationTable -> Bool usedOnHost n mt = statusOf n mt /= MoveToDevice --- | Merges two migration tables that are assumed to be disjoint. -merge :: MigrationTable -> MigrationTable -> MigrationTable -merge (MigrationTable a) (MigrationTable b) = MigrationTable (a `IM.union` b) - -------------------------------------------------------------------------------- -- HOST-ONLY FUNCTION ANALYSIS -- -------------------------------------------------------------------------------- @@ -232,15 +232,6 @@ nameToId :: VName -> Id nameToId = baseTag - --- | Analyses a program to return a migration table that covers all its --- statements and variables. -analyseProg :: Prog GPU -> MigrationTable -analyseProg (Prog consts funs) = - let hof = hostOnlyFunDefs funs - mt = analyseConsts hof funs consts - mts = parMap rpar (analyseFunDef hof) funs - in foldl' merge mt mts -- | Analyses top-level constants. analyseConsts :: HostOnlyFuns -> [FunDef GPU] -> Stms GPU -> MigrationTable diff --git a/src/Futhark/Optimise/Simplify.hs b/src/Futhark/Optimise/Simplify.hs --- a/src/Futhark/Optimise/Simplify.hs +++ b/src/Futhark/Optimise/Simplify.hs @@ -39,7 +39,9 @@ Engine.HoistBlockers rep -> Prog rep -> PassM (Prog rep) -simplifyProg simpl rules blockers (Prog consts funs) = do +simplifyProg simpl rules blockers prog = do + let consts = progConsts prog + funs = progFuns prog (consts_vtable, consts') <- simplifyConsts (UT.usages $ foldMap freeIn funs) (mempty, informStms consts) @@ -51,7 +53,11 @@ (_, consts'') <- simplifyConsts funs_uses (mempty, consts') - pure $ Prog (fmap removeStmWisdom consts'') (fmap removeFunDefWisdom funs') + pure $ + prog + { progConsts = fmap removeStmWisdom consts'', + progFuns = fmap removeFunDefWisdom funs' + } where simplifyFun' consts_vtable = simplifySomething 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 @@ -320,7 +320,8 @@ | otherwise -> pure $ constant True -- infinite loop ForLoop _ it bound _ -> letSubExp "loop_nonempty" $ - BasicOp $ CmpOp (CmpSlt it) (intConst it 0) bound + BasicOp $ + CmpOp (CmpSlt it) (intConst it 0) bound protectIf :: MonadBuilder m => @@ -332,7 +333,8 @@ 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 + 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 @@ -351,7 +353,8 @@ 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 + If taken taken_body untaken_body $ + IfDec if_ts IfFallback protectIf _ _ _ stm = addStm stm @@ -386,7 +389,7 @@ let dims = map zeroIfContext $ shapeDims shape pure $ BasicOp $ Scratch et dims where - zeroIfContext (Var v) | v `elem` ctx_names = intConst Int32 0 + zeroIfContext (Var v) | v `elem` ctx_names = intConst Int64 0 zeroIfContext se = se -- | Statements that are not worth hoisting out of loops, because they @@ -529,13 +532,13 @@ UT.UsageTable -> Stm rep -> UT.UsageTable -expandUsage usageInStm vtable utable stm@(Let pat _ e) = +expandUsage usageInStm vtable utable stm@(Let pat aux e) = stmUsages <> utable where stmUsages = UT.expand (`ST.lookupAliases` vtable) (usageInStm stm <> usageThroughAliases) <> ( if any (`UT.isSize` utable) (patNames pat) - then UT.sizeUsages (freeIn e) + then UT.sizeUsages (freeIn (stmAuxCerts aux) <> freeIn e) else mempty ) usageThroughAliases = @@ -544,7 +547,8 @@ usageThroughBindeeAliases (name, aliases) = do uses <- UT.lookup name utable pure . mconcat $ - map (`UT.usage` (uses `UT.withoutU` UT.presentU)) $ namesToList aliases + map (`UT.usage` (uses `UT.withoutU` UT.presentU)) $ + namesToList aliases type BlockPred rep = ST.SymbolTable rep -> UT.UsageTable -> Stm rep -> Bool @@ -613,8 +617,10 @@ cheapExp (BasicOp UnOp {}) = True cheapExp (BasicOp CmpOp {}) = True cheapExp (BasicOp ConvOp {}) = True +cheapExp (BasicOp Assert {}) = True cheapExp (BasicOp Copy {}) = False cheapExp (BasicOp Replicate {}) = False +cheapExp (BasicOp Concat {}) = False cheapExp (BasicOp Manifest {}) = False cheapExp DoLoop {} = False cheapExp (If _ tbranch fbranch _) = @@ -624,9 +630,6 @@ cheapExp _ = True -- Used to be False, but -- let's try it out. -stmIs :: (Stm rep -> Bool) -> BlockPred rep -stmIs f _ _ = f - loopInvariantStm :: ASTRep rep => ST.SymbolTable rep -> Stm rep -> Bool loopInvariantStm vtable = all (`nameIn` ST.availableAtClosestLoop vtable) . namesToList . freeIn @@ -660,7 +663,7 @@ cond_loop_invariant = all (`nameIn` ST.availableAtClosestLoop vtable) $ namesToList $ freeIn cond - desirableToHoist stm = + desirableToHoist usage stm = is_alloc_fun stm || ( ST.loopDepth vtable > 0 && cond_loop_invariant @@ -670,6 +673,11 @@ -- asymptotics of the program. && all primType (patTypes (stmPat stm)) ) + || ( ifsort /= IfFallback + && any (`UT.isSize` usage) (patNames (stmPat stm)) + && all primType (patTypes (stmPat stm)) + ) + notDesirableToHoist _ usage stm = not $ desirableToHoist usage stm -- No matter what, we always want to hoist constants as much as -- possible. @@ -682,9 +690,6 @@ isNotHoistableBnd _ _ (Let _ _ (BasicOp (Index _ slice))) = null $ sliceDims slice -- - isNotHoistableBnd _ usage (Let pat _ _) - | any (`UT.isSize` usage) $ patNames pat = - False isNotHoistableBnd _ _ stm | is_alloc_fun stm = False isNotHoistableBnd _ _ _ = @@ -694,7 +699,7 @@ block = branch_blocker `orIf` ( (isNotSafe `orIf` isNotCheap `orIf` isNotHoistableBnd) - `andAlso` stmIs (not . desirableToHoist) + `andAlso` notDesirableToHoist ) `orIf` isConsuming @@ -830,21 +835,22 @@ ) seq_blocker <- asksEngineEnv $ blockHoistSeq . envHoistBlockers (loopres, loopstms, hoisted) <- - enterLoop . consumeMerge $ - bindMerge (zipWith withRes merge' (bodyResult loopbody)) . wrapbody $ - blockIf - ( hasFree boundnames `orIf` isConsumed - `orIf` seq_blocker - `orIf` notWorthHoisting - ) - (bodyStms loopbody) - $ do - let params_usages = - map - (\p -> if unique (paramDeclType p) then UT.consumedU else mempty) - params' - (res, uses) <- simplifyResult params_usages $ bodyResult loopbody - pure (res, uses <> isDoLoopResult res) + enterLoop . consumeMerge + $ bindMerge (zipWith withRes merge' (bodyResult loopbody)) . wrapbody + $ blockIf + ( hasFree boundnames + `orIf` isConsumed + `orIf` seq_blocker + `orIf` notWorthHoisting + ) + (bodyStms loopbody) + $ do + let params_usages = + map + (\p -> if unique (paramDeclType p) then UT.consumedU else mempty) + params' + (res, uses) <- simplifyResult params_usages $ bodyResult loopbody + pure (res, uses <> isDoLoopResult res) loopbody' <- constructBody loopstms loopres pure (DoLoop merge' form' loopbody', hoisted) where 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 @@ -72,7 +72,8 @@ -- simplifier applies bottom-up rules in a kind of deepest-first -- order. not (patElemName d `UT.isInResult` used) - || patElemName d `UT.isConsumed` used + || patElemName d + `UT.isConsumed` used -- Always OK to remove the copy if 'v' has no aliases and is never -- used again. || (v_is_fresh && v_not_used_again), @@ -104,7 +105,10 @@ Simplify $ certifying cs $ attributing attrs $ - letBind pat $ BasicOp $ SubExp $ Constant result + letBind pat $ + BasicOp $ + SubExp $ + Constant result where isConst (Constant v) = Just v isConst _ = Nothing @@ -117,10 +121,14 @@ attributing attrs $ case res of SubExpResult cs' se -> certifying (cs <> cs') $ - letBindNames (patNames pat) $ BasicOp $ SubExp se + letBindNames (patNames pat) $ + BasicOp $ + SubExp se IndexResult extra_cs idd' inds' -> certifying (cs <> extra_cs) $ - letBindNames (patNames 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 @@ -193,7 +201,9 @@ if oneIshInt t && zeroIshInt f && tcs == mempty && fcs == mempty then Simplify $ - letBind pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond + letBind pat $ + BasicOp $ + ConvOp (BToI (intValueType t)) cond else if zeroIshInt t && oneIshInt f then Simplify $ do @@ -219,7 +229,9 @@ matches x y || matches y x = Simplify $ certifying (stmAuxCerts aux <> xcs <> ycs) $ - letBind (Pat [pe]) $ BasicOp $ SubExp y + letBind (Pat [pe]) $ + BasicOp $ + SubExp y where z = patElemName pe matches (Var x) y @@ -256,13 +268,16 @@ namesFromList . concatMap (patNames . stmPat) $ bodyStms tb <> bodyStms fb invariant Constant {} = True - invariant (Var v) = not $ v `nameIn` bound_in_branches + invariant (Var v) = v `notNameIn` bound_in_branches branchInvariant (i, pe, t, (tse, fse)) -- Do both branches return the same value? | tse == fse = do certifying (resCerts tse <> resCerts fse) $ - letBindNames [patElemName pe] $ BasicOp $ SubExp $ resSubExp tse + letBindNames [patElemName pe] $ + BasicOp $ + SubExp $ + resSubExp tse hoisted i pe -- Do both branches return values that are free in the @@ -274,7 +289,8 @@ Prim _ <- patElemType pe = do bt <- expTypesFromPat $ Pat [pe] letBindNames [patElemName pe] - =<< ( If cond <$> resultBodyM [resSubExp tse] + =<< ( If cond + <$> resultBodyM [resSubExp tse] <*> resultBodyM [resSubExp fse] <*> pure (IfDec bt ifsort) ) @@ -305,7 +321,7 @@ removeDeadBranchResult :: BuilderOps rep => BottomUpRuleIf rep removeDeadBranchResult (_, used) pat _ (e1, tb, fb, IfDec rettype ifsort) | -- Only if there is no existential binding... - not $ any (`nameIn` foldMap freeIn (patElems pat)) (patNames pat), + all (`notNameIn` foldMap freeIn (patElems pat)) (patNames pat), -- Figure out which of the names in 'pat' are used... patused <- map (`UT.isUsedDirectly` used) $ patNames pat, -- If they are not all used, then this rule applies. @@ -357,7 +373,8 @@ lam' <- mkLambda (cert_params' ++ acc_params') $ - bodyBind $ (lambdaBody lam) {bodyResult = acc_res' <> nonacc_res'} + bodyBind $ + (lambdaBody lam) {bodyResult = acc_res' <> nonacc_res'} letBind (Pat (concat acc_pes' <> nonacc_pes')) $ WithAcc inputs' lam' where @@ -420,10 +437,10 @@ -- Eliminate unused accumulator results let get_rid_of = - map snd . filter getRidOf $ - zip + map snd . filter getRidOf + $ zip (chunks (map inputArrs inputs) acc_pes) - $ map paramName cert_params + $ map paramName cert_params -- Eliminate unused non-accumulator results let (nonacc_pes', nonacc_res') = 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 @@ -21,7 +21,6 @@ import Futhark.Optimise.Simplify.Rule import Futhark.Optimise.Simplify.Rules.Loop import Futhark.Optimise.Simplify.Rules.Simple -import Futhark.Util isCt1 :: SubExp -> Bool isCt1 (Constant v) = oneIsh v @@ -89,7 +88,9 @@ Just (xs', xs_cs) <- unzip <$> mapM (transposedBy perm) xs = Simplify $ do concat_rearrange <- certifying (x_cs <> mconcat xs_cs) $ - letExp "concat_rearrange" $ BasicOp $ Concat 0 (x' :| xs') new_d + letExp "concat_rearrange" $ + BasicOp $ + Concat 0 (x' :| xs') new_d letBind pat $ BasicOp $ Rearrange perm concat_rearrange where transposedBy perm1 v = @@ -103,7 +104,10 @@ simplifyConcat _ pat aux (Concat _ (x :| []) _) = Simplify $ -- Still need a copy because Concat produces a fresh array. - auxing aux $ letBind pat $ BasicOp $ Copy x + auxing aux $ + letBind pat $ + BasicOp $ + Copy x -- concat xs (concat ys zs) == concat xs ys zs simplifyConcat (vtable, _) pat (StmAux cs attrs _) (Concat i (x :| xs) new_d) | x' /= x || concat xs' /= xs = @@ -111,7 +115,8 @@ certifying (cs <> x_cs <> mconcat xs_cs) $ attributing attrs $ letBind pat $ - BasicOp $ Concat i (x' :| zs ++ concat xs') new_d + BasicOp $ + Concat i (x' :| zs ++ concat xs') new_d where (x' : zs, x_cs) = isConcat x (xs', xs_cs) = unzip $ map isConcat xs @@ -128,7 +133,8 @@ forSingleArray $ reverse $ foldl' fuseConcatArg mempty $ - map (toConcatArg vtable) $ x : xs, + map (toConcatArg vtable) $ + x : xs, length xs /= length ys = Simplify $ do elem_type <- lookupType x @@ -164,7 +170,9 @@ Simplify $ do e' <- toSubExp "update_elem" e auxing aux . certifying cs $ - letBind pat $ BasicOp $ Update safety src (Slice [DimFix i]) e' + 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 = @@ -189,7 +197,8 @@ Var v | not $ null $ sliceDims is -> do v_reshaped <- letExp (baseString v ++ "_reshaped") $ - BasicOp $ Reshape (map DimNew $ arrayDims dest_t) v + 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 safety1 dest1 is1 (Var v1)) @@ -224,7 +233,8 @@ not_p_and_eq_x_z <- letSubExp "p_and_eq_x_y" $ BasicOp $ BinOp LogAnd not_p eq_x_z letBind pat $ - BasicOp $ BinOp LogOr p_and_eq_x_y not_p_and_eq_x_z + BasicOp $ + BinOp LogOr p_and_eq_x_y not_p_and_eq_x_z simplifyWith _ _ = Nothing @@ -261,7 +271,9 @@ Just _ -> certifying idd_cs $ auxing aux $ - letBind pat $ BasicOp $ Index idd2 slice + letBind pat $ + BasicOp $ + Index idd2 slice Nothing -> do -- Linearise indices and map to old index space. oldshape <- arrayDims <$> lookupType idd2 @@ -273,13 +285,19 @@ new_inds' <- mapM (toSubExp "new_index") new_inds certifying idd_cs . auxing aux $ - letBind pat $ BasicOp $ Index idd2 $ Slice $ map DimFix new_inds' + 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 + letBind pat $ + BasicOp $ + Iota n x s it -- Handle identity permutation. ruleBasicOp _ pat _ (Rearrange perm v) | sort perm == perm = @@ -288,7 +306,9 @@ | 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 + 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 @@ -296,7 +316,9 @@ rearrange_rotate <- letExp "rearrange_rotate" $ BasicOp $ Rotate offsets' v3 certifying (v_cs <> v2_cs) $ auxing aux $ - letBind pat $ BasicOp $ Rearrange (perm `rearrangeCompose` perm3) rearrange_rotate + letBind pat $ + BasicOp $ + Rearrange (perm `rearrangeCompose` perm3) rearrange_rotate -- Rearranging a replicate where the outer dimension is left untouched. ruleBasicOp vtable pat aux (Rearrange perm v1) @@ -310,7 +332,8 @@ auxing aux $ do v <- letSubExp "rearrange_replicate" $ - BasicOp $ Rearrange (map (subtract num_dims) rest_perm) v2 + BasicOp $ + Rearrange (map (subtract num_dims) rest_perm) v2 letBind pat $ BasicOp $ Replicate dims v -- A zero-rotation is identity. @@ -325,7 +348,9 @@ rotate_rearrange <- auxing aux $ letExp "rotate_rearrange" $ BasicOp $ Rearrange perm v3 certifying (v_cs <> v2_cs) $ - letBind pat $ BasicOp $ Rotate offsets' rotate_rearrange + letBind pat $ + BasicOp $ + Rotate offsets' rotate_rearrange -- Combining Rotates. ruleBasicOp vtable pat aux (Rotate offsets1 v) @@ -333,28 +358,12 @@ offsets <- zipWithM add offsets1 offsets2 certifying v_cs $ auxing aux $ - letBind pat $ BasicOp $ Rotate offsets v2 + letBind pat $ + BasicOp $ + Rotate offsets v2 where add x y = letSubExp "offset" $ BasicOp $ BinOp (Add Int64 OverflowWrap) x y --- If we see an Update with a scalar where the value to be written is --- the result of indexing some other array, then we convert it into an --- 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 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, - not $ ST.aliases arr_x arr_y vtable, - 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 $ 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 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) | Constant (IntValue (Int64Value 0)) <- x, @@ -381,7 +390,10 @@ cs' <- filter (`notElem` v_cs) cs, cs' /= cs = Simplify . certifying (Certs cs') $ - letBind pat $ BasicOp $ SubExp $ Var v + letBind pat $ + BasicOp $ + SubExp $ + Var v -- Remove UpdateAccs that contribute the neutral value, which is -- always a no-op. ruleBasicOp vtable pat aux (UpdateAcc acc _ vs) @@ -396,7 +408,9 @@ | Just (Copy v2, cs) <- ST.lookupBasicOp v1 vtable, ST.available v2 vtable = Simplify . auxing aux . certifying cs $ - letBind pat $ BasicOp $ Manifest perm v2 + letBind pat $ + BasicOp $ + Manifest perm v2 ruleBasicOp _ _ _ _ = Skip 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 @@ -65,7 +65,8 @@ accs isEmpty <- newVName "fold_input_is_empty" letBindNames [isEmpty] $ - BasicOp $ CmpOp (CmpEq int64) inputsize (intConst Int64 0) + BasicOp $ + CmpOp (CmpEq int64) inputsize (intConst Int64 0) letBind pat =<< ( If (Var isEmpty) <$> resultBodyM accs @@ -103,7 +104,8 @@ mergeexp isEmpty <- newVName "bound_is_zero" letBindNames [isEmpty] $ - BasicOp $ CmpOp (CmpSlt it) bound (intConst it 0) + BasicOp $ + CmpOp (CmpSlt it) bound (intConst it 0) letBind pat =<< ( If (Var isEmpty) @@ -183,7 +185,8 @@ properFloatSize t = Just $ letSubExp "converted_size" $ - BasicOp $ ConvOp (SIToFP it t) size + BasicOp $ + ConvOp (SIToFP it t) size determineKnownBindings :: VarLookup rep -> 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 @@ -88,10 +88,12 @@ `add` primExpFromSubExp (IntType to_it) i_offset' i_stride'' <- letSubExp "iota_offset" $ - BasicOp $ BinOp (Mul Int64 OverflowWrap) s i_stride' + BasicOp $ + BinOp (Mul Int64 OverflowWrap) s i_stride' fmap (SubExpResult cs) $ letSubExp "slice_iota" $ - BasicOp $ Iota i_n i_offset'' i_stride'' to_it + BasicOp $ + Iota i_n i_offset'' i_stride'' to_it -- A rotate cannot be simplified away if we are slicing a rotated dimension. Just (Rotate offsets a, cs) @@ -195,7 +197,8 @@ (thisres, thisstms) <- collectStms $ do i' <- letSubExp "index_concat_i" $ BasicOp $ BinOp (Sub Int64 OverflowWrap) i start letSubExp "index_concat" . BasicOp . Index x' $ - Slice $ ibef ++ DimFix i' : iaft + Slice $ + ibef ++ DimFix i' : iaft thisbody <- mkBodyM thisstms [subExpRes thisres] (altres, altstms) <- collectStms $ mkBranch xs_and_starts' altbody <- mkBodyM altstms [subExpRes altres] 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 @@ -37,13 +37,16 @@ resIsNecessary ((v, _), _) = usedAfterLoop v - || paramName v `nameIn` necessaryForReturned + || paramName v + `nameIn` necessaryForReturned || referencedInPat v || referencedInForm v (keep_valpart, discard_valpart) = partition (resIsNecessary . snd) $ - zip (patElems pat) $ zip merge $ bodyResult body + zip (patElems pat) $ + zip merge $ + bodyResult body (keep_valpatelems, keep_val) = unzip keep_valpart (_discard_valpatelems, discard_val) = unzip discard_valpart @@ -119,7 +122,7 @@ (invariant, explpat', merge', resExps) | isInvariant, -- Also do not remove the condition in a while-loop. - not $ paramName mergeParam `nameIn` freeIn form = + paramName mergeParam `notNameIn` freeIn form = let (stm, explpat'') = removeFromResult (mergeParam, mergeInit) explpat' in ( maybe id (:) stm $ (paramIdent mergeParam, mergeInit) : invariant, @@ -163,8 +166,8 @@ namesToList $ freeIn mergeParam `namesSubtract` oneName (paramName mergeParam) invariantOrNotMergeParam namesOfInvariant name = - not (name `nameIn` namesOfMergeParams) - || name `nameIn` namesOfInvariant + (name `notNameIn` namesOfMergeParams) + || (name `nameIn` namesOfInvariant) simplifyClosedFormLoop :: BuilderOps rep => TopDownRuleDoLoop rep simplifyClosedFormLoop _ pat _ (val, ForLoop i it bound [], body) = @@ -216,7 +219,7 @@ | not $ any ((i `nameIn`) . freeIn) x_stms, DimFix (Var j) : slice' <- slice, j == i, - not $ i `nameIn` freeIn slice -> do + i `notNameIn` freeIn slice -> do addStms x_stms w <- arraySize 0 <$> lookupType arr' for_in_partial <- 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 @@ -10,8 +10,10 @@ import Control.Monad import Data.List (isSuffixOf) +import qualified Data.List.NonEmpty as NE import Futhark.Analysis.PrimExp.Convert import Futhark.IR +import Futhark.Util (focusNth) -- | A function that, given a variable name, returns its definition. type VarLookup rep = VName -> Maybe (Exp rep, Certs) @@ -300,6 +302,17 @@ Just (Iota n offset stride it, v_cs) simplifyReshapeIota _ _ _ = Nothing +simplifyReshapeConcat :: SimpleRule rep +simplifyReshapeConcat defOf seType (Reshape newshape v) = do + (BasicOp (Concat d arrs _), v_cs) <- defOf v + (bef, w', aft) <- focusNth d =<< shapeCoercion newshape + (arr_bef, _, arr_aft) <- + focusNth d <=< fmap arrayDims $ seType $ Var $ NE.head arrs + guard $ arr_bef == bef + guard $ arr_aft == aft + Just (Concat d arrs w', v_cs) +simplifyReshapeConcat _ _ _ = Nothing + reshapeSlice :: [DimIndex d] -> [d] -> [DimIndex d] reshapeSlice (DimFix i : slice') scs = DimFix i : reshapeSlice slice' scs @@ -369,6 +382,7 @@ simplifyReshapeScratch, simplifyReshapeReplicate, simplifyReshapeIota, + simplifyReshapeConcat, simplifyReshapeIndex, simplifyUpdateReshape, improveReshape 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 @@ -104,7 +104,8 @@ (sinking_here, sinking') = M.partitionWithKey sunkHere sinking sunk_stms = stmsFromList $ M.elems sinking_here sunkHere v stm = - v `nameIn` free_in_stms + v + `nameIn` free_in_stms && all (`ST.available` vtable) (namesToList (freeIn stm)) sunk = namesFromList $ foldMap (patNames . stmPat) sunk_stms @@ -120,7 +121,7 @@ let stms' = foldr (inline i) (bodyStms body0) loop_vars body1 = body0 {bodyStms = stms'} (body2, sunk) = optimiseBody onOp vtable' sinking body1 - notSunk (x, _) = not $ paramName x `nameIn` sunk + notSunk (x, _) = paramName x `notNameIn` sunk loop_vars' = filter notSunk loop_vars form' = ForLoop i it bound loop_vars' body3 = body2 {bodyStms = SQ.drop (length loop_vars') (bodyStms body2)} @@ -279,7 +280,9 @@ pure $ fst $ optimiseStms onOp mempty mempty consts $ - namesFromList $ M.keys $ scopeOf consts + namesFromList $ + M.keys $ + scopeOf consts -- | Sinking in GPU kernels. sinkGPU :: Pass GPU GPU 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 @@ -148,7 +148,7 @@ Just (w, arrs, form) <- tileable stm_to_tile, inputs <- map (is1DTileable gtid variance) arrs, not $ null $ tiledInputs inputs, - not $ gtid `nameIn` branch_variant, + gtid `notNameIn` branch_variant, (prestms', poststms') <- preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms), used <- freeIn stm_to_tile <> freeIn poststms' <> freeIn stms_res = @@ -180,14 +180,14 @@ merge_params = map fst merge maybe_tiled <- - localScope (M.insert i (IndexName it) $ scopeOfFParams merge_params) $ - tileInBody + localScope (M.insert i (IndexName it) $ scopeOfFParams merge_params) + $ tileInBody branch_variant' variance initial_lvl initial_space (map paramType merge_params) - $ mkBody (bodyStms loopbody) (bodyResult loopbody) + $ mkBody (bodyStms loopbody) (bodyResult loopbody) case maybe_tiled of Nothing -> next @@ -235,7 +235,8 @@ used stm = any (`nameIn` used_in_stm_variant) $ - patNames $ stmPat stm + patNames $ + stmPat stm (prelude_used, prelude_not_used) = Seq.partition used prelude @@ -268,7 +269,7 @@ invariantTo names stm = case patNames (stmPat stm) of [] -> True -- Does not matter. - v : _ -> not $ any (`nameIn` names) $ namesToList $ M.findWithDefault mempty v variance + v : _ -> all (`notNameIn` names) (namesToList $ M.findWithDefault mempty v variance) consumed v = v `nameIn` consumed_in_prestms consumedStm stm = any consumed (patNames (stmPat stm)) @@ -276,11 +277,12 @@ later_consumed = namesFromList $ concatMap (patNames . stmPat) $ - stmsToList $ Seq.filter consumedStm prestms + stmsToList $ + Seq.filter consumedStm prestms groupInvariant stm = invariantTo private stm - && not (any (`nameIn` later_consumed) (patNames (stmPat stm))) + && all (`notNameIn` later_consumed) (patNames (stmPat stm)) && invariantTo later_consumed stm (invariant_prestms, variant_prestms) = Seq.partition groupInvariant prestms @@ -301,7 +303,8 @@ must_be_inlined = namesFromList $ concatMap (patNames . stmPat) $ - stmsToList $ Seq.filter mustBeInlined variant_prestms + stmsToList $ + Seq.filter mustBeInlined variant_prestms recompute stm = any (`nameIn` must_be_inlined) (patNames (stmPat stm)) || not (invariantTo must_be_inlined stm) @@ -519,7 +522,9 @@ letSubExp "slice_offset" =<< toExp (pe64 tile_id * pe64 full_tile_size) let slice = DimSlice slice_offset this_tile_size (intConst Int64 1) letExp "untiled_slice" $ - BasicOp $ Index arr $ fullSlice arr_t [slice] + BasicOp $ + Index arr $ + fullSlice arr_t [slice] -- | Statements that we insert directly into every thread-private -- SegMaps. This is for things that cannot efficiently be computed @@ -868,7 +873,8 @@ -- the whole tiles. residual_input <- letSubExp "residual_input" $ - BasicOp $ BinOp (SRem Int64 Unsafe) w tile_size + BasicOp $ + BinOp (SRem Int64 Unsafe) w tile_size letTupExp "acc_after_residual" =<< eIf @@ -932,12 +938,14 @@ else do group_size <- letSubExp "computed_group_size" $ - BasicOp $ BinOp (SMin Int64) (unCount (segGroupSize initial_lvl)) kdim + BasicOp $ + BinOp (SMin Int64) (unCount (segGroupSize initial_lvl)) kdim -- How many groups we need to exhaust the innermost dimension. ldim <- letSubExp "ldim" $ - BasicOp $ BinOp (SDivUp Int64 Unsafe) kdim group_size + BasicOp $ + BinOp (SDivUp Int64 Unsafe) kdim group_size num_groups <- letSubExp "computed_num_groups" @@ -965,7 +973,8 @@ tilingTileShape = Shape [tile_size], tilingNumWholeTiles = letSubExp "num_whole_tiles" $ - BasicOp $ BinOp (SQuot Int64 Unsafe) w tile_size, + BasicOp $ + BinOp (SQuot Int64 Unsafe) w tile_size, tilingLevel = lvl, tilingSpace = space } @@ -980,10 +989,10 @@ j : i : _ <- Just $ reverse dims let variant_to = M.findWithDefault mempty arr variance branch_invariant = not $ nameIn j branch_variant || nameIn i branch_variant - if branch_invariant && i `nameIn` variant_to && not (j `nameIn` variant_to) + if branch_invariant && i `nameIn` variant_to && j `notNameIn` variant_to then Just $ InputTile [0, 1] arr else - if branch_invariant && j `nameIn` variant_to && not (i `nameIn` variant_to) + if branch_invariant && j `nameIn` variant_to && i `notNameIn` variant_to then Just $ InputTile [1, 0] arr else Just $ InputDontTile arr @@ -1118,7 +1127,9 @@ tile_t <- lookupType tile let idx = DimFix $ Var $ head $ rearrangeShape perm [ltid_x, ltid_y] letExp "tile" $ - BasicOp $ Index tile $ sliceAt tile_t (head perm) [idx] + BasicOp $ + Index tile $ + sliceAt tile_t (head perm) [idx] tiles' <- mapM sliceTile tiles @@ -1151,7 +1162,8 @@ -- the whole tiles. residual_input <- letSubExp "residual_input" $ - BasicOp $ BinOp (SRem Int64 Unsafe) w tile_size + BasicOp $ + BinOp (SRem Int64 Unsafe) w tile_size letTupExp "acc_after_residual" =<< eIf @@ -1219,10 +1231,12 @@ num_groups_x <- letSubExp "num_groups_x" $ - BasicOp $ BinOp (SDivUp Int64 Unsafe) kdim_x tile_size + BasicOp $ + BinOp (SDivUp Int64 Unsafe) kdim_x tile_size num_groups_y <- letSubExp "num_groups_y" $ - BasicOp $ BinOp (SDivUp Int64 Unsafe) kdim_y tile_size + BasicOp $ + BinOp (SDivUp Int64 Unsafe) kdim_y tile_size num_groups <- letSubExp "num_groups_top" @@ -1254,7 +1268,8 @@ tilingTileShape = Shape [tile_size, tile_size], tilingNumWholeTiles = letSubExp "num_whole_tiles" $ - BasicOp $ BinOp (SQuot Int64 Unsafe) w tile_size, + BasicOp $ + BinOp (SQuot Int64 Unsafe) w tile_size, tilingLevel = lvl, tilingSpace = space } 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 @@ -68,7 +68,8 @@ loop_body <- runBodyBuilder . inScopeOf loop_form . localScope (scopeOfFParams loop_inits) $ - body i $ map paramName loop_inits + body i $ + map paramName loop_inits letTupExp "loop" $ DoLoop (zip loop_inits $ map Var merge) loop_form loop_body @@ -101,7 +102,10 @@ let ret (SubExpRes cs se) = Returns manifest cs se letTupExp desc $ - Op . SegOp $ SegMap lvl space ts $ KernelBody () stms' $ map ret res' + Op . SegOp $ + SegMap lvl space ts $ + KernelBody () stms' $ + map ret res' segMap2D :: String -> -- desc @@ -125,7 +129,10 @@ let ret (SubExpRes cs se) = Returns manifest cs se letTupExp desc <=< renameExp $ - Op . SegOp $ SegMap lvl segspace ts $ KernelBody () stms $ map ret res + Op . SegOp $ + SegMap lvl segspace ts $ + KernelBody () stms $ + map ret res segMap3D :: String -> -- desc @@ -150,7 +157,10 @@ let ret (SubExpRes cs se) = Returns manifest cs se letTupExp desc <=< renameExp $ - Op . SegOp $ SegMap lvl segspace ts $ KernelBody () stms $ map ret res + Op . SegOp $ + SegMap lvl segspace ts $ + KernelBody () stms $ + map ret res segScatter2D :: String -> 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 @@ -140,7 +140,8 @@ stms <- runBuilder_ $ FOT.transformSOAC pat soac fmap concat $ localScope (scopeOf stms) $ - mapM (optimiseStm (onMCOp stage)) $ stmsToList stms + mapM (optimiseStm (onMCOp stage)) $ + stmsToList stms | otherwise = -- Still sequentialise whatever's inside. pure <$> (Let pat aux . Op . MC.OtherOp <$> mapSOACM optimise soac) @@ -161,7 +162,8 @@ stms <- runBuilder_ $ FOT.transformSOAC pat soac fmap concat $ localScope (scopeOf stms) $ - mapM (optimiseStm (onHostOp stage)) $ stmsToList stms + mapM (optimiseStm (onHostOp stage)) $ + stmsToList stms | otherwise = -- Still sequentialise whatever's inside. pure <$> (Let pat aux . Op . GPU.OtherOp <$> mapSOACM optimise soac) diff --git a/src/Futhark/Pass.hs b/src/Futhark/Pass.hs --- a/src/Futhark/Pass.hs +++ b/src/Futhark/Pass.hs @@ -7,8 +7,6 @@ module Futhark.Pass ( PassM, runPassM, - liftEither, - liftEitherM, Pass (..), passLongOption, parPass, @@ -21,8 +19,6 @@ import Control.Monad.Writer.Strict import Control.Parallel.Strategies import Data.Char -import Data.Either -import Futhark.Error import Futhark.IR import Futhark.MonadFreshNames import Futhark.Util.Log @@ -47,17 +43,6 @@ m (a, Log) runPassM (PassM m) = modifyNameSource $ runState (runWriterT m) --- | Turn an 'Either' computation into a 'PassM'. If the 'Either' is --- 'Left', the result is a 'CompilerBug'. -liftEither :: Show err => Either err a -> PassM a -liftEither (Left e) = compilerBugS $ show e -liftEither (Right v) = pure v - --- | Turn an 'Either' monadic computation into a 'PassM'. If the 'Either' is --- 'Left', the result is an exception. -liftEitherM :: Show err => PassM (Either err a) -> PassM a -liftEitherM m = liftEither =<< m - -- | A compiler pass transforming a 'Prog' of a given rep to a 'Prog' -- of another rep. data Pass fromrep torep = Pass @@ -105,10 +90,10 @@ (Stms torep -> FunDef fromrep -> PassM (FunDef torep)) -> Prog fromrep -> PassM (Prog torep) -intraproceduralTransformationWithConsts ct ft (Prog consts funs) = do - consts' <- ct consts - funs' <- parPass (ft consts') funs - pure $ Prog consts' funs' +intraproceduralTransformationWithConsts ct ft prog = do + consts' <- ct (progConsts prog) + funs' <- parPass (ft consts') (progFuns prog) + pure $ prog {progConsts = consts', progFuns = funs'} -- | Like 'intraproceduralTransformationWithConsts', but do not change -- the top-level constants, and simply pass along their 'Scope'. 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 @@ -36,10 +36,13 @@ expandAllocations :: Pass GPUMem GPUMem expandAllocations = Pass "expand allocations" "Expand allocations" $ - \(Prog consts funs) -> do + \prog -> do consts' <- - modifyNameSource $ limitationOnLeft . runStateT (runReaderT (transformStms consts) mempty) - Prog consts' <$> mapM (transformFunDef $ scopeOf consts') funs + modifyNameSource $ + limitationOnLeft + . runStateT (runReaderT (transformStms (progConsts prog)) mempty) + funs' <- mapM (transformFunDef $ scopeOf consts') (progFuns prog) + pure $ prog {progConsts = consts', progFuns = funs'} -- Cannot use intraproceduralTransformation because it might create -- duplicate size keys (which are not fixed by renamer, and size @@ -64,7 +67,8 @@ m = localScope scope $ inScopeOf fundec $ - transformBody $ funDefBody fundec + transformBody $ + funDefBody fundec transformBody :: Body GPUMem -> ExpandM (Body GPUMem) transformBody (Body () stms res) = Body () <$> transformStms stms <*> pure res @@ -162,14 +166,15 @@ lvl = SegThread (Count $ intConst Int64 0) (Count $ intConst Int64 0) SegNoVirt (op_lam', lam_allocs) = extractLambdaAllocations (lvl, [0]) bound_outside mempty op_lam - variantAlloc (_, Var v, _) = not $ v `nameIn` bound_outside + variantAlloc (_, Var v, _) = v `notNameIn` bound_outside variantAlloc _ = False (variant_allocs, invariant_allocs) = M.partition variantAlloc lam_allocs case M.elems variant_allocs of (_, v, _) : _ -> throwError $ - "Cannot handle un-sliceable allocation size: " ++ pretty v + "Cannot handle un-sliceable allocation size: " + ++ pretty v ++ "\nLikely cause: irregular nested operations inside accumulator update operator." [] -> pure () @@ -200,17 +205,18 @@ (kbody', kbody_allocs) = extractKernelBodyAllocations user bound_outside bound_in_kernel kbody (ops', ops_allocs) = unzip $ map (extractLambdaAllocations user bound_outside mempty) ops - variantAlloc (_, Var v, _) = not $ v `nameIn` bound_outside + variantAlloc (_, Var v, _) = v `notNameIn` bound_outside variantAlloc _ = False (variant_allocs, invariant_allocs) = M.partition variantAlloc $ kbody_allocs <> mconcat ops_allocs - badVariant (_, Var v, _) = not $ v `nameIn` bound_in_kernel + badVariant (_, Var v, _) = v `notNameIn` bound_in_kernel badVariant _ = False case find badVariant $ M.elems variant_allocs of Just v -> throwError $ - "Cannot handle un-sliceable allocation size: " ++ pretty v + "Cannot handle un-sliceable allocation size: " + ++ pretty v ++ "\nLikely cause: irregular nested operations inside parallel constructs." Nothing -> pure () @@ -350,7 +356,8 @@ runWriter $ fmap catMaybes $ mapM (extractStmAllocations user bound_outside bound_kernel') $ - stmsToList $ get_stms body + stmsToList $ + get_stms body in (set_stms (stmsFromList stms) body, allocs) expandable, notScalar :: Space -> Bool @@ -445,7 +452,8 @@ permuted_ixfun = IxFun.permute root_ixfun perm offset_ixfun = IxFun.slice permuted_ixfun $ - Slice $ 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 @@ -809,7 +817,8 @@ params <- replicateM num_sizes $ newParam "x" (Prim int64) (zs, stms) <- localScope (scopeOfLParams params <> scopeOfLParams [flat_gtid_lparam]) - $ collectStms $ do + $ collectStms + $ do -- Even though this SegRed is one-dimensional, we need to -- provide indexes corresponding to the original potentially -- multi-dimensional construct. @@ -836,7 +845,8 @@ thread_space_iota <- letExp "thread_space_iota" $ - BasicOp $ Iota w (intConst Int64 0) (intConst Int64 1) Int64 + BasicOp $ + Iota w (intConst Int64 0) (intConst Int64 1) Int64 let red_op = SegBinOp Commutative @@ -845,12 +855,14 @@ mempty lvl <- segThread "segred" - addStms =<< mapM renameStm + addStms + =<< mapM renameStm =<< nonSegRed lvl pat w [red_op] size_lam' [thread_space_iota] size_sums <- forM (patNames pat) $ \threads_max -> letExp "size_sum" $ - BasicOp $ BinOp (Mul Int64 OverflowUndef) (Var threads_max) num_threads + BasicOp $ + BinOp (Mul Int64 OverflowUndef) (Var threads_max) num_threads pure (patNames pat, 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 @@ -178,7 +178,8 @@ elm_size_i64 = elemSize t pure $ BinOpExp (SMax Int64) (ValueExp $ IntValue $ Int64Value 0) $ - untyped $ dim_prod_i64 * elm_size_i64 + untyped $ + dim_prod_i64 * elm_size_i64 arraySizeInBytes :: MonadBuilder m => ChunkMap -> Type -> m SubExp arraySizeInBytes chunkmap = letSubExp "bytes" <=< toExp <=< arraySizeInBytesExpM chunkmap @@ -628,7 +629,10 @@ explicitAllocationsInStmsGeneric handleOp hints stms = do scope <- askScope runAllocM handleOp hints $ - localScope scope $ collectStms_ $ allocInStms stms $ pure () + localScope scope $ + collectStms_ $ + allocInStms stms $ + pure () memoryInDeclExtType :: Int -> [DeclExtType] -> [FunReturns] memoryInDeclExtType k dets = evalState (mapM addMem dets) 0 @@ -639,7 +643,9 @@ i <- get <* modify (+ 1) let shape' = fmap shift shape pure . MemArray pt shape' u . ReturnsNewBlock DefaultSpace i $ - IxFun.iota $ map convert $ shapeDims shape' + IxFun.iota $ + map convert $ + shapeDims shape' addMem (Acc acc ispace ts u) = pure $ MemAcc acc ispace ts u convert (Ext i) = le64 $ Ext i @@ -851,7 +857,9 @@ mkP attrs p pt shape u mem ixfun is = Param attrs p . MemArray pt shape u . ArrayIn mem . IxFun.slice ixfun $ - fmap pe64 $ Slice $ is ++ map sliceDim (shapeDims shape) + fmap pe64 $ + Slice $ + is ++ map sliceDim (shapeDims shape) onXParam _ (Param attrs p (Prim t)) _ = pure $ Param attrs p (MemPrim t) @@ -962,7 +970,9 @@ shape' = fmap (adjustExt num_new_ctx) shape bodyret = MemArray pt shape' u . ReturnsNewBlock space' k $ - IxFun.iota $ map convert $ shapeDims shape' + IxFun.iota $ + map convert $ + shapeDims shape' in bodyret inspect _ _ (Acc acc ispace ts u) _ = MemAcc acc ispace ts u inspect _ _ (Prim pt) _ = MemPrim pt @@ -1105,7 +1115,8 @@ fbody <- resultBodyM [intConst Int64 0] size' <- letSubExp "hoisted_alloc_size" $ - If taken tbody fbody $ IfDec [MemPrim int64] IfFallback + If taken tbody fbody $ + IfDec [MemPrim int64] IfFallback letBind pat $ Op $ Alloc size' space protectOp _ _ _ = Nothing 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 @@ -161,9 +161,11 @@ nilSlice d = DimSlice 0 d 0 in Hint ( IxFun.slice (IxFun.iota dims) $ - fullSliceNum dims $ map nilSlice seg_dims + fullSliceNum dims $ + map nilSlice seg_dims ) - $ ScalarSpace (arrayDims t) $ elemType t + $ ScalarSpace (arrayDims t) + $ elemType t else NoHint where private (Returns ResultPrivate _ _) = True 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 @@ -31,7 +31,8 @@ AllocM fromrep torep (Lambda torep) allocInLambda params body = mkLambda params . allocInStms (bodyStms body) $ - pure $ bodyResult body + pure $ + bodyResult body allocInBinOpParams :: Allocable fromrep torep inner => @@ -48,7 +49,9 @@ Array pt shape u -> do twice_num_threads <- letSubExp "twice_num_threads" $ - BasicOp $ BinOp (Mul Int64 OverflowUndef) num_threads $ intConst Int64 2 + BasicOp $ + BinOp (Mul Int64 OverflowUndef) num_threads $ + intConst Int64 2 let t = paramType x `arrayOfRow` twice_num_threads mem <- allocForArray t DefaultSpace -- XXX: this iota ixfun is a bit inefficient; leading to 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 @@ -194,10 +194,14 @@ } transformProg :: Prog SOACS -> PassM (Prog GPU) -transformProg (Prog consts funs) = do - consts' <- runDistribM $ transformStms mempty $ stmsToList consts - funs' <- mapM (transformFunDef $ scopeOf consts') funs - pure $ Prog consts' funs' +transformProg prog = do + consts' <- runDistribM $ transformStms mempty $ stmsToList $ progConsts prog + funs' <- mapM (transformFunDef $ scopeOf consts') $ progFuns prog + pure $ + prog + { progConsts = consts', + progFuns = funs' + } -- In order to generate more stable threshold names, we keep track of -- the numbers used for thresholds separately from the ordinary name @@ -286,7 +290,8 @@ unbalancedStm bound (WithAcc _ lam) = unbalancedBody bound (lambdaBody lam) unbalancedStm bound (If cond tbranch fbranch _) = - cond `subExpBound` bound + cond + `subExpBound` bound && (unbalancedBody bound tbranch || unbalancedBody bound fbranch) unbalancedStm _ (BasicOp _) = False @@ -338,7 +343,8 @@ let alt_body = mkBody alt_stms $ varsRes $ patNames alts_pat letBind pat $ - If cond alt alt_body $ IfDec (staticShapes (patTypes pat)) IfEquiv + If cond alt alt_body $ + IfDec (staticShapes (patTypes pat)) IfEquiv transformLambda :: KernelPath -> Lambda SOACS -> DistribM (Lambda GPU) transformLambda path (Lambda params body ret) = @@ -432,7 +438,8 @@ =<< (mkBody <$> paralleliseInner path' <*> pure (varsRes (patNames pat))) if not (lambdaContainsParallelism map_lam) - || "sequential_inner" `inAttrs` stmAuxAttrs aux + || "sequential_inner" + `inAttrs` stmAuxAttrs aux then paralleliseOuter else do ((outer_suff, outer_suff_key), suff_stms) <- @@ -647,7 +654,8 @@ | WithAcc _ withacc_lam <- stmExp stm = bodyInterest (lambdaBody withacc_lam) | Op (Screma _ _ form@(ScremaForm _ _ lam')) <- stmExp stm = - 1 + bodyInterest (lambdaBody lam') + 1 + + bodyInterest (lambdaBody lam') + -- Give this a bigger score if it's a redomap, as these -- are often tileable and thus benefit more from @@ -710,14 +718,18 @@ mayExploitOuter :: Attrs -> Bool mayExploitOuter attrs = not $ - AttrComp "incremental_flattening" ["no_outer"] `inAttrs` attrs - || AttrComp "incremental_flattening" ["only_inner"] `inAttrs` attrs + AttrComp "incremental_flattening" ["no_outer"] + `inAttrs` attrs + || AttrComp "incremental_flattening" ["only_inner"] + `inAttrs` attrs mayExploitIntra :: Attrs -> Bool mayExploitIntra attrs = not $ - AttrComp "incremental_flattening" ["no_intra"] `inAttrs` attrs - || AttrComp "incremental_flattening" ["only_inner"] `inAttrs` attrs + AttrComp "incremental_flattening" ["no_intra"] + `inAttrs` attrs + || AttrComp "incremental_flattening" ["only_inner"] + `inAttrs` attrs -- The minimum amount of inner parallelism we require (by default) in -- intra-group versions. Less than this is usually pointless on a GPU @@ -755,8 +767,10 @@ | Just m <- mkSeqAlts -> do (outer_suff, outer_suff_key, outer_suff_stms, seq_body) <- m par_body <- - renameBody =<< mkBody - <$> mk_par_stms ((outer_suff_key, False) : path) <*> pure res + renameBody + =<< mkBody + <$> mk_par_stms ((outer_suff_key, False) : path) + <*> pure res (outer_suff_stms <>) <$> kernelAlternatives pat par_body [(outer_suff, seq_body)] -- | otherwise -> do @@ -778,8 +792,10 @@ checkSuffIntraPar path intra' par_body <- - renameBody =<< mkBody - <$> mk_par_stms ((intra_suff_key, False) : path) <*> pure res + renameBody + =<< mkBody + <$> mk_par_stms ((intra_suff_key, False) : path) + <*> pure res (intra_suff_stms <>) <$> kernelAlternatives pat par_body [(intra_ok, group_par_body)] @@ -790,13 +806,14 @@ checkSuffIntraPar ((outer_suff_key, False) : path) intra' par_body <- - renameBody =<< mkBody - <$> mk_par_stms - ( [ (outer_suff_key, False), - (intra_suff_key, False) - ] - ++ path - ) + renameBody + =<< mkBody + <$> mk_par_stms + ( [ (outer_suff_key, False), + (intra_suff_key, False) + ] + ++ path + ) <*> pure res ((outer_suff_stms <> intra_suff_stms) <>) @@ -815,8 +832,10 @@ mayExploitOuter attrs = Just $ do ((outer_suff, outer_suff_key), outer_suff_stms) <- checkSuffOuterPar seq_body <- - renameBody =<< mkBody - <$> mk_seq_stms ((outer_suff_key, True) : path) <*> pure res + renameBody + =<< mkBody + <$> mk_seq_stms ((outer_suff_key, True) : path) + <*> pure res pure (outer_suff, outer_suff_key, outer_suff_stms, seq_body) | otherwise = Nothing @@ -914,7 +933,8 @@ -- order instead. let lam_res' = rearrangeShape (rearrangeInverse perm) $ - bodyResult $ lambdaBody lam' + bodyResult $ + lambdaBody lam' lam'' = lam' {lambdaBody = (lambdaBody lam') {bodyResult = lam_res'}} map_nesting = MapNesting pat' aux w $ zip (lambdaParams lam') arrs nest' = pushInnerKernelNesting (pat', lam_res') map_nesting 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 @@ -192,7 +192,9 @@ forM_ (zip (lambdaParams lam) arrs) $ \(p, arr) -> do arr_t <- lookupType arr letBindNames [paramName p] $ - BasicOp $ Index arr $ fullSlice arr_t [DimFix $ Var gtid] + BasicOp $ + Index arr $ + fullSlice arr_t [DimFix $ Var gtid] res <- bodyBind (lambdaBody lam) forM res $ \(SubExpRes cs se) -> pure $ Returns ResultMaySimplify cs se 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 @@ -251,7 +251,8 @@ } stms <- runBuilder_ . auxing aux . FOT.transformSOAC pat $ - Screma w used_arrs $ mapSOAC lam' + Screma w used_arrs $ + mapSOAC lam' pure $ acc {distTargets = newtargets, distStms = stms} | otherwise -> do @@ -381,7 +382,7 @@ Nothing -> addStmToAcc stm acc Just acc' -> distribute =<< onInnerMap (MapLoop pat (stmAux stm) w lam arrs) acc' maybeDistributeStm stm@(Let pat aux (DoLoop merge form@ForLoop {} body)) acc - | not $ any (`nameIn` freeIn pat) $ patNames pat, + | all (`notNameIn` freeIn pat) (patNames pat), bodyContainsParallelism body = distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') @@ -413,8 +414,9 @@ _ -> addStmToAcc stm acc maybeDistributeStm stm@(Let pat _ (If cond tbranch fbranch ret)) acc - | not $ any (`nameIn` freeIn pat) $ patNames pat, - bodyContainsParallelism tbranch || bodyContainsParallelism fbranch + | all (`notNameIn` freeIn pat) (patNames pat), + bodyContainsParallelism tbranch + || bodyContainsParallelism fbranch || not (all primType (ifReturns ret)) = distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') @@ -657,7 +659,8 @@ | map resSubExp res == map Var (patNames $ stmPat stm), (outer, _) <- nest, [(arr_p, arr)] <- loopNestingParamsAndArrs outer, - boundInKernelNest nest `namesIntersection` freeIn stm + boundInKernelNest nest + `namesIntersection` freeIn stm == oneName (paramName arr_p), perfectlyMapped arr nest -> do addPostStms kernels @@ -783,7 +786,8 @@ let rts = concatMap (take 1) $ chunks as_ns $ - drop (sum indexes) $ lambdaReturnType lam + drop (sum indexes) $ + lambdaReturnType lam (is, vs) = splitAt (sum indexes) $ bodyResult $ lambdaBody lam (is', k_body_stms) <- runBuilder $ do @@ -806,7 +810,9 @@ let pat = Pat . rearrangeShape perm $ - patElems $ loopNestingPat $ fst nest + patElems $ + loopNestingPat $ + fst nest letBind pat $ Op $ segOp k where @@ -847,10 +853,15 @@ -- Compute indexes into full array. v' <- certifying cs $ - letSubExp "v" $ BasicOp $ Index v $ Slice $ map (DimFix . Var) slice_gtids + letSubExp "v" $ + BasicOp $ + Index v $ + Slice $ + map (DimFix . Var) slice_gtids slice_is <- traverse (toSubExp "index") $ - fixSlice (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' = @@ -878,7 +889,9 @@ let pat = Pat . rearrangeShape perm $ - patElems $ loopNestingPat $ fst nest + patElems $ + loopNestingPat $ + fst nest letBind pat $ Op $ segOp k @@ -900,7 +913,9 @@ -- Compute indexes into full array. slice'' <- subExpSlice . sliceSlice (primExpSlice slice) $ - primExpSlice $ Slice $ map (DimFix . Var) slice_gtids + primExpSlice $ + Slice $ + map (DimFix . Var) slice_gtids v' <- certifying cs $ letSubExp "v" $ BasicOp $ Index arr slice'' v_t <- subExpType v' pure (v_t, Returns ResultMaySimplify mempty v') @@ -934,7 +949,9 @@ (ispace, inputs) <- flatKernel nest let orig_pat = Pat . rearrangeShape perm $ - patElems $ loopNestingPat $ fst nest + 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. @@ -984,7 +1001,8 @@ inputs' = filter (not . isDest . kernelInputArray) inputs certifying cs $ - addStms =<< traverse renameStm + addStms + =<< traverse renameStm =<< segHist lvl orig_pat hist_w ispace inputs' ops' lam arrs determineReduceOp :: @@ -1004,7 +1022,9 @@ BasicOp $ Index ne_v $ fullSlice ne_v_t $ - replicate (shapeRank shape) $ DimFix $ intConst Int64 0 + replicate (shapeRank shape) $ + DimFix $ + intConst Int64 0 pure (lam', nes', shape) Nothing -> pure (lam, nes, mempty) @@ -1041,7 +1061,8 @@ lam'' <- onLambda' lam' let scan_op = SegBinOp Noncommutative lam'' nes'' shape lvl <- mk_lvl (segment_size : map snd ispace) "segscan" $ NoRecommendation SegNoVirt - addStms =<< traverse renameStm + addStms + =<< traverse renameStm =<< segScan lvl pat cs segment_size [scan_op] map_lam arrs ispace inps regularSegmentedRedomapKernel :: @@ -1062,7 +1083,8 @@ \pat ispace inps nes' _ -> do let red_op = SegBinOp comm lam nes' mempty lvl <- mk_lvl (segment_size : map snd ispace) "segred" $ NoRecommendation SegNoVirt - addStms =<< traverse renameStm + addStms + =<< traverse renameStm =<< segRed lvl pat cs segment_size [red_op] map_lam arrs ispace inps isSegmentedOp :: @@ -1110,7 +1132,7 @@ | kernelInputIndices inp == map Var indices -> pure $ pure $ kernelInputArray inp Nothing - | not (arr `nameIn` bound_by_nest) -> + | arr `notNameIn` bound_by_nest -> -- This input is something that is free inside -- the loop nesting. We will have to replicate -- it. @@ -1132,7 +1154,9 @@ let pat = Pat . rearrangeShape perm $ - patElems $ loopNestingPat $ fst nest + patElems $ + loopNestingPat $ + fst nest m pat ispace kernel_inps nes' nested_arrs @@ -1150,8 +1174,8 @@ MonadFreshNames m => [PatElem Type] -> KernelNest -> m KernelNest expandKernelNest pes (outer_nest, inner_nests) = do let outer_size = - loopNestingWidth outer_nest : - map loopNestingWidth inner_nests + loopNestingWidth outer_nest + : map loopNestingWidth inner_nests inner_sizes = tails $ map loopNestingWidth inner_nests outer_nest' <- expandWith outer_nest outer_size inner_nests' <- zipWithM expandWith inner_nests inner_sizes 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 @@ -434,7 +434,8 @@ nest'' = removeUnusedNestingParts free_in_kernel $ - MapNesting pat aux w $ zip actual_params actual_arrs + MapNesting pat aux w $ + zip actual_params actual_arrs free_in_kernel'' = (freeIn nest'' <> free_in_kernel) `namesSubtract` actual_param_names @@ -515,7 +516,7 @@ ) where isIdentity (patElem, SubExpRes cs (Var v)) - | not (v `nameIn` bound) = Left (patElem, (cs, v)) + | v `notNameIn` bound = Left (patElem, (cs, v)) isIdentity x = Right x removeIdentityMappingFromNesting :: @@ -553,7 +554,8 @@ Just (targets', distributed) -> do (kernel_stm, w_stms) <- localScope (targetsScope targets') $ - constructKernel mk_lvl distributed $ mkBody stms inner_body_res + constructKernel mk_lvl distributed $ + mkBody stms inner_body_res distributed' <- renameStm kernel_stm logMsg $ "distributing\n" 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 @@ -44,7 +44,9 @@ scan_fun' = Lambda scan_params scan_body scan_rettype scan_input' = map (first Var) $ - uncurry zip $ splitAt (length arrs') $ map paramName map_params + uncurry zip $ + splitAt (length arrs') $ + map paramName map_params (nes', scan_arrs) = unzip scan_input' scan_soac <- scanSOAC [Scan scan_fun' nes'] @@ -52,9 +54,11 @@ mkBody ( oneStm $ Let (setPatOuterDimTo w map_pat) (defAux ()) $ - Op $ Screma w scan_arrs scan_soac + Op $ + Screma w scan_arrs scan_soac ) - $ varsRes $ patNames map_pat + $ varsRes + $ patNames map_pat map_fun' = Lambda map_params map_body map_rettype res_pat' <- @@ -64,13 +68,16 @@ addStm $ Let res_pat' (StmAux map_cs mempty ()) $ - Op $ Screma map_w map_arrs' (mapSOAC map_fun') + Op $ + Screma map_w map_arrs' (mapSOAC map_fun') 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 + BasicOp $ + Rearrange perm $ + identName from | otherwise = Nothing -- | Interchange Reduce With Inner Map. Tries to turn a @reduce(map)@ into a @@ -115,13 +122,15 @@ case irwim red_pat w comm red_fun' red_input' of Nothing -> do reduce_soac <- reduceSOAC [Reduce comm red_fun' $ map fst red_input'] - pure $ - mkBody + pure + $ mkBody ( oneStm $ Let red_pat (defAux ()) $ - Op $ Screma w (map snd red_input') reduce_soac + Op $ + Screma w (map snd red_input') reduce_soac ) - $ varsRes $ patNames map_pat + $ varsRes + $ patNames map_pat Just m -> localScope (scopeOfLParams map_params) $ do map_body_stms <- collectStms_ m pure $ mkBody map_body_stms $ varsRes $ patNames map_pat @@ -130,7 +139,9 @@ addStm $ Let res_pat (StmAux map_cs mempty ()) $ - Op $ Screma map_w arrs' $ mapSOAC map_fun' + Op $ + Screma map_w arrs' $ + mapSOAC map_fun' | otherwise = Nothing -- | Does this reduce operator contain an inner map, and if so, what 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 @@ -79,7 +79,8 @@ let lam = Lambda (params' <> new_params) body rettype map_stm = Let loop_pat_expanded aux $ - Op $ Screma w (arrs' <> new_arrs) (mapSOAC lam) + Op $ + Screma w (arrs' <> new_arrs) (mapSOAC lam) res = varsRes $ patNames loop_pat_expanded pat' = Pat $ rearrangeShape perm $ patElems pat @@ -90,7 +91,7 @@ free_in_body = freeIn body copyOrRemoveParam (param, arr) - | not (paramName param `nameIn` free_in_body) = + | paramName param `notNameIn` free_in_body = pure Nothing | otherwise = pure $ Just (param, arr) @@ -100,7 +101,8 @@ pure $ Var arr expandedInit param_name se = letSubExp (param_name <> "_expanded_init") $ - BasicOp $ Replicate (Shape [w]) se + BasicOp $ + Replicate (Shape [w]) se expand (merge_param, merge_init) = do expanded_param <- @@ -148,7 +150,8 @@ in ( patNames $ loopNestingPat n, oneStm $ Let (loopNestingPat n) (loopNestingAux n) $ - Op $ Screma (loopNestingWidth n) arrs (mapSOAC lam) + Op $ + Screma (loopNestingWidth n) arrs (mapSOAC lam) ) -- | Given a (parallel) map nesting and an inner sequential loop, move @@ -261,7 +264,8 @@ maplam_ret = lambdaReturnType acc_lam maplam = Lambda (iota_p : orig_acc_params ++ params) (lambdaBody acc_lam) maplam_ret auxing map_aux . fmap subExpsRes . letTupExp' "withacc_inter" $ - Op $ Screma w (iota_w : map paramName acc_params ++ arrs) (mapSOAC maplam) + Op $ + Screma w (iota_w : map paramName acc_params ++ arrs) (mapSOAC maplam) let pat = Pat $ rearrangeShape perm $ patElems map_pat pure $ WithAccStm perm pat inputs' acc_lam' where 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 @@ -122,7 +122,9 @@ lvl = SegGroup (Count num_groups) (Count $ Var group_size) SegNoVirt kstm = Let nested_pat aux $ - Op $ SegOp $ SegMap lvl kspace rts kbody' + Op $ + SegOp $ + SegMap lvl kspace rts kbody' let intra_min_par = intra_avail_par pure @@ -201,7 +203,8 @@ localScope (scopeOfFParams $ map fst merge) $ do loopbody' <- intraGroupBody lvl loopbody certifying (stmAuxCerts aux) $ - letBind pat $ DoLoop merge form' loopbody' + letBind pat $ + DoLoop merge form' loopbody' where form' = case form of ForLoop i it bound inps -> ForLoop i it bound inps @@ -210,7 +213,8 @@ tbody' <- intraGroupBody lvl tbody fbody' <- intraGroupBody lvl fbody certifying (stmAuxCerts aux) $ - letBind pat $ If cond tbody' fbody' ifdec + letBind pat $ + If cond tbody' fbody' ifdec Op soac | "sequential_outer" `inAttrs` stmAuxAttrs aux -> intraGroupStms lvl . fmap (certify (stmAuxCerts aux)) diff --git a/src/Futhark/Pass/ExtractKernels/StreamKernel.hs b/src/Futhark/Pass/ExtractKernels/StreamKernel.hs --- a/src/Futhark/Pass/ExtractKernels/StreamKernel.hs +++ b/src/Futhark/Pass/ExtractKernels/StreamKernel.hs @@ -52,10 +52,13 @@ max_num_groups_key <- nameFromString . pretty <$> newVName (desc ++ "_num_groups") num_groups <- letSubExp "num_groups" $ - Op $ SizeOp $ CalcNumGroups w max_num_groups_key group_size + Op $ + SizeOp $ + CalcNumGroups w max_num_groups_key group_size num_threads <- letSubExp "num_threads" $ - BasicOp $ BinOp (Mul Int64 OverflowUndef) num_groups group_size + BasicOp $ + BinOp (Mul Int64 OverflowUndef) num_groups group_size pure (num_groups, num_threads) blockedKernelSize :: 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 @@ -173,14 +173,17 @@ body <- runBodyBuilder $ localScope (scopeOfLParams inp_params) $ do letBindNames [paramName chunk_param] $ - BasicOp $ SubExp $ intConst Int64 1 + BasicOp $ + SubExp $ + intConst Int64 1 forM_ (zip acc_params nes) $ \(p, ne) -> letBindNames [paramName p] $ BasicOp $ SubExp ne forM_ (zip slice_params inp_params) $ \(slice, v) -> letBindNames [paramName slice] $ - BasicOp $ ArrayLit [Var $ paramName v] (paramType v) + BasicOp $ + ArrayLit [Var $ paramName v] (paramType v) (red_res, map_res) <- splitAt (length nes) <$> bodyBind (lambdaBody lam) @@ -188,7 +191,8 @@ v <- letExp "map_res" $ BasicOp $ SubExp se v_t <- lookupType v certifying cs . letSubExp "chunk" . BasicOp $ - Index v $ fullSlice v_t [DimFix $ intConst Int64 0] + Index v $ + fullSlice v_t [DimFix $ intConst Int64 0] pure $ mkBody mempty $ red_res <> subExpsRes map_res' @@ -381,7 +385,8 @@ (par_red_stms, par_op) <- transformParStream DoRename transformBody w comm red_lam red_nes map_lam arrs pure $ - seq_red_stms <> par_red_stms + seq_red_stms + <> par_red_stms <> oneStm (Let pat (defAux ()) $ Op $ ParOp (Just par_op) seq_op) else pure $ @@ -396,13 +401,17 @@ transformStms stream_stms transformProg :: Prog SOACS -> PassM (Prog MC) -transformProg (Prog consts funs) = +transformProg prog = modifyNameSource $ runState (runReaderT m mempty) where ExtractM m = do - consts' <- transformStms consts - funs' <- inScopeOf consts' $ mapM transformFunDef funs - pure $ Prog consts' funs' + consts' <- transformStms $ progConsts prog + funs' <- inScopeOf consts' $ mapM transformFunDef $ progFuns prog + pure $ + prog + { progConsts = consts', + progFuns = funs' + } -- | Transform a program using SOACs to a program in the 'MC' -- representation, using some amount of flattening. 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 @@ -287,7 +287,7 @@ not $ tooSmallSlice (primByteSize pt) rem_slice, is /= map Var (take (length is) thread_gids) || length is == length thread_gids, not (null thread_gids || null is), - not (last thread_gids `nameIn` (freeIn is <> freeIn rem_slice)) -> + last thread_gids `notNameIn` (freeIn is <> freeIn rem_slice) -> pure Nothing -- We are not fully indexing the array, and the indices are not -- a proper prefix of the thread indices, and some indices are @@ -439,7 +439,8 @@ -- will hopefully be removed by the simplifier. manifested <- if isJust manifest then rowMajorArray arr else pure arr letExp (baseString arr ++ "_coalesced") $ - BasicOp $ Manifest perm manifested + BasicOp $ + Manifest perm manifested rowMajorArray :: MonadBuilder m => @@ -463,7 +464,8 @@ per_chunk <- letSubExp "per_chunk" $ - BasicOp $ BinOp (SQuot Int64 Unsafe) w_padded num_chunks' + BasicOp $ + BinOp (SQuot Int64 Unsafe) w_padded num_chunks' arr_t <- lookupType arr arr_padded <- padArray w_padded padding arr_t rearrange num_chunks' w_padded per_chunk (baseString arr) arr_padded arr_t @@ -473,9 +475,11 @@ padding_shape = setDim d arr_shape padding arr_padding <- letExp (baseString arr <> "_padding") $ - BasicOp $ Scratch (elemType arr_t) (shapeDims padding_shape) + BasicOp $ + Scratch (elemType arr_t) (shapeDims padding_shape) letExp (baseString arr <> "_padded") $ - BasicOp $ Concat d (arr :| [arr_padding]) w_padded + BasicOp $ + Concat d (arr :| [arr_padding]) w_padded rearrange num_chunks' w_padded per_chunk arr_name arr_padded arr_t = do let arr_dims = arrayDims arr_t @@ -485,10 +489,12 @@ tr_perm = [0 .. d - 1] ++ map (+ d) ([1] ++ [2 .. shapeRank extradim_shape - 1 - d] ++ [0]) arr_extradim <- letExp (arr_name <> "_extradim") $ - BasicOp $ Reshape (map DimNew $ shapeDims extradim_shape) arr_padded + BasicOp $ + Reshape (map DimNew $ shapeDims extradim_shape) arr_padded arr_extradim_tr <- letExp (arr_name <> "_extradim_tr") $ - BasicOp $ Manifest tr_perm arr_extradim + BasicOp $ + Manifest tr_perm arr_extradim arr_inv_tr <- letExp (arr_name <> "_inv_tr") $ BasicOp $ diff --git a/src/Futhark/Passes.hs b/src/Futhark/Passes.hs --- a/src/Futhark/Passes.hs +++ b/src/Futhark/Passes.hs @@ -58,13 +58,9 @@ simplifySOACS, performCSE True, simplifySOACS, - -- We run fusion twice fuseSOACs, performCSE True, simplifySOACS, - fuseSOACs, - performCSE True, - simplifySOACS, removeDeadFunctions ] >>> condPipeline usesAD adPipeline @@ -79,8 +75,6 @@ performCSE True, fuseSOACs, performCSE True, - simplifySOACS, - fuseSOACs, simplifySOACS ] diff --git a/src/Futhark/Pkg/Info.hs b/src/Futhark/Pkg/Info.hs --- a/src/Futhark/Pkg/Info.hs +++ b/src/Futhark/Pkg/Info.hs @@ -209,7 +209,10 @@ let path = T.unpack $ - owner <> "/" <> repo <> "@" + owner + <> "/" + <> repo + <> "@" <> tag <> "/" <> T.pack futharkPkg @@ -258,7 +261,8 @@ head_ref <- maybe (fail $ "Cannot find HEAD ref for " <> T.unpack repo_url) pure $ - maybeHead $ mapMaybe isHeadRef remote_lines + maybeHead $ + mapMaybe isHeadRef remote_lines let def = fromMaybe head_ref rev_info <- M.fromList . catMaybes <$> mapM revInfo remote_lines @@ -347,14 +351,17 @@ base_url = "https://gitlab.com/" <> owner <> "/" <> repo repo_url = base_url <> ".git" mk_archive_url r = - base_url <> "/-/archive/" <> r + base_url + <> "/-/archive/" + <> r <> "/" <> repo <> "-" <> r <> ".zip" mk_manifest_url r = - base_url <> "/raw/" + base_url + <> "/raw/" <> r <> "/" <> T.pack futharkPkg @@ -444,7 +451,8 @@ major | (_, vs) <- majorRevOfPkg p, _svMajor v `notElem` vs = - "\nFor major version " <> T.pack (show (_svMajor v)) + "\nFor major version " + <> T.pack (show (_svMajor v)) <> ", use package path " <> p <> "@" @@ -452,7 +460,11 @@ | otherwise = mempty in fail $ T.unpack $ - "package " <> p <> " does not have a version " <> prettySemVer v <> ".\n" + "package " + <> p + <> " does not have a version " + <> prettySemVer v + <> ".\n" <> versions <> major Just v' -> pure v' diff --git a/src/Futhark/Pkg/Solve.hs b/src/Futhark/Pkg/Solve.hs --- a/src/Futhark/Pkg/Solve.hs +++ b/src/Futhark/Pkg/Solve.hs @@ -101,7 +101,10 @@ | otherwise = fail $ T.unpack $ - "Package " <> p <> " " <> prettySemVer v + "Package " + <> p + <> " " + <> prettySemVer v <> " has commit hash " <> pkgRevCommit pinfo <> ", but expected " diff --git a/src/Futhark/Pkg/Types.hs b/src/Futhark/Pkg/Types.hs --- a/src/Futhark/Pkg/Types.hs +++ b/src/Futhark/Pkg/Types.hs @@ -194,7 +194,9 @@ -- | The required packages listed in a package manifest. pkgRevDeps :: PkgManifest -> PkgRevDeps pkgRevDeps = - PkgRevDeps . M.fromList . mapMaybe onR + PkgRevDeps + . M.fromList + . mapMaybe onR . commented . manifestRequire where @@ -206,7 +208,8 @@ pkgDir :: PkgManifest -> Maybe Posix.FilePath pkgDir = fmap - ( Posix.addTrailingPathSeparator . ("lib" Posix.) + ( Posix.addTrailingPathSeparator + . ("lib" Posix.) . T.unpack ) . commented @@ -280,12 +283,14 @@ spaceNoEol = many $ oneOf (" \t" :: String) pPkgPath = - T.pack <$> some (alphaNumChar <|> oneOf ("@-/.:" :: String)) + T.pack + <$> some (alphaNumChar <|> oneOf ("@-/.:" :: String)) "package path" pRequired = space - *> ( Required <$> lexeme' pPkgPath + *> ( Required + <$> lexeme' pPkgPath <*> lexeme' semver' <*> optional (lexeme' pHash) ) diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs --- a/src/Futhark/Script.hs +++ b/src/Futhark/Script.hs @@ -35,6 +35,7 @@ where import Control.Monad.Except +import Data.Bifunctor (bimap) import Data.Char import Data.Foldable (toList) import Data.Functor @@ -51,20 +52,44 @@ import qualified Futhark.Test.Values as V import Futhark.Util (nubOrd) import Futhark.Util.Pretty hiding (float, line, sep, space, string, (), (<|>)) +import Language.Futhark.Core (Name, nameFromText, nameToText) +import Language.Futhark.Tuple (areTupleFields) import Text.Megaparsec import Text.Megaparsec.Char (space) import Text.Megaparsec.Char.Lexer (charLiteral) +type TypeMap = M.Map TypeName (Maybe [(Name, TypeName)]) + +typeMap :: MonadIO m => Server -> m TypeMap +typeMap server = do + liftIO $ either (pure mempty) onTypes =<< cmdTypes server + where + onTypes types = M.fromList . zip types <$> mapM onType types + onType t = + either (const Nothing) (Just . map onField) <$> cmdFields server t + onField = bimap nameFromText (T.drop 1) . T.breakOn " " + +isRecord :: TypeName -> TypeMap -> Maybe [(Name, TypeName)] +isRecord t m = join $ M.lookup t m + +isTuple :: TypeName -> TypeMap -> Maybe [TypeName] +isTuple t m = areTupleFields . M.fromList =<< isRecord t m + -- | Like a 'Server', but keeps a bit more state to make FutharkScript -- more convenient. -data ScriptServer = ScriptServer Server (IORef Int) +data ScriptServer = ScriptServer + { scriptServer :: Server, + scriptCounter :: IORef Int, + scriptTypes :: TypeMap + } -- | Run an action with a 'ScriptServer' produced by an existing -- 'Server', without shutting it down at the end. withScriptServer' :: MonadIO m => Server -> (ScriptServer -> m a) -> m a withScriptServer' server f = do counter <- liftIO $ newIORef 0 - f $ ScriptServer server counter + types <- typeMap server + f $ ScriptServer server counter types -- | Start a server, execute an action, then shut down the server. -- Similar to 'withServer'. @@ -132,9 +157,12 @@ parseExp :: Parsec Void T.Text () -> Parsec Void T.Text Exp parseExp sep = choice - [ lexeme sep "let" $> Let - <*> pPat <* lexeme sep "=" - <*> parseExp sep <* lexeme sep "in" + [ lexeme sep "let" + $> Let + <*> pPat + <* lexeme sep "=" + <*> parseExp sep + <* lexeme sep "in" <*> parseExp sep, try $ Call <$> parseFunc <*> many pAtom, pAtom @@ -276,15 +304,26 @@ ScriptServer -> Exp -> m ExpValue -evalExp builtin (ScriptServer server counter) top_level_e = do +evalExp builtin sserver top_level_e = do vars <- liftIO $ newIORef [] - let newVar base = liftIO $ do + let ( ScriptServer + { scriptServer = server, + scriptCounter = counter, + scriptTypes = types + } + ) = sserver + newVar base = liftIO $ do x <- readIORef counter modifyIORef counter (+ 1) let v = base <> prettyText x modifyIORef vars (v :) pure v + mkRecord t vs = do + v <- newVar "record" + cmdMaybe $ cmdNew server v t vs + pure v + toVal :: ValOrVar -> m V.Value toVal (VVal v) = pure v toVal (VVar v) = readVar server v @@ -310,17 +349,25 @@ interValToVal :: ExpValue -> m V.CompoundValue interValToVal = traverse scriptValueToVal - interValToVar :: ExpValue -> m VarName - interValToVar (V.ValueAtom v) = scriptValueToVar v - interValToVar _ = throwError "Unexpected tuple or record value." + -- Apart from type checking, this function also converts + -- FutharkScript tuples/records to Futhark-level tuples/records. + interValToVar :: m VarName -> TypeName -> ExpValue -> m VarName + interValToVar _ t (V.ValueAtom v) + | STValue t == scriptValueType v = scriptValueToVar v + interValToVar bad t (V.ValueTuple vs) + | Just ts <- isTuple t types, + length vs == length ts = + mkRecord t =<< zipWithM (interValToVar bad) ts vs + interValToVar bad t (V.ValueRecord vs) + | Just fs <- isRecord t types, + Just vs' <- mapM ((`M.lookup` vs) . nameToText . fst) fs = + mkRecord t =<< zipWithM (interValToVar bad) (map snd fs) vs' + interValToVar bad _ _ = bad valToInterVal :: V.CompoundValue -> ExpValue valToInterVal = fmap $ \v -> SValue (V.valueTypeTextNoDims (V.valueType v)) $ VVal v - simpleType (V.ValueAtom (STValue _)) = True - simpleType _ = False - letMatch :: [VarName] -> ExpValue -> m VTable letMatch vs val | vals <- V.unCompound val, @@ -328,7 +375,8 @@ pure $ M.fromList (zip vs vals) | otherwise = throwError $ - "Pat: " <> prettyTextOneLine vs + "Pat: " + <> prettyTextOneLine vs <> "\nDoes not match value of type: " <> prettyTextOneLine (fmap scriptValueType val) @@ -341,7 +389,8 @@ evalExp' vtable (Call (FuncFut name) es) | Just e <- M.lookup name vtable = do unless (null es) $ - throwError $ "Locally bound name cannot be invoked as a function: " <> prettyText name + throwError $ + "Locally bound name cannot be invoked as a function: " <> prettyText name pure e evalExp' vtable (Call (FuncFut name) es) = do in_types <- fmap (map inputType) $ cmdEither $ cmdInputs server name @@ -350,22 +399,19 @@ es' <- mapM (evalExp' vtable) es let es_types = map (fmap scriptValueType) es' - unless (all simpleType es_types) $ - throwError $ - "Literate Futhark does not support passing script-constructed records, tuples, or functions to entry points.\n" - <> "Create a Futhark wrapper function." + let cannotApply = + throwError $ + "Function \"" + <> name + <> "\" expects arguments of types:\n" + <> prettyText (V.mkCompound $ map V.ValueAtom in_types) + <> "\nBut called with arguments of types:\n" + <> prettyText (V.mkCompound $ map V.ValueAtom es_types) -- Careful to not require saturated application, but do still -- check for over-saturation. - let too_many = length es_types > length in_types - too_wrong = zipWith (/=) es_types (map (V.ValueAtom . STValue) in_types) - when (or $ too_many : too_wrong) . throwError $ - "Function \"" <> name <> "\" expects arguments of types:\n" - <> prettyText (V.mkCompound $ map V.ValueAtom in_types) - <> "\nBut called with arguments of types:\n" - <> prettyText (V.mkCompound $ map V.ValueAtom es_types) - - ins <- mapM (interValToVar <=< evalExp' vtable) es + when (length es_types > length in_types) cannotApply + ins <- zipWithM (interValToVar cannotApply) in_types es' if length in_types == length ins then do @@ -374,7 +420,8 @@ pure $ V.mkCompound $ map V.ValueAtom $ zipWith SValue out_types $ map VVar outs else pure . V.ValueAtom . SFun name in_types out_types $ - zipWith SValue in_types $ map VVar ins + zipWith SValue in_types $ + map VVar ins evalExp' _ (StringLit s) = case V.putValue s of Just s' -> @@ -386,7 +433,8 @@ V.ValueTuple <$> mapM (evalExp' vtable) es evalExp' vtable e@(Record m) = do when (length (nubOrd (map fst m)) /= length (map fst m)) $ - throwError $ "Record " <> prettyText e <> " has duplicate fields." + throwError $ + "Record " <> prettyText e <> " has duplicate fields." V.ValueRecord <$> traverse (evalExp' vtable) (M.fromList m) evalExp' vtable (Let pat e1 e2) = do v <- evalExp' vtable e1 @@ -412,10 +460,10 @@ -- no well-defined external representation. getExpValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m V.CompoundValue -getExpValue (ScriptServer server _) e = +getExpValue server e = traverse toGround =<< traverse (traverse onLeaf) e where - onLeaf (VVar v) = readVar server v + onLeaf (VVar v) = readVar (scriptServer server) v onLeaf (VVal v) = pure v toGround (SFun fname _ _ _) = throwError $ "Function " <> fname <> " not fully applied." @@ -453,5 +501,5 @@ -- | Release all the server-side variables in the value. Yes, -- FutharkScript has manual memory management... freeValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m () -freeValue (ScriptServer server _) = - cmdMaybe . cmdFree server . S.toList . serverVarsInValue +freeValue server = + cmdMaybe . cmdFree (scriptServer server) . S.toList . serverVarsInValue diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -272,7 +272,9 @@ pure stdout ExitFailure e -> fail $ - "'futhark dataset' failed with exit code " ++ show e ++ " and stderr:\n" + "'futhark dataset' failed with exit code " + ++ show e + ++ " and stderr:\n" ++ map (chr . fromIntegral) (SBS.unpack stderr) where args = "-b" : concatMap argForGen gens @@ -289,7 +291,8 @@ header_size = 1 + 1 + 1 + 4 -- 'b' genSize (GenValue (V.ValueType ds t)) = toInteger $ - header_size + length ds * 8 + header_size + + length ds * 8 + product ds * V.primTypeBytes t genSize (GenPrim v) = toInteger $ header_size + product (V.valueShape v) * V.primTypeBytes (V.valueElemType v) @@ -300,11 +303,11 @@ testRunReferenceOutput prog entry tr = "data" takeBaseName prog - <> ":" - <> T.unpack entry - <> "-" - <> map clean (runDescription tr) - <.> "out" + <> ":" + <> T.unpack entry + <> "-" + <> map clean (runDescription tr) + <.> "out" where clean '/' = '_' -- Would this ever happen? clean ' ' = '_' @@ -492,7 +495,9 @@ liftIO $ BS.writeFile actualf $ mconcat $ map Bin.encode actual_vs liftIO $ BS.writeFile expectedf $ mconcat $ map Bin.encode expected_vs throwError $ - T.pack actualf <> " and " <> T.pack expectedf + T.pack actualf + <> " and " + <> T.pack expectedf <> " do not match:\n" <> T.pack (show mismatch) <> if null mismatches diff --git a/src/Futhark/Test/Spec.hs b/src/Futhark/Test/Spec.hs --- a/src/Futhark/Test/Spec.hs +++ b/src/Futhark/Test/Spec.hs @@ -212,7 +212,8 @@ parseAction sep = choice [ CompileTimeFailure <$> (lexstr' "error:" *> parseExpectedError sep), - RunCases <$> parseInputOutputs sep + RunCases + <$> parseInputOutputs sep <*> many (parseExpectedStructure sep) <*> many (parseWarning sep) ] @@ -373,7 +374,9 @@ cases <- many $ pInputOutputs <* many pNonTestLine pure spec {testAction = RunCases (old_cases ++ concat cases) structures warnings} | otherwise -> - many pNonTestLine *> notFollowedBy "-- ==" *> pure spec + many pNonTestLine + *> notFollowedBy "-- ==" + *> pure spec "no more test blocks, since first test block specifies type error." Nothing -> eof $> noTest diff --git a/src/Futhark/Tools.hs b/src/Futhark/Tools.hs --- a/src/Futhark/Tools.hs +++ b/src/Futhark/Tools.hs @@ -94,7 +94,8 @@ let scanomap = scanomapSOAC scans map_lam letBindNames (scan_res <> to_red <> map_res) $ - Op $ Screma w arrs scanomap + Op $ + Screma w arrs scanomap reduce <- reduceSOAC reds letBindNames red_res $ Op $ Screma w to_red reduce 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 @@ -171,16 +171,21 @@ case paramForAcc arr_t of Just acc_out_p -> letBindNames [paramName p] . BasicOp $ - SubExp $ Var $ paramName acc_out_p + SubExp $ + Var $ + paramName acc_out_p Nothing | paramName p `nameIn` lam_cons -> do p' <- letExp (baseString (paramName p)) . BasicOp $ - Index arr $ fullSlice arr_t [DimFix $ Var i] + Index arr $ + fullSlice arr_t [DimFix $ Var i] letBindNames [paramName p] $ BasicOp $ Copy p' | otherwise -> letBindNames [paramName p] $ - BasicOp $ Index arr $ fullSlice arr_t [DimFix $ Var i] + BasicOp $ + Index arr $ + fullSlice arr_t [DimFix $ Var i] -- Insert the statements of the lambda. We have taken care to -- ensure that the parameters are bound at this point. @@ -188,7 +193,8 @@ -- Split into scan results, reduce results, and map results. let (scan_res, red_res, map_res) = splitAt3 (length scan_nes) (length red_nes) $ - bodyResult $ lambdaBody map_lam + bodyResult $ + lambdaBody map_lam scan_res' <- eLambda scan_lam $ @@ -202,12 +208,14 @@ -- Write the scan accumulator to the scan result arrays. scan_outarrs <- certifying (foldMap resCerts scan_res) $ - letwith (map paramName scanout_params) (Var i) $ map resSubExp scan_res' + letwith (map paramName scanout_params) (Var i) $ + map resSubExp scan_res' -- Write the map results to the map result arrays. map_outarrs <- certifying (foldMap resCerts map_res) $ - letwith (map paramName mapout_params) (Var i) $ map resSubExp map_res + letwith (map paramName mapout_params) (Var i) $ + map resSubExp map_res pure . mkBody mempty . concat $ [ scan_res', @@ -255,8 +263,8 @@ let loop_form = ForLoop i Int64 w [] - letBindNames [paramName chunk_size_param] $ - BasicOp $ SubExp $ intConst Int64 1 + letBindNames [paramName chunk_size_param] . BasicOp . SubExp $ + intConst Int64 1 loop_body <- runBodyBuilder $ localScope (scopeOf loop_form <> scopeOfFParams merge_params) $ do @@ -267,11 +275,13 @@ (res, mapout_res) <- splitAt (length nes) <$> bodyBind (lambdaBody lam) + res' <- mapM (copyIfArray . resSubExp) res + 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 - mkBodyM mempty $ res ++ subExpsRes mapout_res' + mkBodyM mempty $ subExpsRes $ res' ++ mapout_res' letBind pat $ DoLoop merge loop_form loop_body transformSOAC pat (Scatter len ivs lam as) = do @@ -296,7 +306,8 @@ 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 + BasicOp $ + Update Safe arr' (fullSlice arr_t $ map (DimFix . resSubExp) indexCur) valueCur foldM saveInArray arr indexes' pure $ resultBody (map Var ress) @@ -348,7 +359,8 @@ hist' <- forM (zip hist h_val') $ \(arr, SubExpRes cs v) -> do arr_t <- lookupType arr certifying cs . letInPlace "hist_out" arr (fullSlice arr_t $ map DimFix idxs) $ - BasicOp $ SubExp v + BasicOp $ + SubExp v pure $ varsRes hist' diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -20,7 +20,6 @@ dropAt, takeLast, dropLast, - debug, mapEither, maybeNth, maybeHead, @@ -72,7 +71,6 @@ import Control.Concurrent import Control.Exception import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) import Crypto.Hash.MD5 as MD5 import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 @@ -99,7 +97,6 @@ import System.IO (hIsTerminalDevice, stdout) import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe -import System.Log.Logger (debugM) import System.Process.ByteString import Text.Read (readMaybe) @@ -515,10 +512,10 @@ encodeAsUnicodeCharar :: Char -> EncodedString encodeAsUnicodeCharar c = - 'z' : - if isDigit (head hex_str) - then hex_str - else '0' : hex_str + 'z' + : if isDigit (head hex_str) + then hex_str + else '0' : hex_str where hex_str = showHex (ord c) "U" @@ -546,7 +543,3 @@ fixPoint f x = let x' = f x in if x' == x then x else fixPoint f x' - --- | Issue a debugging statement to the log. -debug :: MonadIO m => String -> m () -debug msg = liftIO $ debugM "futhark" msg diff --git a/src/Language/Futhark.hs b/src/Language/Futhark.hs --- a/src/Language/Futhark.hs +++ b/src/Language/Futhark.hs @@ -2,6 +2,7 @@ module Language.Futhark ( module Language.Futhark.Syntax, module Language.Futhark.Prop, + module Language.Futhark.FreeVars, module Language.Futhark.Pretty, Ident, DimIndex, @@ -26,6 +27,7 @@ ) where +import Language.Futhark.FreeVars import Language.Futhark.Pretty import Language.Futhark.Prop import Language.Futhark.Syntax @@ -79,7 +81,7 @@ type Prog = ProgBase Info VName -- | A known type arg with shape annotations. -type StructTypeArg = TypeArg (DimDecl VName) +type StructTypeArg = TypeArg Size -- | A type-checked type parameter. type TypeParam = TypeParamBase 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 @@ -30,9 +30,6 @@ quote, pquote, - -- * Special identifiers - defaultEntryPoint, - -- * Number re-export Int8, Int16, @@ -76,10 +73,6 @@ ppr Unique = star ppr Nonunique = empty --- | The name of the default program entry point (main). -defaultEntryPoint :: Name -defaultEntryPoint = nameFromString "main" - -- | The abstract (not really) type representing names in the Futhark -- compiler. 'String's, being lists of characters, are very slow, -- while 'T.Text's are based on byte-arrays. @@ -156,8 +149,8 @@ -- beyond that would require a truly perverse program. f i x = (if cur == i then "-> " else " ") - ++ '#' : - show i + ++ '#' + : show i ++ (if i > 9 then "" else " ") ++ " " ++ x diff --git a/src/Language/Futhark/FreeVars.hs b/src/Language/Futhark/FreeVars.hs new file mode 100644 --- /dev/null +++ b/src/Language/Futhark/FreeVars.hs @@ -0,0 +1,164 @@ +-- | Facilities for computing free term variables in various syntactic +-- constructs. +module Language.Futhark.FreeVars + ( freeInExp, + freeInPat, + freeInType, + freeWithout, + FV (..), + ) +where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Futhark.IR.Pretty () +import Language.Futhark.Prop +import Language.Futhark.Syntax + +-- | A set of names where we also track their type. +newtype FV = FV {unFV :: M.Map VName StructType} + deriving (Show) + +instance Semigroup FV where + FV x <> FV y = FV $ M.unionWith max x y + +instance Monoid FV where + mempty = FV mempty + +-- | Set subtraction. Do not consider those variables as free. +freeWithout :: FV -> S.Set VName -> FV +freeWithout (FV x) y = FV $ M.filterWithKey keep x + where + keep k _ = k `S.notMember` y + +ident :: IdentBase Info VName -> FV +ident v = FV $ M.singleton (identName v) (toStruct $ unInfo (identType v)) + +size :: VName -> FV +size v = FV $ M.singleton v $ Scalar $ Prim $ Signed Int64 + +-- | A 'FV' with these names, considered to be sizes. +sizes :: S.Set VName -> FV +sizes = foldMap size + +-- | Compute the set of free variables of an expression. +freeInExp :: ExpBase Info VName -> FV +freeInExp expr = case expr of + Literal {} -> mempty + IntLit {} -> mempty + FloatLit {} -> mempty + StringLit {} -> mempty + Hole {} -> mempty + Parens e _ -> freeInExp e + QualParens _ e _ -> freeInExp e + TupLit es _ -> foldMap freeInExp es + RecordLit fs _ -> foldMap freeInExpField fs + where + freeInExpField (RecordFieldExplicit _ e _) = freeInExp e + freeInExpField (RecordFieldImplicit vn t _) = ident $ Ident vn t mempty + ArrayLit es t _ -> + foldMap freeInExp es <> sizes (freeInType $ unInfo t) + AppExp (Range e me incl _) _ -> + freeInExp e <> foldMap freeInExp me <> foldMap freeInExp incl + Var qn (Info t) _ -> FV $ M.singleton (qualLeaf qn) $ toStruct t + Ascript e _ _ -> freeInExp e + AppExp (Coerce e _ _) (Info ar) -> + freeInExp e <> sizes (freeInType (appResType ar)) + AppExp (LetPat let_sizes pat e1 e2 _) _ -> + freeInExp e1 + <> ( (sizes (freeInPat pat) <> freeInExp e2) + `freeWithout` (patNames pat <> S.fromList (map sizeName let_sizes)) + ) + AppExp (LetFun vn (tparams, pats, _, _, e1) e2 _) _ -> + ( (freeInExp e1 <> sizes (foldMap freeInPat pats)) + `freeWithout` ( foldMap patNames pats + <> S.fromList (map typeParamName tparams) + ) + ) + <> (freeInExp e2 `freeWithout` S.singleton vn) + AppExp (If e1 e2 e3 _) _ -> freeInExp e1 <> freeInExp e2 <> freeInExp e3 + AppExp (Apply e1 e2 _ _) _ -> freeInExp e1 <> freeInExp e2 + Negate e _ -> freeInExp e + Not e _ -> freeInExp e + Lambda pats e0 _ (Info (_, RetType dims t)) _ -> + (sizes (foldMap freeInPat pats) <> freeInExp e0 <> sizes (freeInType t)) + `freeWithout` (foldMap patNames pats <> S.fromList dims) + OpSection {} -> mempty + OpSectionLeft _ _ e _ _ _ -> freeInExp e + OpSectionRight _ _ e _ _ _ -> freeInExp e + ProjectSection {} -> mempty + IndexSection idxs _ _ -> foldMap freeInDimIndex idxs + AppExp (DoLoop sparams pat e1 form e3 _) _ -> + let (e2fv, e2ident) = formVars form + in freeInExp e1 + <> ( (e2fv <> freeInExp e3) + `freeWithout` (S.fromList sparams <> patNames pat <> e2ident) + ) + where + formVars (For v e2) = (freeInExp e2, S.singleton $ identName v) + formVars (ForIn p e2) = (freeInExp e2, patNames p) + formVars (While e2) = (freeInExp e2, mempty) + AppExp (BinOp (qn, _) (Info qn_t) (e1, _) (e2, _) _) _ -> + FV (M.singleton (qualLeaf qn) $ toStruct qn_t) + <> freeInExp e1 + <> freeInExp e2 + Project _ e _ _ -> freeInExp e + AppExp (LetWith id1 id2 idxs e1 e2 _) _ -> + ident id2 + <> foldMap freeInDimIndex idxs + <> freeInExp e1 + <> (freeInExp e2 `freeWithout` S.singleton (identName id1)) + AppExp (Index e idxs _) _ -> freeInExp e <> foldMap freeInDimIndex idxs + Update e1 idxs e2 _ -> freeInExp e1 <> foldMap freeInDimIndex idxs <> freeInExp e2 + RecordUpdate e1 _ e2 _ _ -> freeInExp e1 <> freeInExp e2 + Assert e1 e2 _ _ -> freeInExp e1 <> freeInExp e2 + Constr _ es _ _ -> foldMap freeInExp es + Attr _ e _ -> freeInExp e + AppExp (Match e cs _) _ -> freeInExp e <> foldMap caseFV cs + where + caseFV (CasePat p eCase _) = + (sizes (freeInPat p) <> freeInExp eCase) + `freeWithout` patNames p + +freeInDimIndex :: DimIndexBase Info VName -> FV +freeInDimIndex (DimFix e) = freeInExp e +freeInDimIndex (DimSlice me1 me2 me3) = + foldMap (foldMap freeInExp) [me1, me2, me3] + +-- | Free variables in pattern (including types of the bound identifiers). +freeInPat :: PatBase Info VName -> S.Set VName +freeInPat (TuplePat ps _) = foldMap freeInPat ps +freeInPat (RecordPat fs _) = foldMap (freeInPat . snd) fs +freeInPat (PatParens p _) = freeInPat p +freeInPat (Id _ (Info tp) _) = freeInType tp +freeInPat (Wildcard (Info tp) _) = freeInType tp +freeInPat (PatAscription p _ _) = freeInPat p +freeInPat (PatLit _ (Info tp) _) = freeInType tp +freeInPat (PatConstr _ _ ps _) = foldMap freeInPat ps +freeInPat (PatAttr _ p _) = freeInPat p + +-- | Free variables in the type (meaning those that are used in size expression). +freeInType :: TypeBase Size as -> S.Set VName +freeInType t = + case t of + Array _ _ s a -> + freeInType (Scalar a) <> foldMap onSize (shapeDims s) + Scalar (Record fs) -> + foldMap freeInType fs + Scalar Prim {} -> + mempty + Scalar (Sum cs) -> + foldMap (foldMap freeInType) cs + Scalar (Arrow _ v t1 (RetType dims t2)) -> + S.filter (notV v) $ S.filter (`notElem` dims) $ freeInType t1 <> freeInType t2 + Scalar (TypeVar _ _ _ targs) -> + foldMap typeArgDims targs + where + typeArgDims (TypeArgDim d _) = onSize d + typeArgDims (TypeArgType at _) = freeInType at + + notV Unnamed = const True + notV (Named v) = (/= v) + + onSize (NamedSize qn) = S.singleton $ qualLeaf qn + onSize _ = mempty 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 @@ -45,13 +45,13 @@ import qualified Data.Map as M import Data.Maybe import Data.Monoid hiding (Sum) -import Futhark.IR.Primitive (floatValue, intValue) -import qualified Futhark.IR.Primitive as P import Futhark.Util (chunk, maybeHead, splitFromEnd) import Futhark.Util.Loc import Futhark.Util.Pretty hiding (apply, bool) -import Language.Futhark hiding (Value, matchDims) +import Language.Futhark hiding (Shape, Value, matchDims) import qualified Language.Futhark as F +import Language.Futhark.Primitive (floatValue, intValue) +import qualified Language.Futhark.Primitive as P import qualified Language.Futhark.Semantic as T import Prelude hiding (break, mod) @@ -140,7 +140,7 @@ field (k, v) = ppr k <+> equals <+> ppr v valueStructType :: ValueType -> StructType -valueStructType = first (ConstDim . fromIntegral) +valueStructType = first (ConstSize . fromIntegral) -- | A shape is a tree to accomodate the case of records. It is -- parameterised over the representation of dimensions. @@ -177,7 +177,7 @@ ShapeRecord $ M.map go fs go (Scalar (Sum cs)) = ShapeSum $ M.map (map go) cs - go (Scalar (TypeVar _ _ (TypeName [] v) [])) + go (Scalar (TypeVar _ _ (QualName [] v) [])) | Just shape <- M.lookup v shapes = shape go _ = @@ -186,16 +186,16 @@ structTypeShape :: M.Map VName ValueShape -> StructType -> Shape (Maybe Int64) structTypeShape shapes = fmap dim . typeShape shapes' where - dim (ConstDim d) = Just $ fromIntegral d + dim (ConstSize d) = Just $ fromIntegral d dim _ = Nothing - shapes' = M.map (fmap $ ConstDim . fromIntegral) shapes + shapes' = M.map (fmap $ ConstSize . fromIntegral) shapes resolveTypeParams :: [VName] -> StructType -> StructType -> Env resolveTypeParams names = match where match (Scalar (TypeVar _ _ tn _)) t - | typeLeaf tn `elem` names = - typeEnv $ M.singleton (typeLeaf tn) t + | qualLeaf tn `elem` names = + typeEnv $ M.singleton (qualLeaf tn) t match (Scalar (Record poly_fields)) (Scalar (Record fields)) = mconcat $ M.elems $ @@ -215,7 +215,7 @@ matchDims d1 d2 <> match (stripArray 1 poly_t) (stripArray 1 t) match _ _ = mempty - matchDims (NamedDim (QualName _ d1)) (ConstDim d2) + matchDims (NamedSize (QualName _ d1)) (ConstSize d2) | d1 `elem` names = i64Env $ M.singleton d1 $ fromIntegral d2 matchDims _ _ = mempty @@ -237,7 +237,7 @@ matchDims d1 d2 <> match (stripArray 1 poly_t) rowshape match _ _ = mempty - matchDims (NamedDim (QualName _ d1)) d2 + matchDims (NamedSize (QualName _ d1)) d2 | d1 `elem` names = M.singleton d1 d2 matchDims _ _ = mempty @@ -549,12 +549,14 @@ instance Pretty Indexing where ppr (IndexingFix i) = ppr i ppr (IndexingSlice i j (Just s)) = - maybe mempty ppr i <> text ":" + maybe mempty ppr i + <> text ":" <> maybe mempty ppr j <> text ":" <> ppr s ppr (IndexingSlice i (Just j) s) = - maybe mempty ppr i <> text ":" + maybe mempty ppr i + <> text ":" <> ppr j <> maybe mempty ((text ":" <>) . ppr) s ppr (IndexingSlice i Nothing Nothing) = @@ -663,7 +665,8 @@ evalDimIndex env (DimFix x) = IndexingFix . asInt64 <$> eval env x evalDimIndex env (DimSlice start end stride) = - IndexingSlice <$> traverse (fmap asInt64 . eval env) start + IndexingSlice + <$> traverse (fmap asInt64 . eval env) start <*> traverse (fmap asInt64 . eval env) end <*> traverse (fmap asInt64 . eval env) stride @@ -671,7 +674,8 @@ evalIndex loc env is arr = do let oob = bad loc env $ - "Index [" <> intercalate ", " (map pretty is) + "Index [" + <> intercalate ", " (map pretty is) <> "] out of bounds for array of shape " <> pretty (valueShape arr) <> "." @@ -690,26 +694,26 @@ shape' = fmap evalDim shape in arrayOf u shape' et' where - evalDim (NamedDim qn) + evalDim (NamedSize qn) | Just (TermValue _ (ValuePrim (SignedValue (Int64Value x)))) <- lookupVar qn env = - ConstDim $ fromIntegral x + ConstSize $ fromIntegral x evalDim d = d evalType env t@(Scalar (TypeVar () _ tn args)) = - case lookupType (qualNameFromTypeName tn) env of + case lookupType tn env of Just (T.TypeAbbr _ ps (RetType _ t')) -> let (substs, types) = mconcat $ zipWith matchPtoA ps args - onDim (NamedDim v) = fromMaybe (NamedDim v) $ M.lookup (qualLeaf v) substs + onDim (NamedSize v) = fromMaybe (NamedSize v) $ M.lookup (qualLeaf v) substs onDim d = d in if null ps then first onDim t' else evalType (Env mempty types mempty <> env) $ first onDim t' Nothing -> t where - matchPtoA (TypeParamDim p _) (TypeArgDim (NamedDim qv) _) = - (M.singleton p $ NamedDim qv, mempty) - matchPtoA (TypeParamDim p _) (TypeArgDim (ConstDim k) _) = - (M.singleton p $ ConstDim k, mempty) + matchPtoA (TypeParamDim p _) (TypeArgDim (NamedSize qv) _) = + (M.singleton p $ NamedSize qv, mempty) + matchPtoA (TypeParamDim p _) (TypeArgDim (ConstSize k) _) = + (M.singleton p $ ConstSize k, mempty) matchPtoA (TypeParamType l p _) (TypeArgType t' _) = let t'' = evalType env t' in (mempty, M.singleton p $ T.TypeAbbr l [] $ RetType [] t'') @@ -733,7 +737,7 @@ Nothing -> error $ "typeValueShape: failed to fully evaluate type " ++ pretty t' Just shape -> pure shape where - dim (ConstDim x) = Just $ fromIntegral x + dim (ConstSize x) = Just $ fromIntegral x dim _ = Nothing evalFunction :: Env -> [VName] -> [Pat] -> Exp -> StructType -> EvalM Value @@ -808,12 +812,13 @@ Nothing -> pure () pure v -returned :: Env -> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value +returned :: Env -> TypeBase Size als -> [VName] -> Value -> EvalM Value returned _ _ [] v = pure v returned env ret retext v = do mapM_ (uncurry putExtSize) $ M.toList $ - resolveExistentials retext (evalType env $ toStruct ret) $ valueShape v + resolveExistentials retext (evalType env $ toStruct ret) $ + valueShape v pure v evalAppExp :: Env -> StructType -> AppExp -> EvalM Value @@ -853,7 +858,8 @@ t -> error $ "Nonsensical range type: " ++ show t badRange start' maybe_second' end' = - "Range " ++ pretty start' + "Range " + ++ pretty start' ++ ( case maybe_second' of Nothing -> "" Just second' -> ".." ++ pretty second' @@ -870,12 +876,13 @@ Just _ -> pure v Nothing -> bad loc env $ - "Value `" <> pretty v <> "` of shape `" ++ pretty (valueShape v) + "Value `" <> pretty v <> "` of shape `" + ++ pretty (valueShape v) ++ "` cannot match shape of type `" - <> pretty te - <> "` (`" - <> pretty t - <> "`)" + <> pretty te + <> "` (`" + <> pretty t + <> "`)" evalAppExp env _ (LetPat sizes p e body _) = do v <- eval env e env' <- matchPat env p v @@ -922,9 +929,10 @@ let Ident src_vn (Info src_t) _ = src dest' <- maybe oob pure - =<< writeArray <$> mapM (evalDimIndex env) is - <*> evalTermVar env (qualName src_vn) (toStruct src_t) - <*> eval env v + =<< writeArray + <$> mapM (evalDimIndex env) is + <*> evalTermVar env (qualName src_vn) (toStruct src_t) + <*> eval env v let t = T.BoundV [] $ toStruct $ unInfo $ identType dest eval (valEnv (M.singleton (identName dest) (Just t, dest')) <> env) body where @@ -1165,9 +1173,9 @@ onTerm (TermPoly t v) = TermPoly t v onTerm (TermModule m) = TermModule $ onModule m onType (T.TypeAbbr l ps t) = T.TypeAbbr l ps $ first onDim t - onDim (NamedDim v) = NamedDim $ replaceQ v - onDim (ConstDim x) = ConstDim x - onDim (AnyDim v) = AnyDim v + onDim (NamedSize v) = NamedSize $ replaceQ v + onDim (ConstSize x) = ConstSize x + onDim (AnySize v) = AnySize v evalModuleVar :: Env -> QualName VName -> EvalM Module evalModuleVar env qv = @@ -1522,27 +1530,31 @@ def "<" = Just $ bopDef $ - sintCmp P.CmpSlt ++ uintCmp P.CmpUlt + sintCmp P.CmpSlt + ++ uintCmp P.CmpUlt ++ floatCmp P.FCmpLt ++ boolCmp P.CmpLlt def ">" = Just $ bopDef $ flipCmps $ - sintCmp P.CmpSlt ++ uintCmp P.CmpUlt + sintCmp P.CmpSlt + ++ uintCmp P.CmpUlt ++ floatCmp P.FCmpLt ++ boolCmp P.CmpLlt def "<=" = Just $ bopDef $ - sintCmp P.CmpSle ++ uintCmp P.CmpUle + sintCmp P.CmpSle + ++ uintCmp P.CmpUle ++ floatCmp P.FCmpLe ++ boolCmp P.CmpLle def ">=" = Just $ bopDef $ flipCmps $ - sintCmp P.CmpSle ++ uintCmp P.CmpUle + sintCmp P.CmpSle + ++ uintCmp P.CmpUle ++ floatCmp P.FCmpLe ++ boolCmp P.CmpLle def s @@ -1892,7 +1904,8 @@ ShapeDim _ ys_rowshape = valueShape ys pure $ toArray' (ShapeRecord (tupleFields [xs_rowshape, ys_rowshape])) $ - map toTuple $ transpose [snd $ fromArray xs, snd $ fromArray ys] + map toTuple $ + transpose [snd $ fromArray xs, snd $ fromArray ys] def "concat" = Just $ fun2t $ \xs ys -> do let (ShapeDim _ rowshape, xs') = fromArray xs @@ -1903,7 +1916,9 @@ let (ShapeDim n (ShapeDim m shape), xs') = fromArray xs pure $ toArray (ShapeDim m (ShapeDim n shape)) $ - map (toArray (ShapeDim n shape)) $ transpose $ map (snd . fromArray) xs' + map (toArray (ShapeDim n shape)) $ + transpose $ + map (snd . fromArray) xs' def "rotate" = Just $ fun2t $ \i xs -> do let (shape, xs') = fromArray xs @@ -1928,7 +1943,8 @@ if asInt64 n * asInt64 m /= xs_size then bad mempty mempty $ - "Cannot unflatten array of shape [" <> pretty xs_size + "Cannot unflatten array of shape [" + <> pretty xs_size <> "] to array of shape [" <> pretty (asInt64 n) <> "][" @@ -1936,9 +1952,11 @@ <> "]" else pure $ toArray shape $ map (toArray rowshape) $ chunk (asInt m) xs' def "vjp2" = Just $ - fun3t $ \_ _ _ -> bad noLoc mempty "Interpreter does not support autodiff." + fun3t $ + \_ _ _ -> bad noLoc mempty "Interpreter does not support autodiff." def "jvp2" = Just $ - fun3t $ \_ _ _ -> bad noLoc mempty "Interpreter does not support autodiff." + fun3t $ + \_ _ _ -> bad noLoc mempty "Interpreter does not support autodiff." def "acc" = Nothing def s | nameFromString s `M.member` namesToPrimTypes = Nothing def s = error $ "Missing intrinsic: " ++ s @@ -2037,8 +2055,10 @@ badPrim vt pt = Left . pretty $ "Invalid argument type." - "Expected:" <+> align (ppr pt) - "Got: " <+> align (ppr vt) + "Expected:" + <+> align (ppr pt) + "Got: " + <+> align (ppr vt) convertValue (F.PrimValue p) = Just $ ValuePrim p convertValue (F.ArrayValue arr t) = mkArray t =<< mapM convertValue (elems arr) diff --git a/src/Language/Futhark/Parser/Monad.hs b/src/Language/Futhark/Parser/Monad.hs --- a/src/Language/Futhark/Parser/Monad.hs +++ b/src/Language/Futhark/Parser/Monad.hs @@ -91,7 +91,7 @@ "Only the keyword '" <> expected <> "' may appear here." mustBeEmpty :: Located loc => loc -> ValueType -> ParserMonad () -mustBeEmpty _ (Array _ _ (ShapeDecl dims) _) +mustBeEmpty _ (Array _ _ (Shape dims) _) | 0 `elem` dims = pure () mustBeEmpty loc t = parseErrorAt loc $ Just $ pretty t ++ " is not an empty array." @@ -139,7 +139,9 @@ | valueType x == valueType y = Right x | otherwise = Left . SyntaxError NoLoc $ - "Elements " <> pretty x <> " and " + "Elements " + <> pretty x + <> " and " <> pretty y <> " cannot exist in same array." @@ -155,7 +157,8 @@ op (AppExp (Index e is floc) _) (ArrayLit xs _ xloc) = parseErrorAt (srcspan floc xloc) . Just . pretty $ "Incorrect syntax for multi-dimensional indexing." - "Use" <+> align (ppr index) + "Use" + <+> align (ppr index) where index = AppExp (Index e (is ++ map DimFix xs) xloc) NoInfo op f x = 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 @@ -457,12 +457,12 @@ TypeExpTerm :: { UncheckedTypeExp } : '*' TypeExpTerm { TEUnique $2 (srcspan $1 $>) } - | '[' DimExp ']' TypeExpTerm %prec indexprec + | '[' SizeExp ']' TypeExpTerm %prec indexprec { TEArray $2 $4 (srcspan $1 $>) } | TypeExpApply %prec sumprec { $1 } -- Errors - | '[' DimExp ']' %prec bottom + | '[' SizeExp ']' %prec bottom {% parseErrorAt (srcspan $1 $>) $ Just $ unlines ["missing array row type.", "Did you mean []" ++ pretty $2 ++ "?"] @@ -487,12 +487,12 @@ TypeExpApply :: { UncheckedTypeExp } : TypeExpApply TypeArg { TEApply $1 $2 (srcspan $1 $>) } - | 'id[' DimExp ']' + | 'id[' SizeExp ']' { let L loc (INDEXING v) = $1 in TEApply (TEVar (qualName v) (srclocOf (backOneCol loc))) (TypeArgExpDim $2 (srclocOf loc)) (srcspan $1 $>) } - | 'qid[' DimExp ']' + | 'qid[' SizeExp ']' { let L loc (QUALINDEXING qs v) = $1 in TEApply (TEVar (QualName qs v) (srclocOf (backOneCol loc))) (TypeArgExpDim $2 (srclocOf loc)) @@ -513,7 +513,7 @@ : constructor { let L _ (CONSTRUCTOR c) = $1 in (c, locOf $1) } TypeArg :: { TypeArgExp Name } - : '[' DimExp ']' { TypeArgExpDim $2 (srcspan $1 $>) } + : '[' SizeExp ']' { TypeArgExpDim $2 (srcspan $1 $>) } | TypeExpAtom { TypeArgExpType $1 } FieldType :: { (Name, UncheckedTypeExp) } @@ -527,14 +527,14 @@ : TypeExp { [$1] } | TypeExp ',' TupleTypes { $1 : $3 } -DimExp :: { DimExp Name } +SizeExp :: { SizeExp Name } : QualName - { DimExpNamed (fst $1) (srclocOf (snd $1)) } + { SizeExpNamed (fst $1) (srclocOf (snd $1)) } | intlit { let L loc (INTLIT n) = $1 - in DimExpConst (fromIntegral n) (srclocOf loc) } + in SizeExpConst (fromIntegral n) (srclocOf loc) } | - { DimExpAny } + { SizeExpAny } FunParam :: { PatBase NoInfo Name } FunParam : InnerPat { $1 } @@ -1000,13 +1000,13 @@ ArrayValue :: { Value } ArrayValue : '[' Value ']' {% pure $ ArrayValue (arrayFromList [$2]) $ - arrayOf Unique (ShapeDecl [1]) (valueType $2) + arrayOf Unique (Shape [1]) (valueType $2) } | '[' Value ',' Values ']' {% case combArrayElements $2 $4 of Left e -> throwError e Right v -> pure $ ArrayValue (arrayFromList $ $2:$4) $ - arrayOf Unique (ShapeDecl [1+fromIntegral (length $4)]) (valueType v) + arrayOf Unique (Shape [1+fromIntegral (length $4)]) (valueType v) } | id '(' ValueType ')' {% ($1 `mustBe` "empty") >> mustBeEmpty (srcspan $2 $4) $3 >> pure (ArrayValue (listArray (0,-1) []) $3) } @@ -1019,8 +1019,8 @@ Dim : intlit { let L _ (INTLIT num) = $1 in fromInteger num } ValueType :: { ValueType } -ValueType : '[' Dim ']' ValueType { arrayOf Nonunique (ShapeDecl [$2]) $4 } - | '[' Dim ']' PrimType { arrayOf Nonunique (ShapeDecl [$2]) (Scalar (Prim $4)) } +ValueType : '[' Dim ']' ValueType { arrayOf Nonunique (Shape [$2]) $4 } + | '[' Dim ']' PrimType { arrayOf Nonunique (Shape [$2]) (Scalar (Prim $4)) } Values :: { [Value] } Values : Value ',' Values { $1 : $3 } 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 @@ -94,41 +94,41 @@ ppr (BoolValue False) = text "false" ppr (FloatValue v) = ppr v -instance IsName vn => Pretty (DimDecl vn) where - ppr (AnyDim Nothing) = mempty - ppr (AnyDim (Just v)) = text "?" <> pprName v - ppr (NamedDim v) = ppr v - ppr (ConstDim n) = ppr n +instance Pretty Size where + ppr (AnySize Nothing) = mempty + ppr (AnySize (Just v)) = text "?" <> pprName v + ppr (NamedSize v) = ppr v + ppr (ConstSize n) = ppr n -instance IsName vn => Pretty (DimExp vn) where - ppr DimExpAny = mempty - ppr (DimExpNamed v _) = ppr v - ppr (DimExpConst n _) = ppr n +instance IsName vn => Pretty (SizeExp vn) where + ppr SizeExpAny = mempty + ppr (SizeExpNamed v _) = ppr v + ppr (SizeExpConst n _) = ppr n -instance IsName vn => Pretty (ShapeDecl (DimDecl vn)) where - ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds) +instance Pretty (Shape Size) where + ppr (Shape ds) = mconcat (map (brackets . ppr) ds) -instance Pretty (ShapeDecl ()) where - ppr (ShapeDecl ds) = mconcat $ replicate (length ds) $ text "[]" +instance Pretty (Shape ()) where + ppr (Shape ds) = mconcat $ replicate (length ds) $ text "[]" -instance Pretty (ShapeDecl Int64) where - ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds) +instance Pretty (Shape Int64) where + ppr (Shape ds) = mconcat (map (brackets . ppr) ds) -instance Pretty (ShapeDecl Bool) where - ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds) +instance Pretty (Shape Bool) where + ppr (Shape ds) = mconcat (map (brackets . ppr) ds) -instance Pretty (ShapeDecl dim) => Pretty (RetTypeBase dim as) where +instance Pretty (Shape dim) => Pretty (RetTypeBase dim as) where ppr = pprPrec 0 pprPrec p (RetType [] t) = pprPrec p t pprPrec _ (RetType dims t) = text "?" <> mconcat (map (brackets . pprName) dims) <> text "." <> ppr t -instance Pretty (ShapeDecl dim) => Pretty (ScalarTypeBase dim as) where +instance Pretty (Shape dim) => Pretty (ScalarTypeBase dim as) where ppr = pprPrec 0 pprPrec _ (Prim et) = ppr et - pprPrec p (TypeVar _ u et targs) = + pprPrec p (TypeVar _ u v targs) = parensIf (not (null targs) && p > 3) $ - ppr u <> ppr (qualNameFromTypeName et) <+> spread (map (pprPrec 3) targs) + ppr u <> ppr v <+> spread (map (pprPrec 3) targs) pprPrec _ (Record fs) | Just ts <- areTupleFields fs = oneLine (parens $ commasep $ map ppr ts) @@ -152,14 +152,14 @@ ppConstr (name, fs) = sep $ (text "#" <> ppr name) : map (pprPrec 2) fs cs' = map ppConstr $ M.toList cs -instance Pretty (ShapeDecl dim) => Pretty (TypeBase dim as) where +instance Pretty (Shape dim) => Pretty (TypeBase dim as) where ppr = pprPrec 0 pprPrec _ (Array _ u shape at) = ppr u <> ppr shape <> align (pprPrec 1 at) pprPrec p (Scalar t) = pprPrec p t -instance Pretty (ShapeDecl dim) => Pretty (TypeArg dim) where +instance Pretty (Shape dim) => Pretty (TypeArg dim) where ppr = pprPrec 0 - pprPrec _ (TypeArgDim d _) = ppr $ ShapeDecl [d] + pprPrec _ (TypeArgDim d _) = ppr $ Shape [d] pprPrec p (TypeArgType t _) = pprPrec p t instance (Eq vn, IsName vn) => Pretty (TypeExp vn) where @@ -201,12 +201,14 @@ instance (Eq vn, IsName vn, Annot f) => Pretty (DimIndexBase f vn) where ppr (DimFix e) = ppr e ppr (DimSlice i j (Just s)) = - maybe mempty ppr i <> text ":" + maybe mempty ppr i + <> text ":" <> maybe mempty ppr j <> text ":" <> ppr s ppr (DimSlice i (Just j) s) = - maybe mempty ppr i <> text ":" + maybe mempty ppr i + <> text ":" <> ppr j <> maybe mempty ((text ":" <>) . ppr) s ppr (DimSlice i Nothing Nothing) = @@ -230,9 +232,11 @@ text "loop" <+> align ( spread (map (brackets . pprName) sizeparams) - <+/> ppr pat <+> equals + <+/> ppr pat + <+> equals <+/> ppr initexp - <+/> ppr form <+> text "do" + <+/> ppr form + <+> text "do" ) indent 2 (ppr loopbody) pprPrec _ (Index e idxs _) = @@ -240,7 +244,9 @@ pprPrec p (LetPat sizes pat e body _) = parensIf (p /= -1) $ align $ - text "let" <+> spread (map ppr sizes) <+> align (ppr pat) + text "let" + <+> spread (map ppr sizes) + <+> align (ppr pat) <+> ( if linebreak then equals indent 2 (ppr e) else equals <+> align (ppr e) @@ -253,8 +259,11 @@ ArrayLit {} -> False _ -> hasArrayLit e pprPrec _ (LetFun fname (tparams, params, retdecl, rettype, e) body _) = - text "let" <+> pprName fname <+> spread (map ppr tparams ++ map ppr params) - <> retdecl' <+> equals + text "let" + <+> pprName fname + <+> spread (map ppr tparams ++ map ppr params) + <> retdecl' + <+> equals indent 2 (ppr e) letBody body where @@ -263,12 +272,16 @@ Nothing -> mempty pprPrec _ (LetWith dest src idxs ve body _) | dest == src = - text "let" <+> ppr dest <> list (map ppr idxs) + text "let" + <+> ppr dest <> list (map ppr idxs) <+> equals <+> align (ppr ve) letBody body | otherwise = - text "let" <+> ppr dest <+> equals <+> ppr src + text "let" + <+> ppr dest + <+> equals + <+> ppr src <+> text "with" <+> brackets (commasep (map ppr idxs)) <+> text "=" @@ -283,9 +296,12 @@ ToInclusive end' -> text "..." <> ppr end' UpToExclusive end' -> text "..<" <> ppr end' pprPrec _ (If c t f _) = - text "if" <+> ppr c - text "then" <+> align (ppr t) - text "else" <+> align (ppr f) + text "if" + <+> ppr c + text "then" + <+> align (ppr t) + text "else" + <+> align (ppr f) pprPrec p (Apply f arg _ _) = parensIf (p >= 10) $ pprPrec 0 f <+/> pprPrec 10 arg @@ -335,12 +351,14 @@ pprPrec _ (Negate e _) = text "-" <> ppr e pprPrec _ (Not e _) = text "-" <> ppr e pprPrec _ (Update src idxs ve _) = - ppr src <+> text "with" + ppr src + <+> text "with" <+> brackets (commasep (map ppr idxs)) <+> text "=" <+> align (ppr ve) pprPrec _ (RecordUpdate src fs ve _ _) = - ppr src <+> text "with" + ppr src + <+> text "with" <+> mconcat (intersperse (text ".") (map ppr fs)) <+> text "=" <+> align (ppr ve) @@ -348,7 +366,8 @@ pprPrec p (Lambda params body rettype _ _) = parensIf (p /= -1) $ text "\\" <> spread (map ppr params) <> ppAscription rettype - <+> text "->" indent 2 (ppr body) + <+> text "->" + indent 2 (ppr body) pprPrec _ (OpSection binop _ _) = parens $ ppr binop pprPrec _ (OpSectionLeft binop _ x _ _ _) = @@ -436,7 +455,8 @@ ppr (ModAscript me se _ _) = ppr me <> colon <+> ppr se ppr (ModLambda param maybe_sig body _) = text "\\" <> ppr param <> maybe_sig' - <+> text "->" indent 2 (ppr body) + <+> text "->" + indent 2 (ppr body) where maybe_sig' = case maybe_sig of Nothing -> mempty @@ -449,7 +469,8 @@ instance (Eq vn, IsName vn, Annot f) => Pretty (TypeBindBase f vn) where ppr (TypeBind name l params te rt _ _) = - text "type" <> ppr l <+> pprName name + text "type" <> ppr l + <+> pprName name <+> spread (map ppr params) <+> equals <+> maybe (ppr te) ppr (unAnnot rt) @@ -464,8 +485,8 @@ <> text fun <+> pprName name <+> align (sep (map ppr tparams ++ map ppr args)) - <> retdecl' - <> text " =" + <> retdecl' + <> text " =" indent 2 (ppr body) where fun diff --git a/src/Language/Futhark/Primitive.hs b/src/Language/Futhark/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Language/Futhark/Primitive.hs @@ -0,0 +1,1873 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | Definitions of primitive types, the values that inhabit these +-- types, and operations on these values. A primitive value can also +-- be called a scalar. +-- +-- This module diverges from the actual Futhark language in that it +-- does not distinguish signed and unsigned types. Further, we allow +-- a "unit" type that is only indirectly present in source Futhark in +-- the form of empty tuples. +module Language.Futhark.Primitive + ( -- * Types + IntType (..), + allIntTypes, + FloatType (..), + allFloatTypes, + PrimType (..), + allPrimTypes, + module Data.Int, + module Data.Word, + Half, + + -- * Values + IntValue (..), + intValue, + intValueType, + valueIntegral, + FloatValue (..), + floatValue, + floatValueType, + PrimValue (..), + primValueType, + blankPrimValue, + + -- * Operations + Overflow (..), + Safety (..), + UnOp (..), + allUnOps, + BinOp (..), + allBinOps, + ConvOp (..), + allConvOps, + CmpOp (..), + allCmpOps, + + -- ** Unary Operations + doUnOp, + doComplement, + doAbs, + doFAbs, + doSSignum, + doUSignum, + + -- ** Binary Operations + doBinOp, + doAdd, + doMul, + doSDiv, + doSMod, + doPow, + + -- ** Conversion Operations + doConvOp, + doZExt, + doSExt, + doFPConv, + doFPToUI, + doFPToSI, + doUIToFP, + doSIToFP, + intToInt64, + intToWord64, + flipConvOp, + + -- * Comparison Operations + doCmpOp, + doCmpEq, + doCmpUlt, + doCmpUle, + doCmpSlt, + doCmpSle, + doFCmpLt, + doFCmpLe, + + -- * Type Of + binOpType, + unOpType, + cmpOpType, + convOpType, + + -- * Primitive functions + primFuns, + + -- * Utility + zeroIsh, + zeroIshInt, + oneIsh, + oneIshInt, + negativeIsh, + primBitSize, + primByteSize, + intByteSize, + floatByteSize, + commutativeBinOp, + associativeBinOp, + + -- * Prettyprinting + convOpFun, + prettySigned, + ) +where + +import Control.Category +import qualified Data.Binary.Get as G +import qualified Data.Binary.Put as P +import Data.Bits + ( complement, + countLeadingZeros, + countTrailingZeros, + popCount, + shift, + shiftR, + xor, + (.&.), + (.|.), + ) +import Data.Fixed (mod') -- Weird location. +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Map as M +import Data.Word (Word16, Word32, Word64, Word8) +import Foreign.C.Types (CUShort (..)) +import Futhark.Util + ( cbrt, + cbrtf, + ceilDouble, + ceilFloat, + convFloat, + erf, + erfc, + erfcf, + erff, + floorDouble, + floorFloat, + hypot, + hypotf, + lgamma, + lgammaf, + roundDouble, + roundFloat, + tgamma, + tgammaf, + ) +import Futhark.Util.Pretty +import Numeric.Half +import Prelude hiding (id, (.)) + +-- | An integer type, ordered by size. Note that signedness is not a +-- property of the type, but a property of the operations performed on +-- values of these types. +data IntType + = Int8 + | Int16 + | Int32 + | Int64 + deriving (Eq, Ord, Show, Enum, Bounded) + +instance Pretty IntType where + ppr Int8 = text "i8" + ppr Int16 = text "i16" + ppr Int32 = text "i32" + ppr Int64 = text "i64" + +-- | A list of all integer types. +allIntTypes :: [IntType] +allIntTypes = [minBound .. maxBound] + +-- | A floating point type. +data FloatType + = 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" + +-- | A list of all floating-point types. +allFloatTypes :: [FloatType] +allFloatTypes = [minBound .. maxBound] + +-- | Low-level primitive types. +data PrimType + = IntType IntType + | FloatType FloatType + | Bool + | -- | An informationless type - An array of this type takes up no space. + Unit + deriving (Eq, Ord, Show) + +instance Enum PrimType where + toEnum 0 = IntType Int8 + toEnum 1 = IntType Int16 + toEnum 2 = IntType Int32 + toEnum 3 = IntType Int64 + 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 Float16) = 4 + fromEnum (FloatType Float32) = 5 + fromEnum (FloatType Float64) = 6 + fromEnum Bool = 7 + fromEnum Unit = 8 + +instance Bounded PrimType where + minBound = IntType Int8 + maxBound = Unit + +instance Pretty PrimType where + ppr (IntType t) = ppr t + ppr (FloatType t) = ppr t + ppr Bool = text "bool" + ppr Unit = text "unit" + +-- | A list of all primitive types. +allPrimTypes :: [PrimType] +allPrimTypes = + map IntType allIntTypes + ++ map FloatType allFloatTypes + ++ [Bool, Unit] + +-- | An integer value. +data IntValue + = Int8Value !Int8 + | Int16Value !Int16 + | Int32Value !Int32 + | Int64Value !Int64 + deriving (Eq, Ord, Show) + +instance Pretty IntValue where + ppr (Int8Value v) = text $ show v ++ "i8" + ppr (Int16Value v) = text $ show v ++ "i16" + ppr (Int32Value v) = text $ show v ++ "i32" + ppr (Int64Value v) = text $ show v ++ "i64" + +-- | Create an t'IntValue' from a type and an 'Integer'. +intValue :: Integral int => IntType -> int -> IntValue +intValue Int8 = Int8Value . fromIntegral +intValue Int16 = Int16Value . fromIntegral +intValue Int32 = Int32Value . fromIntegral +intValue Int64 = Int64Value . fromIntegral + +-- | The type of an integer value. +intValueType :: IntValue -> IntType +intValueType Int8Value {} = Int8 +intValueType Int16Value {} = Int16 +intValueType Int32Value {} = Int32 +intValueType Int64Value {} = Int64 + +-- | Convert an t'IntValue' to any 'Integral' type. +valueIntegral :: Integral int => IntValue -> int +valueIntegral (Int8Value v) = fromIntegral v +valueIntegral (Int16Value v) = fromIntegral v +valueIntegral (Int32Value v) = fromIntegral v +valueIntegral (Int64Value v) = fromIntegral v + +-- | A floating-point value. +data FloatValue + = 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 + _ == _ = 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" + | isNaN v = text "f32.nan" + | otherwise = text $ show v ++ "f32" + ppr (Float64Value v) + | isInfinite v, v >= 0 = text "f64.inf" + | isInfinite v, v < 0 = text "-f64.inf" + | isNaN v = text "f64.nan" + | otherwise = text $ show v ++ "f64" + +-- | 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 + +-- | Non-array values. +data PrimValue + = IntValue !IntValue + | FloatValue !FloatValue + | BoolValue !Bool + | -- | The only value of type 'Unit'. + UnitValue + deriving (Eq, Ord, Show) + +instance Pretty PrimValue where + ppr (IntValue v) = ppr v + ppr (BoolValue True) = text "true" + ppr (BoolValue False) = text "false" + ppr (FloatValue v) = ppr v + ppr UnitValue = text "()" + +-- | The type of a basic value. +primValueType :: PrimValue -> PrimType +primValueType (IntValue v) = IntType $ intValueType v +primValueType (FloatValue v) = FloatType $ floatValueType v +primValueType BoolValue {} = Bool +primValueType UnitValue = Unit + +-- | A "blank" value of the given primitive type - this is zero, or +-- whatever is close to it. Don't depend on this value, but use it +-- for e.g. creating arrays to be populated by do-loops. +blankPrimValue :: PrimType -> PrimValue +blankPrimValue (IntType Int8) = IntValue $ Int8Value 0 +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 +blankPrimValue Unit = UnitValue + +-- | Various unary operators. It is a bit ad-hoc what is a unary +-- operator and what is a built-in function. Perhaps these should all +-- go away eventually. +data UnOp + = -- | E.g., @! True == False@. + Not + | -- | E.g., @~(~1) = 1@. + Complement IntType + | -- | @abs(-2) = 2@. + Abs IntType + | -- | @fabs(-2.0) = 2.0@. + FAbs FloatType + | -- | Signed sign function: @ssignum(-2)@ = -1. + SSignum IntType + | -- | Unsigned sign function: @usignum(2)@ = 1. + USignum IntType + | -- | Floating-point sign function. + FSignum FloatType + deriving (Eq, Ord, Show) + +-- | What to do in case of arithmetic overflow. Futhark's semantics +-- are that overflow does wraparound, but for generated code (like +-- address arithmetic), it can be beneficial for overflow to be +-- undefined behaviour, as it allows better optimisation of things +-- such as GPU kernels. +-- +-- Note that all values of this type are considered equal for 'Eq' and +-- 'Ord'. +data Overflow = OverflowWrap | OverflowUndef + deriving (Show) + +instance Eq Overflow where + _ == _ = True + +instance Ord Overflow where + _ `compare` _ = EQ + +-- | Whether something is safe or unsafe (mostly function calls, and +-- in the context of whether operations are dynamically checked). +-- When we inline an 'Unsafe' function, we remove all safety checks in +-- its body. The 'Ord' instance picks 'Unsafe' as being less than +-- 'Safe'. +-- +-- For operations like integer division, a safe division will not +-- explode the computer in case of division by zero, but instead +-- return some unspecified value. This always involves a run-time +-- check, so generally the unsafe variant is what the compiler will +-- insert, but guarded by an explicit assertion elsewhere. Safe +-- operations are useful when the optimiser wants to move e.g. a +-- division to a location where the divisor may be zero, but where the +-- result will only be used when it is non-zero (so it doesn't matter +-- what result is provided with a zero divisor, as long as the program +-- keeps running). +data Safety = Unsafe | Safe deriving (Eq, Ord, Show) + +-- | Binary operators. These correspond closely to the binary operators in +-- LLVM. Most are parametrised by their expected input and output +-- types. +data BinOp + = -- | Integer addition. + Add IntType Overflow + | -- | Floating-point addition. + FAdd FloatType + | -- | Integer subtraction. + Sub IntType Overflow + | -- | Floating-point subtraction. + FSub FloatType + | -- | Integer multiplication. + Mul IntType Overflow + | -- | Floating-point multiplication. + FMul FloatType + | -- | Unsigned integer division. Rounds towards + -- negativity infinity. Note: this is different + -- from LLVM. + UDiv IntType Safety + | -- | Unsigned integer division. Rounds towards positive + -- infinity. + UDivUp IntType Safety + | -- | Signed integer division. Rounds towards + -- negativity infinity. Note: this is different + -- from LLVM. + SDiv IntType Safety + | -- | Signed integer division. Rounds towards positive + -- infinity. + SDivUp IntType Safety + | -- | Floating-point division. + FDiv FloatType + | -- | Floating-point modulus. + FMod FloatType + | -- | Unsigned integer modulus; the countepart to 'UDiv'. + UMod IntType Safety + | -- | Signed integer modulus; the countepart to 'SDiv'. + SMod IntType Safety + | -- | Signed integer division. Rounds towards zero. This + -- corresponds to the @sdiv@ instruction in LLVM and + -- integer division in C. + SQuot IntType Safety + | -- | Signed integer division. Rounds towards zero. This + -- corresponds to the @srem@ instruction in LLVM and + -- integer modulo in C. + SRem IntType Safety + | -- | Returns the smallest of two signed integers. + SMin IntType + | -- | Returns the smallest of two unsigned integers. + UMin IntType + | -- | Returns the smallest of two floating-point numbers. + FMin FloatType + | -- | Returns the greatest of two signed integers. + SMax IntType + | -- | Returns the greatest of two unsigned integers. + UMax IntType + | -- | Returns the greatest of two floating-point numbers. + FMax FloatType + | -- | Left-shift. + Shl IntType + | -- | Logical right-shift, zero-extended. + LShr IntType + | -- | Arithmetic right-shift, sign-extended. + AShr IntType + | -- | Bitwise and. + And IntType + | -- | Bitwise or. + Or IntType + | -- | Bitwise exclusive-or. + Xor IntType + | -- | Integer exponentiation. + Pow IntType + | -- | Floating-point exponentiation. + FPow FloatType + | -- | Boolean and - not short-circuiting. + LogAnd + | -- | Boolean or - not short-circuiting. + LogOr + deriving (Eq, Ord, Show) + +-- | Comparison operators are like 'BinOp's, but they always return a +-- boolean value. The somewhat ugly constructor names are straight +-- out of LLVM. +data CmpOp + = -- | All types equality. + CmpEq PrimType + | -- | Unsigned less than. + CmpUlt IntType + | -- | Unsigned less than or equal. + CmpUle IntType + | -- | Signed less than. + CmpSlt IntType + | -- | Signed less than or equal. + CmpSle IntType + | -- Comparison operators for floating-point values. TODO: extend + -- this to handle NaNs and such, like the LLVM fcmp instruction. + + -- | Floating-point less than. + FCmpLt FloatType + | -- | Floating-point less than or equal. + FCmpLe FloatType + | -- Boolean comparison. + + -- | Boolean less than. + CmpLlt + | -- | Boolean less than or equal. + CmpLle + deriving (Eq, Ord, Show) + +-- | Conversion operators try to generalise the @from t0 x to t1@ +-- instructions from LLVM. +data ConvOp + = -- | Zero-extend the former integer type to the latter. + -- If the new type is smaller, the result is a + -- truncation. + ZExt IntType IntType + | -- | Sign-extend the former integer type to the latter. + -- If the new type is smaller, the result is a + -- truncation. + SExt IntType IntType + | -- | Convert value of the former floating-point type to + -- the latter. If the new type is smaller, the result + -- is a truncation. + FPConv FloatType FloatType + | -- | Convert a floating-point value to the nearest + -- unsigned integer (rounding towards zero). + FPToUI FloatType IntType + | -- | Convert a floating-point value to the nearest + -- signed integer (rounding towards zero). + FPToSI FloatType IntType + | -- | Convert an unsigned integer to a floating-point value. + UIToFP IntType FloatType + | -- | Convert a signed integer to a floating-point value. + SIToFP IntType FloatType + | -- | Convert an integer to a boolean value. Zero + -- becomes false; anything else is true. + IToB IntType + | -- | Convert a boolean to an integer. True is converted + -- to 1 and False to 0. + BToI IntType + | -- | Convert a float to a boolean value. Zero becomes false; + -- | anything else is true. + FToB FloatType + | -- | Convert a boolean to a float. True is converted + -- to 1 and False to 0. + BToF FloatType + deriving (Eq, Ord, Show) + +-- | A list of all unary operators for all types. +allUnOps :: [UnOp] +allUnOps = + Not + : map Complement [minBound .. maxBound] + ++ map Abs [minBound .. maxBound] + ++ map FAbs [minBound .. maxBound] + ++ map SSignum [minBound .. maxBound] + ++ map USignum [minBound .. maxBound] + ++ map FSignum [minBound .. maxBound] + +-- | A list of all binary operators for all types. +allBinOps :: [BinOp] +allBinOps = + concat + [ Add <$> allIntTypes <*> [OverflowWrap, OverflowUndef], + map FAdd allFloatTypes, + Sub <$> allIntTypes <*> [OverflowWrap, OverflowUndef], + map FSub allFloatTypes, + Mul <$> allIntTypes <*> [OverflowWrap, OverflowUndef], + map FMul allFloatTypes, + UDiv <$> allIntTypes <*> [Unsafe, Safe], + UDivUp <$> allIntTypes <*> [Unsafe, Safe], + SDiv <$> allIntTypes <*> [Unsafe, Safe], + SDivUp <$> allIntTypes <*> [Unsafe, Safe], + map FDiv allFloatTypes, + map FMod allFloatTypes, + UMod <$> allIntTypes <*> [Unsafe, Safe], + SMod <$> allIntTypes <*> [Unsafe, Safe], + SQuot <$> allIntTypes <*> [Unsafe, Safe], + SRem <$> allIntTypes <*> [Unsafe, Safe], + map SMin allIntTypes, + map UMin allIntTypes, + map FMin allFloatTypes, + map SMax allIntTypes, + map UMax allIntTypes, + map FMax allFloatTypes, + map Shl allIntTypes, + map LShr allIntTypes, + map AShr allIntTypes, + map And allIntTypes, + map Or allIntTypes, + map Xor allIntTypes, + map Pow allIntTypes, + map FPow allFloatTypes, + [LogAnd, LogOr] + ] + +-- | A list of all comparison operators for all types. +allCmpOps :: [CmpOp] +allCmpOps = + concat + [ map CmpEq allPrimTypes, + map CmpUlt allIntTypes, + map CmpUle allIntTypes, + map CmpSlt allIntTypes, + map CmpSle allIntTypes, + map FCmpLt allFloatTypes, + map FCmpLe allFloatTypes, + [CmpLlt, CmpLle] + ] + +-- | A list of all conversion operators for all types. +allConvOps :: [ConvOp] +allConvOps = + concat + [ ZExt <$> allIntTypes <*> allIntTypes, + SExt <$> allIntTypes <*> allIntTypes, + FPConv <$> allFloatTypes <*> allFloatTypes, + FPToUI <$> allFloatTypes <*> allIntTypes, + FPToSI <$> allFloatTypes <*> allIntTypes, + UIToFP <$> allIntTypes <*> allFloatTypes, + SIToFP <$> allIntTypes <*> allFloatTypes, + IToB <$> allIntTypes, + BToI <$> allIntTypes, + FToB <$> allFloatTypes, + BToF <$> allFloatTypes + ] + +-- | Apply an 'UnOp' to an operand. Returns 'Nothing' if the +-- application is mistyped. +doUnOp :: UnOp -> PrimValue -> Maybe PrimValue +doUnOp Not (BoolValue b) = Just $ BoolValue $ not b +doUnOp Complement {} (IntValue v) = Just $ IntValue $ doComplement v +doUnOp Abs {} (IntValue v) = Just $ IntValue $ doAbs v +doUnOp FAbs {} (FloatValue v) = Just $ FloatValue $ doFAbs v +doUnOp SSignum {} (IntValue v) = Just $ IntValue $ doSSignum v +doUnOp USignum {} (IntValue v) = Just $ IntValue $ doUSignum v +doUnOp FSignum {} (FloatValue v) = Just $ FloatValue $ doFSignum v +doUnOp _ _ = Nothing + +-- | E.g., @~(~1) = 1@. +doComplement :: IntValue -> IntValue +doComplement v = intValue (intValueType v) $ complement $ intToInt64 v + +-- | @abs(-2) = 2@. +doAbs :: IntValue -> IntValue +doAbs v = intValue (intValueType v) $ abs $ intToInt64 v + +-- | @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 + +-- | @ssignum(-2)@ = -1. +doSSignum :: IntValue -> IntValue +doSSignum v = intValue (intValueType v) $ signum $ intToInt64 v + +-- | @usignum(-2)@ = -1. +doUSignum :: IntValue -> IntValue +doUSignum v = intValue (intValueType v) $ signum $ intToWord64 v + +-- | @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 + +-- | Apply a 'BinOp' to an operand. Returns 'Nothing' if the +-- application is mistyped, or outside the domain (e.g. division by +-- zero). +doBinOp :: BinOp -> PrimValue -> PrimValue -> Maybe PrimValue +doBinOp Add {} = doIntBinOp doAdd +doBinOp FAdd {} = doFloatBinOp (+) (+) (+) +doBinOp Sub {} = doIntBinOp doSub +doBinOp FSub {} = doFloatBinOp (-) (-) (-) +doBinOp Mul {} = doIntBinOp doMul +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' 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 fmin fmin fmin + where + fmin x y + | isNaN x = y + | isNaN y = x + | otherwise = min x y +doBinOp SMax {} = doIntBinOp doSMax +doBinOp UMax {} = doIntBinOp doUMax +doBinOp FMax {} = doFloatBinOp fmax fmax fmax + where + fmax x y + | isNaN x = y + | isNaN y = x + | otherwise = max x y +doBinOp Shl {} = doIntBinOp doShl +doBinOp LShr {} = doIntBinOp doLShr +doBinOp AShr {} = doIntBinOp doAShr +doBinOp And {} = doIntBinOp doAnd +doBinOp Or {} = doIntBinOp doOr +doBinOp Xor {} = doIntBinOp doXor +doBinOp Pow {} = doRiskyIntBinOp doPow +doBinOp FPow {} = doFloatBinOp (**) (**) (**) +doBinOp LogAnd {} = doBoolBinOp (&&) +doBinOp LogOr {} = doBoolBinOp (||) + +doIntBinOp :: + (IntValue -> IntValue -> IntValue) -> + PrimValue -> + PrimValue -> + Maybe PrimValue +doIntBinOp f (IntValue v1) (IntValue v2) = + Just $ IntValue $ f v1 v2 +doIntBinOp _ _ _ = Nothing + +doRiskyIntBinOp :: + (IntValue -> IntValue -> Maybe IntValue) -> + PrimValue -> + PrimValue -> + Maybe PrimValue +doRiskyIntBinOp f (IntValue v1) (IntValue v2) = + IntValue <$> f v1 v2 +doRiskyIntBinOp _ _ _ = Nothing + +doFloatBinOp :: + (Half -> Half -> Half) -> + (Float -> Float -> Float) -> + (Double -> Double -> Double) -> + PrimValue -> + PrimValue -> + Maybe PrimValue +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)) = + Just $ FloatValue $ Float64Value $ f64 v1 v2 +doFloatBinOp _ _ _ _ _ = Nothing + +doBoolBinOp :: + (Bool -> Bool -> Bool) -> + PrimValue -> + PrimValue -> + Maybe PrimValue +doBoolBinOp f (BoolValue v1) (BoolValue v2) = + Just $ BoolValue $ f v1 v2 +doBoolBinOp _ _ _ = Nothing + +-- | Integer addition. +doAdd :: IntValue -> IntValue -> IntValue +doAdd v1 v2 = intValue (intValueType v1) $ intToInt64 v1 + intToInt64 v2 + +-- | Integer subtraction. +doSub :: IntValue -> IntValue -> IntValue +doSub v1 v2 = intValue (intValueType v1) $ intToInt64 v1 - intToInt64 v2 + +-- | Integer multiplication. +doMul :: IntValue -> IntValue -> IntValue +doMul v1 v2 = intValue (intValueType v1) $ intToInt64 v1 * intToInt64 v2 + +-- | Unsigned integer division. Rounds towards negativity infinity. +-- Note: this is different from LLVM. +doUDiv :: IntValue -> IntValue -> Maybe IntValue +doUDiv v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = + Just . intValue (intValueType v1) $ + intToWord64 v1 `div` intToWord64 v2 + +-- | Unsigned integer division. Rounds towards positive infinity. +doUDivUp :: IntValue -> IntValue -> Maybe IntValue +doUDivUp v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = + Just . intValue (intValueType v1) $ + (intToWord64 v1 + intToWord64 v2 - 1) `div` intToWord64 v2 + +-- | Signed integer division. Rounds towards negativity infinity. +-- Note: this is different from LLVM. +doSDiv :: IntValue -> IntValue -> Maybe IntValue +doSDiv v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = + Just $ + intValue (intValueType v1) $ + intToInt64 v1 `div` intToInt64 v2 + +-- | Signed integer division. Rounds towards positive infinity. +doSDivUp :: IntValue -> IntValue -> Maybe IntValue +doSDivUp v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = + Just . intValue (intValueType v1) $ + (intToInt64 v1 + intToInt64 v2 - 1) `div` intToInt64 v2 + +-- | Unsigned integer modulus; the countepart to 'UDiv'. +doUMod :: IntValue -> IntValue -> Maybe IntValue +doUMod v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToWord64 v1 `mod` intToWord64 v2 + +-- | Signed integer modulus; the countepart to 'SDiv'. +doSMod :: IntValue -> IntValue -> Maybe IntValue +doSMod v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `mod` intToInt64 v2 + +-- | Signed integer division. Rounds towards zero. +-- This corresponds to the @sdiv@ instruction in LLVM. +doSQuot :: IntValue -> IntValue -> Maybe IntValue +doSQuot v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `quot` intToInt64 v2 + +-- | Signed integer division. Rounds towards zero. +-- This corresponds to the @srem@ instruction in LLVM. +doSRem :: IntValue -> IntValue -> Maybe IntValue +doSRem v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `rem` intToInt64 v2 + +-- | Minimum of two signed integers. +doSMin :: IntValue -> IntValue -> IntValue +doSMin v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `min` intToInt64 v2 + +-- | Minimum of two unsigned integers. +doUMin :: IntValue -> IntValue -> IntValue +doUMin v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `min` intToWord64 v2 + +-- | Maximum of two signed integers. +doSMax :: IntValue -> IntValue -> IntValue +doSMax v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `max` intToInt64 v2 + +-- | Maximum of two unsigned integers. +doUMax :: IntValue -> IntValue -> IntValue +doUMax v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `max` intToWord64 v2 + +-- | Left-shift. +doShl :: IntValue -> IntValue -> IntValue +doShl v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` intToInt v2 + +-- | Logical right-shift, zero-extended. +doLShr :: IntValue -> IntValue -> IntValue +doLShr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `shift` negate (intToInt v2) + +-- | Arithmetic right-shift, sign-extended. +doAShr :: IntValue -> IntValue -> IntValue +doAShr v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` negate (intToInt v2) + +-- | Bitwise and. +doAnd :: IntValue -> IntValue -> IntValue +doAnd v1 v2 = intValue (intValueType v1) $ intToWord64 v1 .&. intToWord64 v2 + +-- | Bitwise or. +doOr :: IntValue -> IntValue -> IntValue +doOr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 .|. intToWord64 v2 + +-- | Bitwise exclusive-or. +doXor :: IntValue -> IntValue -> IntValue +doXor v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `xor` intToWord64 v2 + +-- | Signed integer exponentatation. +doPow :: IntValue -> IntValue -> Maybe IntValue +doPow v1 v2 + | negativeIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 ^ intToInt64 v2 + +-- | Apply a 'ConvOp' to an operand. Returns 'Nothing' if the +-- application is mistyped. +doConvOp :: ConvOp -> PrimValue -> Maybe PrimValue +doConvOp (ZExt _ to) (IntValue v) = Just $ IntValue $ doZExt v to +doConvOp (SExt _ to) (IntValue v) = Just $ IntValue $ doSExt v to +doConvOp (FPConv _ to) (FloatValue v) = Just $ FloatValue $ doFPConv v to +doConvOp (FPToUI _ to) (FloatValue v) = Just $ IntValue $ doFPToUI v to +doConvOp (FPToSI _ to) (FloatValue v) = Just $ IntValue $ doFPToSI v to +doConvOp (UIToFP _ to) (IntValue v) = Just $ FloatValue $ doUIToFP v to +doConvOp (SIToFP _ to) (IntValue v) = Just $ FloatValue $ doSIToFP v to +doConvOp (IToB _) (IntValue v) = Just $ BoolValue $ intToInt64 v /= 0 +doConvOp (BToI to) (BoolValue v) = Just $ IntValue $ intValue to $ if v then 1 else 0 :: Int +doConvOp (FToB _) (FloatValue v) = Just $ BoolValue $ floatToDouble v /= 0 +doConvOp (BToF to) (BoolValue v) = Just $ FloatValue $ floatValue to $ if v then 1 else 0 :: Double +doConvOp _ _ = Nothing + +-- | Turn the conversion the other way around. Note that most +-- conversions are lossy, so there is no guarantee the value will +-- round-trip. +flipConvOp :: ConvOp -> ConvOp +flipConvOp (ZExt from to) = ZExt to from +flipConvOp (SExt from to) = SExt to from +flipConvOp (FPConv from to) = FPConv to from +flipConvOp (FPToUI from to) = UIToFP to from +flipConvOp (FPToSI from to) = SIToFP to from +flipConvOp (UIToFP from to) = FPToSI to from +flipConvOp (SIToFP from to) = FPToSI to from +flipConvOp (IToB from) = BToI from +flipConvOp (BToI to) = IToB to +flipConvOp (FToB from) = BToF from +flipConvOp (BToF to) = FToB to + +-- | Zero-extend the given integer value to the size of the given +-- type. If the type is smaller than the given value, the result is a +-- truncation. +doZExt :: IntValue -> IntType -> IntValue +doZExt (Int8Value x) t = intValue t $ toInteger (fromIntegral x :: Word8) +doZExt (Int16Value x) t = intValue t $ toInteger (fromIntegral x :: Word16) +doZExt (Int32Value x) t = intValue t $ toInteger (fromIntegral x :: Word32) +doZExt (Int64Value x) t = intValue t $ toInteger (fromIntegral x :: Word64) + +-- | Sign-extend the given integer value to the size of the given +-- type. If the type is smaller than the given value, the result is a +-- truncation. +doSExt :: IntValue -> IntType -> IntValue +doSExt (Int8Value x) t = intValue t $ toInteger x +doSExt (Int16Value x) t = intValue t $ toInteger x +doSExt (Int32Value x) t = intValue t $ toInteger x +doSExt (Int64Value x) t = intValue t $ toInteger x + +-- | 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 + +-- | Convert a floating-point value to the nearest +-- unsigned integer (rounding towards zero). +doFPToUI :: FloatValue -> IntType -> IntValue +doFPToUI v t = intValue t (truncate $ floatToDouble v :: Word64) + +-- | Convert a floating-point value to the nearest +-- signed integer (rounding towards zero). +doFPToSI :: FloatValue -> IntType -> IntValue +doFPToSI v t = intValue t (truncate $ floatToDouble v :: Word64) + +-- | Convert an unsigned integer to a floating-point value. +doUIToFP :: IntValue -> FloatType -> FloatValue +doUIToFP v t = floatValue t $ intToWord64 v + +-- | Convert a signed integer to a floating-point value. +doSIToFP :: IntValue -> FloatType -> FloatValue +doSIToFP v t = floatValue t $ intToInt64 v + +-- | Apply a 'CmpOp' to an operand. Returns 'Nothing' if the +-- application is mistyped. +doCmpOp :: CmpOp -> PrimValue -> PrimValue -> Maybe Bool +doCmpOp CmpEq {} v1 v2 = Just $ doCmpEq v1 v2 +doCmpOp CmpUlt {} (IntValue v1) (IntValue v2) = Just $ doCmpUlt v1 v2 +doCmpOp CmpUle {} (IntValue v1) (IntValue v2) = Just $ doCmpUle v1 v2 +doCmpOp CmpSlt {} (IntValue v1) (IntValue v2) = Just $ doCmpSlt v1 v2 +doCmpOp CmpSle {} (IntValue v1) (IntValue v2) = Just $ doCmpSle v1 v2 +doCmpOp FCmpLt {} (FloatValue v1) (FloatValue v2) = Just $ doFCmpLt v1 v2 +doCmpOp FCmpLe {} (FloatValue v1) (FloatValue v2) = Just $ doFCmpLe v1 v2 +doCmpOp CmpLlt {} (BoolValue v1) (BoolValue v2) = Just $ not v1 && v2 +doCmpOp CmpLle {} (BoolValue v1) (BoolValue v2) = Just $ not (v1 && not v2) +doCmpOp _ _ _ = Nothing + +-- | Compare any two primtive values for exact equality. +doCmpEq :: PrimValue -> PrimValue -> Bool +doCmpEq (FloatValue (Float32Value v1)) (FloatValue (Float32Value v2)) = v1 == v2 +doCmpEq (FloatValue (Float64Value v1)) (FloatValue (Float64Value v2)) = v1 == v2 +doCmpEq v1 v2 = v1 == v2 + +-- | Unsigned less than. +doCmpUlt :: IntValue -> IntValue -> Bool +doCmpUlt v1 v2 = intToWord64 v1 < intToWord64 v2 + +-- | Unsigned less than or equal. +doCmpUle :: IntValue -> IntValue -> Bool +doCmpUle v1 v2 = intToWord64 v1 <= intToWord64 v2 + +-- | Signed less than. +doCmpSlt :: IntValue -> IntValue -> Bool +doCmpSlt = (<) + +-- | Signed less than or equal. +doCmpSle :: IntValue -> IntValue -> Bool +doCmpSle = (<=) + +-- | Floating-point less than. +doFCmpLt :: FloatValue -> FloatValue -> Bool +doFCmpLt = (<) + +-- | Floating-point less than or equal. +doFCmpLe :: FloatValue -> FloatValue -> Bool +doFCmpLe = (<=) + +-- | Translate an t'IntValue' to 'Word64'. This is guaranteed to fit. +intToWord64 :: IntValue -> Word64 +intToWord64 (Int8Value v) = fromIntegral (fromIntegral v :: Word8) +intToWord64 (Int16Value v) = fromIntegral (fromIntegral v :: Word16) +intToWord64 (Int32Value v) = fromIntegral (fromIntegral v :: Word32) +intToWord64 (Int64Value v) = fromIntegral (fromIntegral v :: Word64) + +-- | Translate an t'IntValue' to t'Int64'. This is guaranteed to fit. +intToInt64 :: IntValue -> Int64 +intToInt64 (Int8Value v) = fromIntegral v +intToInt64 (Int16Value v) = fromIntegral v +intToInt64 (Int32Value v) = fromIntegral v +intToInt64 (Int64Value v) = fromIntegral v + +-- | Careful - there is no guarantee this will fit. +intToInt :: IntValue -> Int +intToInt = fromIntegral . intToInt64 + +floatToDouble :: FloatValue -> Double +floatToDouble (Float16Value v) + | isInfinite v, v > 0 = 1 / 0 + | 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 + | isNaN v = 0 / 0 + | otherwise = fromRational $ toRational v +floatToDouble (Float64Value v) = v + +floatToFloat :: FloatValue -> Float +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 +binOpType (Sub t _) = IntType t +binOpType (Mul t _) = IntType t +binOpType (SDiv t _) = IntType t +binOpType (SDivUp t _) = IntType t +binOpType (SMod t _) = IntType t +binOpType (SQuot t _) = IntType t +binOpType (SRem t _) = IntType t +binOpType (UDiv t _) = IntType t +binOpType (UDivUp t _) = IntType t +binOpType (UMod t _) = IntType t +binOpType (SMin t) = IntType t +binOpType (UMin t) = IntType t +binOpType (FMin t) = FloatType t +binOpType (SMax t) = IntType t +binOpType (UMax t) = IntType t +binOpType (FMax t) = FloatType t +binOpType (Shl t) = IntType t +binOpType (LShr t) = IntType t +binOpType (AShr t) = IntType t +binOpType (And t) = IntType t +binOpType (Or t) = IntType t +binOpType (Xor t) = IntType t +binOpType (Pow t) = IntType t +binOpType (FPow t) = FloatType t +binOpType LogAnd = Bool +binOpType LogOr = Bool +binOpType (FAdd t) = FloatType t +binOpType (FSub t) = FloatType t +binOpType (FMul t) = FloatType t +binOpType (FDiv t) = FloatType t +binOpType (FMod t) = FloatType t + +-- | The operand types of a comparison operator. +cmpOpType :: CmpOp -> PrimType +cmpOpType (CmpEq t) = t +cmpOpType (CmpSlt t) = IntType t +cmpOpType (CmpSle t) = IntType t +cmpOpType (CmpUlt t) = IntType t +cmpOpType (CmpUle t) = IntType t +cmpOpType (FCmpLt t) = FloatType t +cmpOpType (FCmpLe t) = FloatType t +cmpOpType CmpLlt = Bool +cmpOpType CmpLle = Bool + +-- | The operand and result type of a unary operator. +unOpType :: UnOp -> PrimType +unOpType (SSignum t) = IntType t +unOpType (USignum t) = IntType t +unOpType Not = Bool +unOpType (Complement t) = IntType t +unOpType (Abs t) = IntType t +unOpType (FAbs t) = FloatType t +unOpType (FSignum t) = FloatType t + +-- | The input and output types of a conversion operator. +convOpType :: ConvOp -> (PrimType, PrimType) +convOpType (ZExt from to) = (IntType from, IntType to) +convOpType (SExt from to) = (IntType from, IntType to) +convOpType (FPConv from to) = (FloatType from, FloatType to) +convOpType (FPToUI from to) = (FloatType from, IntType to) +convOpType (FPToSI from to) = (FloatType from, IntType to) +convOpType (UIToFP from to) = (IntType from, FloatType to) +convOpType (SIToFP from to) = (IntType from, FloatType to) +convOpType (IToB from) = (IntType from, Bool) +convOpType (BToI to) = (Bool, IntType to) +convOpType (FToB from) = (FloatType from, Bool) +convOpType (BToF to) = (Bool, FloatType 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 + +wordToFloat :: Word32 -> Float +wordToFloat = G.runGet G.getFloatle . P.runPut . P.putWord32le + +doubleToWord :: Double -> Word64 +doubleToWord = G.runGet G.getWord64le . P.runPut . P.putDoublele + +wordToDouble :: Word64 -> Double +wordToDouble = G.runGet G.getDoublele . P.runPut . P.putWord64le + +-- | A mapping from names of primitive functions to their parameter +-- types, their result type, and a function for evaluating them. +primFuns :: + M.Map + String + ( [PrimType], + PrimType, + [PrimValue] -> Maybe PrimValue + ) +primFuns = + M.fromList + [ f16 "sqrt16" sqrt, + f32 "sqrt32" sqrt, + f64 "sqrt64" sqrt, + -- + f16 "cbrt16" $ convFloat . cbrtf . convFloat, + f32 "cbrt32" cbrtf, + f64 "cbrt64" cbrt, + -- + 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, + -- + -- + f16 "erf16" $ convFloat . erff . convFloat, + f32 "erf32" erff, + f64 "erf64" erf, + -- + f16 "erfc16" $ convFloat . erfcf . convFloat, + f32 "erfc32" erfcf, + f64 "erfc64" erfc, + -- + i8 "clz8" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, + i16 "clz16" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, + i32 "clz32" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, + i64 "clz64" $ IntValue . Int32Value . fromIntegral . countLeadingZeros, + i8 "ctz8" $ IntValue . Int32Value . fromIntegral . countTrailingZeros, + i16 "ctz16" $ IntValue . Int32Value . fromIntegral . countTrailingZeros, + i32 "ctz32" $ IntValue . Int32Value . fromIntegral . countTrailingZeros, + i64 "ctz64" $ IntValue . Int32Value . fromIntegral . countTrailingZeros, + i8 "popc8" $ IntValue . Int32Value . fromIntegral . popCount, + i16 "popc16" $ IntValue . Int32Value . fromIntegral . popCount, + i32 "popc32" $ IntValue . Int32Value . fromIntegral . popCount, + i64 "popc64" $ IntValue . Int32Value . fromIntegral . popCount, + ( "mad_hi8", + ( [IntType Int8, IntType Int8, IntType Int8], + IntType Int8, + \case + [IntValue (Int8Value a), IntValue (Int8Value b), IntValue (Int8Value c)] -> + Just $ IntValue . Int8Value $ mad_hi8 (Int8Value a) (Int8Value b) c + _ -> Nothing + ) + ), + ( "mad_hi16", + ( [IntType Int16, IntType Int16, IntType Int16], + IntType Int16, + \case + [IntValue (Int16Value a), IntValue (Int16Value b), IntValue (Int16Value c)] -> + Just $ IntValue . Int16Value $ mad_hi16 (Int16Value a) (Int16Value b) c + _ -> Nothing + ) + ), + ( "mad_hi32", + ( [IntType Int32, IntType Int32, IntType Int32], + IntType Int32, + \case + [IntValue (Int32Value a), IntValue (Int32Value b), IntValue (Int32Value c)] -> + Just $ IntValue . Int32Value $ mad_hi32 (Int32Value a) (Int32Value b) c + _ -> Nothing + ) + ), + ( "mad_hi64", + ( [IntType Int64, IntType Int64, IntType Int64], + IntType Int64, + \case + [IntValue (Int64Value a), IntValue (Int64Value b), IntValue (Int64Value c)] -> + Just $ IntValue . Int64Value $ mad_hi64 (Int64Value a) (Int64Value b) c + _ -> Nothing + ) + ), + ( "mul_hi8", + ( [IntType Int8, IntType Int8], + IntType Int8, + \case + [IntValue (Int8Value a), IntValue (Int8Value b)] -> + Just $ IntValue . Int8Value $ mul_hi8 (Int8Value a) (Int8Value b) + _ -> Nothing + ) + ), + ( "mul_hi16", + ( [IntType Int16, IntType Int16], + IntType Int16, + \case + [IntValue (Int16Value a), IntValue (Int16Value b)] -> + Just $ IntValue . Int16Value $ mul_hi16 (Int16Value a) (Int16Value b) + _ -> Nothing + ) + ), + ( "mul_hi32", + ( [IntType Int32, IntType Int32], + IntType Int32, + \case + [IntValue (Int32Value a), IntValue (Int32Value b)] -> + Just $ IntValue . Int32Value $ mul_hi32 (Int32Value a) (Int32Value b) + _ -> Nothing + ) + ), + ( "mul_hi64", + ( [IntType Int64, IntType Int64], + IntType Int64, + \case + [IntValue (Int64Value a), IntValue (Int64Value b)] -> + Just $ IntValue . Int64Value $ mul_hi64 (Int64Value a) (Int64Value b) + _ -> 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, + \case + [FloatValue (Float32Value x), FloatValue (Float32Value y)] -> + Just $ FloatValue $ Float32Value $ atan2 x y + _ -> Nothing + ) + ), + ( "atan2_64", + ( [FloatType Float64, FloatType Float64], + FloatType Float64, + \case + [FloatValue (Float64Value x), FloatValue (Float64Value y)] -> + Just $ FloatValue $ Float64Value $ atan2 x y + _ -> 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, + \case + [FloatValue (Float32Value x), FloatValue (Float32Value y)] -> + Just $ FloatValue $ Float32Value $ hypotf x y + _ -> Nothing + ) + ), + ( "hypot64", + ( [FloatType Float64, FloatType Float64], + FloatType Float64, + \case + [FloatValue (Float64Value x), FloatValue (Float64Value y)] -> + Just $ FloatValue $ Float64Value $ hypot x y + _ -> Nothing + ) + ), + ( "isinf16", + ( [FloatType Float16], + Bool, + \case + [FloatValue (Float16Value x)] -> Just $ BoolValue $ isInfinite x + _ -> Nothing + ) + ), + ( "isinf32", + ( [FloatType Float32], + Bool, + \case + [FloatValue (Float32Value x)] -> Just $ BoolValue $ isInfinite x + _ -> Nothing + ) + ), + ( "isinf64", + ( [FloatType Float64], + Bool, + \case + [FloatValue (Float64Value x)] -> Just $ BoolValue $ isInfinite x + _ -> Nothing + ) + ), + ( "isnan16", + ( [FloatType Float16], + Bool, + \case + [FloatValue (Float16Value x)] -> Just $ BoolValue $ isNaN x + _ -> Nothing + ) + ), + ( "isnan32", + ( [FloatType Float32], + Bool, + \case + [FloatValue (Float32Value x)] -> Just $ BoolValue $ isNaN x + _ -> Nothing + ) + ), + ( "isnan64", + ( [FloatType Float64], + Bool, + \case + [FloatValue (Float64Value x)] -> Just $ BoolValue $ isNaN x + _ -> Nothing + ) + ), + ( "to_bits16", + ( [FloatType Float16], + IntType Int16, + \case + [FloatValue (Float16Value x)] -> + Just $ IntValue $ Int16Value $ fromIntegral $ halfToWord x + _ -> Nothing + ) + ), + ( "to_bits32", + ( [FloatType Float32], + IntType Int32, + \case + [FloatValue (Float32Value x)] -> + Just $ IntValue $ Int32Value $ fromIntegral $ floatToWord x + _ -> Nothing + ) + ), + ( "to_bits64", + ( [FloatType Float64], + IntType Int64, + \case + [FloatValue (Float64Value x)] -> + Just $ IntValue $ Int64Value $ fromIntegral $ doubleToWord x + _ -> Nothing + ) + ), + ( "from_bits16", + ( [IntType Int16], + FloatType Float16, + \case + [IntValue (Int16Value x)] -> + Just $ FloatValue $ Float16Value $ wordToHalf $ fromIntegral x + _ -> Nothing + ) + ), + ( "from_bits32", + ( [IntType Int32], + FloatType Float32, + \case + [IntValue (Int32Value x)] -> + Just $ FloatValue $ Float32Value $ wordToFloat $ fromIntegral x + _ -> Nothing + ) + ), + ( "from_bits64", + ( [IntType Int64], + FloatType Float64, + \case + [IntValue (Int64Value x)] -> + Just $ FloatValue $ Float64Value $ wordToDouble $ fromIntegral x + _ -> Nothing + ) + ), + f16_3 "lerp16" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), + f32_3 "lerp32" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), + f64_3 "lerp64" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), + 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) + ] + where + i8 s f = (s, ([IntType Int8], IntType Int32, i8PrimFun f)) + 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], + FloatType Float32, + f32PrimFun3 f + ) + ) + f64_3 s f = + ( s, + ( [FloatType Float64, FloatType Float64, FloatType Float64], + FloatType Float64, + f64PrimFun3 f + ) + ) + + i8PrimFun f [IntValue (Int8Value x)] = + Just $ f x + i8PrimFun _ _ = Nothing + + i16PrimFun f [IntValue (Int16Value x)] = + Just $ f x + i16PrimFun _ _ = Nothing + + i32PrimFun f [IntValue (Int32Value x)] = + Just $ f x + i32PrimFun _ _ = Nothing + + i64PrimFun f [IntValue (Int64Value x)] = + 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 + + f64PrimFun f [FloatValue (Float64Value x)] = + 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), + FloatValue (Float32Value b), + FloatValue (Float32Value c) + ] = + Just $ FloatValue $ Float32Value $ f a b c + f32PrimFun3 _ _ = Nothing + + f64PrimFun3 + f + [ FloatValue (Float64Value a), + FloatValue (Float64Value b), + FloatValue (Float64Value c) + ] = + Just $ FloatValue $ Float64Value $ f a b c + f64PrimFun3 _ _ = Nothing + +-- | 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 +zeroIsh _ = False + +-- | 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 +oneIsh _ = False + +-- | 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 +negativeIsh UnitValue = False + +-- | Is the given integer value kind of zero? +zeroIshInt :: IntValue -> Bool +zeroIshInt (Int8Value k) = k == 0 +zeroIshInt (Int16Value k) = k == 0 +zeroIshInt (Int32Value k) = k == 0 +zeroIshInt (Int64Value k) = k == 0 + +-- | Is the given integer value kind of one? +oneIshInt :: IntValue -> Bool +oneIshInt (Int8Value k) = k == 1 +oneIshInt (Int16Value k) = k == 1 +oneIshInt (Int32Value k) = k == 1 +oneIshInt (Int64Value k) = k == 1 + +-- | Is the given integer value kind of negative? +negativeIshInt :: IntValue -> Bool +negativeIshInt (Int8Value k) = k < 0 +negativeIshInt (Int16Value k) = k < 0 +negativeIshInt (Int32Value k) = k < 0 +negativeIshInt (Int64Value k) = k < 0 + +-- | The size of a value of a given primitive type in bits. +primBitSize :: PrimType -> Int +primBitSize = (* 8) . primByteSize + +-- | The size of a value of a given primitive type in eight-bit bytes. +primByteSize :: Num a => PrimType -> a +primByteSize (IntType t) = intByteSize t +primByteSize (FloatType t) = floatByteSize t +primByteSize Bool = 1 +primByteSize Unit = 0 + +-- | The size of a value of a given integer type in eight-bit bytes. +intByteSize :: Num a => IntType -> a +intByteSize Int8 = 1 +intByteSize Int16 = 2 +intByteSize Int32 = 4 +intByteSize Int64 = 8 + +-- | The size of a value of a given floating-point type in eight-bit bytes. +floatByteSize :: Num a => FloatType -> a +floatByteSize Float16 = 2 +floatByteSize Float32 = 4 +floatByteSize Float64 = 8 + +-- | True if the given binary operator is commutative. +commutativeBinOp :: BinOp -> Bool +commutativeBinOp Add {} = True +commutativeBinOp FAdd {} = True +commutativeBinOp Mul {} = True +commutativeBinOp FMul {} = True +commutativeBinOp And {} = True +commutativeBinOp Or {} = True +commutativeBinOp Xor {} = True +commutativeBinOp LogOr {} = True +commutativeBinOp LogAnd {} = True +commutativeBinOp SMax {} = True +commutativeBinOp SMin {} = True +commutativeBinOp UMax {} = True +commutativeBinOp UMin {} = True +commutativeBinOp FMax {} = True +commutativeBinOp FMin {} = True +commutativeBinOp _ = False + +-- | True if the given binary operator is associative. +associativeBinOp :: BinOp -> Bool +associativeBinOp Add {} = True +associativeBinOp Mul {} = True +associativeBinOp And {} = True +associativeBinOp Or {} = True +associativeBinOp Xor {} = True +associativeBinOp LogOr {} = True +associativeBinOp LogAnd {} = True +associativeBinOp SMax {} = True +associativeBinOp SMin {} = True +associativeBinOp UMax {} = True +associativeBinOp UMin {} = True +associativeBinOp FMax {} = True +associativeBinOp FMin {} = True +associativeBinOp _ = False + +-- Prettyprinting instances + +instance Pretty BinOp where + ppr (Add t OverflowWrap) = taggedI "add" t + ppr (Add t OverflowUndef) = taggedI "add_nw" t + ppr (Sub t OverflowWrap) = taggedI "sub" t + ppr (Sub t OverflowUndef) = taggedI "sub_nw" t + ppr (Mul t OverflowWrap) = taggedI "mul" t + ppr (Mul t OverflowUndef) = taggedI "mul_nw" t + ppr (FAdd t) = taggedF "fadd" t + ppr (FSub t) = taggedF "fsub" t + ppr (FMul t) = taggedF "fmul" t + ppr (UDiv t Safe) = taggedI "udiv_safe" t + ppr (UDiv t Unsafe) = taggedI "udiv" t + ppr (UDivUp t Safe) = taggedI "udiv_up_safe" t + ppr (UDivUp t Unsafe) = taggedI "udiv_up" t + ppr (UMod t Safe) = taggedI "umod_safe" t + ppr (UMod t Unsafe) = taggedI "umod" t + ppr (SDiv t Safe) = taggedI "sdiv_safe" t + ppr (SDiv t Unsafe) = taggedI "sdiv" t + ppr (SDivUp t Safe) = taggedI "sdiv_up_safe" t + ppr (SDivUp t Unsafe) = taggedI "sdiv_up" t + ppr (SMod t Safe) = taggedI "smod_safe" t + ppr (SMod t Unsafe) = taggedI "smod" t + ppr (SQuot t Safe) = taggedI "squot_safe" t + ppr (SQuot t Unsafe) = taggedI "squot" t + ppr (SRem t Safe) = taggedI "srem_safe" t + ppr (SRem t Unsafe) = taggedI "srem" t + ppr (FDiv t) = taggedF "fdiv" t + ppr (FMod t) = taggedF "fmod" t + ppr (SMin t) = taggedI "smin" t + ppr (UMin t) = taggedI "umin" t + ppr (FMin t) = taggedF "fmin" t + ppr (SMax t) = taggedI "smax" t + ppr (UMax t) = taggedI "umax" t + ppr (FMax t) = taggedF "fmax" t + ppr (Shl t) = taggedI "shl" t + ppr (LShr t) = taggedI "lshr" t + ppr (AShr t) = taggedI "ashr" t + ppr (And t) = taggedI "and" t + ppr (Or t) = taggedI "or" t + ppr (Xor t) = taggedI "xor" t + ppr (Pow t) = taggedI "pow" t + ppr (FPow t) = taggedF "fpow" t + ppr LogAnd = text "logand" + ppr LogOr = text "logor" + +instance Pretty CmpOp where + ppr (CmpEq t) = text "eq_" <> ppr t + ppr (CmpUlt t) = taggedI "ult" t + ppr (CmpUle t) = taggedI "ule" t + ppr (CmpSlt t) = taggedI "slt" t + ppr (CmpSle t) = taggedI "sle" t + ppr (FCmpLt t) = taggedF "lt" t + ppr (FCmpLe t) = taggedF "le" t + ppr CmpLlt = text "llt" + ppr CmpLle = text "lle" + +instance Pretty ConvOp where + ppr op = convOp (convOpFun op) from to + where + (from, to) = convOpType op + +instance Pretty UnOp where + ppr Not = text "not" + ppr (Abs t) = taggedI "abs" t + ppr (FAbs t) = taggedF "fabs" t + ppr (SSignum t) = taggedI "ssignum" t + ppr (USignum t) = taggedI "usignum" t + ppr (FSignum t) = taggedF "fsignum" t + ppr (Complement t) = taggedI "complement" t + +-- | The human-readable name for a 'ConvOp'. This is used to expose +-- the 'ConvOp' in the @intrinsics@ module of a Futhark program. +convOpFun :: ConvOp -> String +convOpFun ZExt {} = "zext" +convOpFun SExt {} = "sext" +convOpFun FPConv {} = "fpconv" +convOpFun FPToUI {} = "fptoui" +convOpFun FPToSI {} = "fptosi" +convOpFun UIToFP {} = "uitofp" +convOpFun SIToFP {} = "sitofp" +convOpFun IToB {} = "itob" +convOpFun BToI {} = "btoi" +convOpFun FToB {} = "ftob" +convOpFun BToF {} = "btof" + +taggedI :: String -> IntType -> Doc +taggedI s Int8 = text $ s ++ "8" +taggedI s Int16 = text $ s ++ "16" +taggedI s Int32 = text $ s ++ "32" +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" + +convOp :: (Pretty from, Pretty to) => String -> from -> to -> Doc +convOp s from to = text s <> text "_" <> ppr from <> text "_" <> ppr to + +-- | True if signed. Only makes a difference for integer types. +prettySigned :: Bool -> PrimType -> String +prettySigned True (IntType it) = 'u' : drop 1 (pretty it) +prettySigned _ t = pretty t + +mul_hi8 :: IntValue -> IntValue -> Int8 +mul_hi8 a b = + let a' = intToWord64 a + b' = intToWord64 b + in fromIntegral (shiftR (a' * b') 8) + +mul_hi16 :: IntValue -> IntValue -> Int16 +mul_hi16 a b = + let a' = intToWord64 a + b' = intToWord64 b + in fromIntegral (shiftR (a' * b') 16) + +mul_hi32 :: IntValue -> IntValue -> Int32 +mul_hi32 a b = + let a' = intToWord64 a + b' = intToWord64 b + in fromIntegral (shiftR (a' * b') 32) + +mul_hi64 :: IntValue -> IntValue -> Int64 +mul_hi64 a b = + let a' = (toInteger . intToWord64) a + b' = (toInteger . intToWord64) b + in fromIntegral (shiftR (a' * b') 64) + +mad_hi8 :: IntValue -> IntValue -> Int8 -> Int8 +mad_hi8 a b c = mul_hi8 a b + c + +mad_hi16 :: IntValue -> IntValue -> Int16 -> Int16 +mad_hi16 a b c = mul_hi16 a b + c + +mad_hi32 :: IntValue -> IntValue -> Int32 -> Int32 +mad_hi32 a b c = mul_hi32 a b + c + +mad_hi64 :: IntValue -> IntValue -> Int64 -> Int64 +mad_hi64 a b c = mul_hi64 a b + c diff --git a/src/Language/Futhark/Primitive/Parse.hs b/src/Language/Futhark/Primitive/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/Futhark/Primitive/Parse.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Parsers for primitive values and types. +module Language.Futhark.Primitive.Parse + ( pPrimValue, + pPrimType, + pFloatType, + pIntType, + + -- * Building blocks + constituent, + lexeme, + keyword, + whitespace, + ) +where + +import Data.Char (isAlphaNum) +import Data.Functor +import qualified Data.Text as T +import Data.Void +import Futhark.Util.Pretty hiding (empty) +import Language.Futhark.Primitive +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +-- | Is this character a valid member of an identifier? +constituent :: Char -> Bool +constituent c = isAlphaNum c || (c `elem` ("_/'+-=!&^.<>*|" :: String)) + +-- | Consume whitespace (including skipping line comments). +whitespace :: Parsec Void T.Text () +whitespace = L.space space1 (L.skipLineComment "--") empty + +-- | Consume whitespace after the provided parser, if it succeeds. +lexeme :: Parsec Void T.Text a -> Parsec Void T.Text a +lexeme = try . L.lexeme whitespace + +-- | @keyword k@ parses @k@, which must not be immediately followed by +-- a 'constituent' character. This ensures that @iff@ is not seen as +-- the @if@ keyword followed by @f@. Sometimes called the "maximum +-- munch" rule. +keyword :: T.Text -> Parsec Void T.Text () +keyword s = lexeme $ chunk s *> notFollowedBy (satisfy constituent) + +-- | Parse an integer value. +pIntValue :: Parsec Void T.Text IntValue +pIntValue = try $ do + x <- L.signed (pure ()) L.decimal + t <- pIntType + pure $ intValue t (x :: Integer) + +-- | Parse a floating-point value. +pFloatValue :: Parsec Void T.Text FloatValue +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), + keyword "f64.nan" $> Float64Value (0 / 0), + keyword "f64.inf" $> Float64Value (1 / 0), + keyword "-f64.inf" $> Float64Value (-1 / 0) + ] + where + pNum = try $ do + x <- L.signed (pure ()) L.float + t <- pFloatType + pure $ floatValue t (x :: Double) + +-- | Parse a boolean value. +pBoolValue :: Parsec Void T.Text Bool +pBoolValue = + choice + [ keyword "true" $> True, + keyword "false" $> False + ] + +-- | Defined in this module for convenience. +pPrimValue :: Parsec Void T.Text PrimValue +pPrimValue = + choice + [ FloatValue <$> pFloatValue, + IntValue <$> pIntValue, + BoolValue <$> pBoolValue, + UnitValue <$ "()" + ] + "primitive value" + +-- | Parse a floating-point type. +pFloatType :: Parsec Void T.Text FloatType +pFloatType = choice $ map p allFloatTypes + where + p t = keyword (prettyText t) $> t + +-- | Parse an integer type. +pIntType :: Parsec Void T.Text IntType +pIntType = choice $ map p allIntTypes + where + p t = keyword (prettyText t) $> t + +-- | Parse a primitive type. +pPrimType :: Parsec Void T.Text PrimType +pPrimType = + choice [p Bool, p Unit, FloatType <$> pFloatType, IntType <$> pIntType] + where + p t = keyword (prettyText t) $> t 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 @@ -17,7 +17,6 @@ namesToPrimTypes, qualName, qualify, - typeName, valueType, primValueType, leadingOperator, @@ -27,6 +26,7 @@ identifierReference, prettyStacktrace, progHoles, + defaultEntryPoint, -- * Queries on expressions typeOf, @@ -42,7 +42,6 @@ patternStructType, patternParam, patternOrderZero, - patternDimNames, -- * Queries on types uniqueness, @@ -51,12 +50,10 @@ diet, arrayRank, arrayShape, - nestedDims, orderZero, unfoldFunType, foldFunType, typeVars, - typeDimNames, -- * Operations on types peelArray, @@ -71,9 +68,6 @@ noSizes, traverseDims, DimPos (..), - mustBeExplicit, - mustBeExplicitInType, - determineSizeWitnesses, tupleRecord, isTupleRecord, areTupleFields, @@ -119,13 +113,17 @@ import Data.Maybe import Data.Ord import qualified Data.Set as S -import qualified Data.Text as T -import qualified Futhark.IR.Primitive as Primitive -import Futhark.Util (maxinum, nubOrd) +import Futhark.Util (maxinum) import Futhark.Util.Pretty +import qualified Language.Futhark.Primitive as Primitive import Language.Futhark.Syntax import Language.Futhark.Traversals +import Language.Futhark.Tuple +-- | The name of the default program entry point (@main@). +defaultEntryPoint :: Name +defaultEntryPoint = nameFromString "main" + -- | Return the dimensionality of a type. For non-arrays, this is -- zero. For a one-dimensional array it is one, for a two-dimensional -- it is two, and so forth. @@ -133,38 +131,12 @@ arrayRank = shapeRank . arrayShape -- | Return the shape of a type - for non-arrays, this is 'mempty'. -arrayShape :: TypeBase dim as -> ShapeDecl dim +arrayShape :: TypeBase dim as -> Shape dim arrayShape (Array _ _ ds _) = ds arrayShape _ = mempty --- | Return any free shape declarations in the type, with duplicates --- removed. -nestedDims :: TypeBase (DimDecl VName) as -> [DimDecl VName] -nestedDims t = - case t of - Array _ _ ds a -> - nubOrd $ nestedDims (Scalar a) <> shapeDims ds - Scalar (Record fs) -> - nubOrd $ foldMap nestedDims fs - Scalar Prim {} -> - mempty - Scalar (Sum cs) -> - nubOrd $ foldMap (foldMap nestedDims) cs - Scalar (Arrow _ v t1 (RetType dims t2)) -> - filter (notV v) $ filter (`notElem` dims') $ nestedDims t1 <> nestedDims t2 - where - dims' = map (NamedDim . qualName) dims - Scalar (TypeVar _ _ _ targs) -> - concatMap typeArgDims targs - where - typeArgDims (TypeArgDim d _) = [d] - typeArgDims (TypeArgType at _) = nestedDims at - - notV Unnamed = const True - notV (Named v) = (/= NamedDim (qualName v)) - -- | Change the shape of a type to be just the rank. -noSizes :: TypeBase (DimDecl vn) as -> TypeBase () as +noSizes :: TypeBase Size as -> TypeBase () as noSizes = first $ const () -- | Where does this dimension occur? @@ -220,50 +192,6 @@ onTypeArg bound b (TypeArgType t loc) = TypeArgType <$> go bound b t <*> pure loc -mustBeExplicitAux :: StructType -> M.Map VName Bool -mustBeExplicitAux t = - execState (traverseDims onDim t) mempty - where - onDim bound _ (NamedDim d) - | qualLeaf d `S.member` bound = - modify $ \s -> M.insertWith (&&) (qualLeaf d) False s - onDim _ PosImmediate (NamedDim d) = - modify $ \s -> M.insertWith (&&) (qualLeaf d) False s - onDim _ _ (NamedDim d) = - modify $ M.insertWith (&&) (qualLeaf d) True - onDim _ _ _ = - pure () - --- | Determine which of the sizes in a type are used as sizes outside --- of functions in the type, and which are not. The former are said --- to be "witnessed" by this type, while the latter are not. In --- practice, the latter means that the actual sizes must come from --- somewhere else. -determineSizeWitnesses :: StructType -> (S.Set VName, S.Set VName) -determineSizeWitnesses t = - bimap (S.fromList . M.keys) (S.fromList . M.keys) $ - M.partition not $ mustBeExplicitAux t - --- | Figure out which of the sizes in a parameter type must be passed --- explicitly, because their first use is as something else than just --- an array dimension. 'mustBeExplicit' is like this function, but --- first decomposes into parameter types. -mustBeExplicitInType :: StructType -> S.Set VName -mustBeExplicitInType = snd . determineSizeWitnesses - --- | Figure out which of the sizes in a binding type must be passed --- explicitly, because their first use is as something else than just --- an array dimension. -mustBeExplicit :: StructType -> S.Set VName -mustBeExplicit bind_t = - let (ts, ret) = unfoldFunType bind_t - alsoRet = - M.unionWith (&&) $ - M.fromList $ zip (S.toList $ typeDimNames ret) $ repeat True - in S.fromList $ M.keys $ M.filter id $ alsoRet $ foldl' onType mempty ts - where - onType uses t = uses <> mustBeExplicitAux t -- Left-biased union. - -- | Return the uniqueness of a type. uniqueness :: TypeBase shape as -> Uniqueness uniqueness (Array _ u _ _) = u @@ -332,7 +260,7 @@ arrayOf :: Monoid as => Uniqueness -> - ShapeDecl dim -> + Shape dim -> TypeBase dim as -> TypeBase dim as arrayOf u s t = arrayOfWithAliases mempty u s (t `setUniqueness` Nonunique) @@ -341,7 +269,7 @@ Monoid as => as -> Uniqueness -> - ShapeDecl dim -> + Shape dim -> TypeBase dim as -> TypeBase dim as arrayOfWithAliases as2 u shape2 (Array as1 _ shape1 et) = @@ -371,35 +299,6 @@ isTupleRecord (Scalar (Record fs)) = areTupleFields fs isTupleRecord _ = Nothing --- | Does this record map correspond to a tuple? -areTupleFields :: M.Map Name a -> Maybe [a] -areTupleFields fs = - let fs' = sortFields fs - in if and $ zipWith (==) (map fst fs') tupleFieldNames - then Just $ map snd fs' - else Nothing - --- | Construct a record map corresponding to a tuple. -tupleFields :: [a] -> M.Map Name a -tupleFields as = M.fromList $ zip tupleFieldNames as - --- | Increasing field names for a tuple (starts at 0). -tupleFieldNames :: [Name] -tupleFieldNames = map (nameFromString . show) [(0 :: Int) ..] - --- | Sort fields by their name; taking care to sort numeric fields by --- their numeric value. This ensures that tuples and tuple-like --- records match. -sortFields :: M.Map Name a -> [(Name, a)] -sortFields l = map snd $ sortOn fst $ zip (map (fieldish . fst) l') l' - where - l' = M.toList l - onDigit Nothing _ = Nothing - onDigit (Just d) c - | isDigit c = Just $ d * 10 + ord c - ord '0' - | otherwise = Nothing - fieldish s = maybe (Right s) Left $ T.foldl' onDigit (Just 0) $ nameToText s - -- | Sort the constructors of a sum type in some well-defined (but not -- otherwise significant) manner. sortConstrs :: M.Map Name a -> [(Name, a)] @@ -419,10 +318,10 @@ -- expression. This is necessary since the original type may contain additional -- information (e.g., shape restrictions) from the user given annotation. combineTypeShapes :: - (Monoid as, ArrayDim dim) => - TypeBase dim as -> - TypeBase dim as -> - TypeBase dim as + (Monoid as) => + TypeBase Size as -> + TypeBase Size as -> + TypeBase Size as combineTypeShapes (Scalar (Record ts1)) (Scalar (Record ts2)) | M.keys ts1 == M.keys ts2 = Scalar $ @@ -473,7 +372,7 @@ flip setAliases (als1 <> als2) <$> ( arrayOf (min u1 u2) <$> onShapes bound shape1 shape2 - <*> matchDims' bound (Scalar et1) (Scalar et2) + <*> matchDims' bound (Scalar et1) (Scalar et2) ) (Scalar (Record f1), Scalar (Record f2)) -> Scalar . Record @@ -488,7 +387,8 @@ ) -> let bound' = mapMaybe maybePName [p1, p2] <> dims1 <> dims2 <> bound in Scalar - <$> ( Arrow (als1 <> als2) p1 <$> matchDims' bound' a1 a2 + <$> ( Arrow (als1 <> als2) p1 + <$> matchDims' bound' a1 a2 <*> (RetType dims1 <$> matchDims' bound' b1 b2) ) ( Scalar (TypeVar als1 u v targs1), @@ -507,7 +407,7 @@ maybePName Unnamed = Nothing onShapes bound shape1 shape2 = - ShapeDecl <$> zipWithM (onDims bound) (shapeDims shape1) (shapeDims shape2) + Shape <$> zipWithM (onDims bound) (shapeDims shape1) (shapeDims shape2) -- | Set the uniqueness attribute of a type. If the type is a record -- or sum type, the uniqueness of its components will be modified. @@ -581,7 +481,7 @@ Array mempty Unique - (ShapeDecl [ConstDim $ genericLength vs]) + (Shape [ConstSize $ genericLength vs]) (Prim (Unsigned Int8)) typeOf (Project _ _ (Info t) _) = t typeOf (Var _ (Info t) _) = t @@ -596,9 +496,8 @@ let RetType [] t' = foldr (arrow . patternParam) t params in t' `setAliases` als where - arrow (Named v, x) (RetType dims y) - | v `S.member` typeDimNames y = - RetType [] $ Scalar $ Arrow () (Named v) x $ RetType (v : dims) y + arrow (Named v, x) (RetType dims y) = + RetType [] $ Scalar $ Arrow () (Named v) x $ RetType (v : dims) y arrow (pn, tx) y = RetType [] $ Scalar $ Arrow () pn tx y typeOf (OpSection _ (Info t) _) = @@ -648,10 +547,10 @@ -- sizes). valBindBound :: ValBindBase Info VName -> [VName] valBindBound vb = - valBindName vb : - case valBindParams vb of - [] -> retDims (unInfo (valBindRetType vb)) - _ -> [] + valBindName vb + : case valBindParams vb of + [] -> retDims (unInfo (valBindRetType vb)) + _ -> [] -- | The type of a function with the given parameters and return type. funType :: [PatBase Info VName] -> StructRetType -> StructType @@ -667,13 +566,12 @@ case t of Scalar Prim {} -> mempty Scalar (TypeVar _ _ tn targs) -> - mconcat $ typeVarFree tn : map typeArgFree targs + mconcat $ S.singleton (qualLeaf tn) : map typeArgFree targs Scalar (Arrow _ _ t1 (RetType _ t2)) -> typeVars t1 <> typeVars t2 Scalar (Record fields) -> foldMap typeVars fields Scalar (Sum cs) -> mconcat $ (foldMap . fmap) typeVars cs Array _ _ _ rt -> typeVars $ Scalar rt where - typeVarFree = S.singleton . typeLeaf typeArgFree (TypeArgType ta _) = typeVars ta typeArgFree TypeArgDim {} = mempty @@ -688,25 +586,6 @@ orderZero (Scalar Arrow {}) = False orderZero (Scalar (Sum cs)) = all (all orderZero) cs --- | Extract all the shape names that occur in a given pattern. -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 (PatAscription p _ _) = patternDimNames p -patternDimNames (PatLit _ (Info tp) _) = typeDimNames tp -patternDimNames (PatConstr _ _ ps _) = foldMap patternDimNames ps -patternDimNames (PatAttr _ p _) = patternDimNames p - --- | Extract all the shape names that occur free in a given type. -typeDimNames :: TypeBase (DimDecl VName) als -> S.Set VName -typeDimNames = foldMap dimName . nestedDims - where - dimName (NamedDim qn) = S.singleton $ qualLeaf qn - dimName _ = mempty - -- | @patternOrderZero pat@ is 'True' if all of the types in the given pattern -- have order 0. patternOrderZero :: PatBase Info vn -> Bool @@ -789,8 +668,8 @@ M.fromList [ (nameFromString $ pretty t, t) | t <- - Bool : - map Signed [minBound .. maxBound] + Bool + : map Signed [minBound .. maxBound] ++ map Unsigned [minBound .. maxBound] ++ map FloatType [minBound .. maxBound] ] @@ -803,7 +682,7 @@ data Intrinsic = IntrinsicMonoFun [PrimType] PrimType | IntrinsicOverloadedFun [PrimType] [Maybe PrimType] (Maybe PrimType) - | IntrinsicPolyFun [TypeParamBase VName] [StructType] (RetTypeBase (DimDecl VName) ()) + | IntrinsicPolyFun [TypeParamBase VName] [StructType] (RetTypeBase Size ()) | IntrinsicType Liftedness [TypeParamBase VName] StructType | IntrinsicEquality -- Special cased. @@ -811,12 +690,13 @@ intrinsicAcc = ( acc_v, IntrinsicType SizeLifted [TypeParamType Unlifted t_v mempty] $ - Scalar $ TypeVar () Nonunique (TypeName [] acc_v) [arg] + Scalar $ + TypeVar () Nonunique (qualName acc_v) [arg] ) where acc_v = VName "acc" 10 t_v = VName "t" 11 - arg = TypeArgType (Scalar (TypeVar () Nonunique (TypeName [] t_v) [])) mempty + arg = TypeArgType (Scalar (TypeVar () Nonunique (qualName t_v) [])) mempty -- | A map of all built-ins. intrinsics :: M.Map VName Intrinsic @@ -858,7 +738,8 @@ IntrinsicPolyFun [tp_a, sp_n, sp_m] [Array () Nonunique (shape [n, m]) t_a] - $ RetType [k] $ Array () Nonunique (shape [k]) t_a + $ RetType [k] + $ Array () Nonunique (shape [k]) t_a ), ( "unflatten", IntrinsicPolyFun @@ -867,26 +748,32 @@ Scalar $ Prim $ Signed Int64, Array () Nonunique (shape [n]) t_a ] - $ RetType [k, m] $ - Array () Nonunique (shape [k, m]) t_a + $ RetType [k, m] + $ Array () Nonunique (shape [k, m]) t_a ), ( "concat", IntrinsicPolyFun [tp_a, sp_n, sp_m] [arr_a $ shape [n], arr_a $ shape [m]] - $ RetType [k] $ uarr_a $ shape [k] + $ RetType [k] + $ uarr_a + $ shape [k] ), ( "rotate", IntrinsicPolyFun [tp_a, sp_n] [Scalar $ Prim $ Signed Int64, arr_a $ shape [n]] - $ RetType [] $ arr_a $ shape [n] + $ RetType [] + $ arr_a + $ shape [n] ), ( "transpose", IntrinsicPolyFun [tp_a, sp_n, sp_m] [arr_a $ shape [n, m]] - $ RetType [] $ arr_a $ shape [m, n] + $ RetType [] + $ arr_a + $ shape [m, n] ), ( "scatter", IntrinsicPolyFun @@ -895,7 +782,8 @@ Array () Nonunique (shape [l]) (Prim $ Signed Int64), Array () Nonunique (shape [l]) t_a ] - $ RetType [] $ Array () Unique (shape [n]) t_a + $ RetType [] + $ Array () Unique (shape [n]) t_a ), ( "scatter_2d", IntrinsicPolyFun @@ -904,7 +792,9 @@ Array () Nonunique (shape [l]) (tupInt64 2), Array () Nonunique (shape [l]) t_a ] - $ RetType [] $ uarr_a $ shape [n, m] + $ RetType [] + $ uarr_a + $ shape [n, m] ), ( "scatter_3d", IntrinsicPolyFun @@ -913,20 +803,24 @@ Array () Nonunique (shape [l]) (tupInt64 3), Array () Nonunique (shape [l]) t_a ] - $ RetType [] $ uarr_a $ shape [n, m, k] + $ RetType [] + $ uarr_a + $ shape [n, m, k] ), ( "zip", IntrinsicPolyFun [tp_a, tp_b, sp_n] [arr_a (shape [n]), arr_b (shape [n])] - $ RetType [] $ tuple_uarr (Scalar t_a) (Scalar t_b) $ shape [n] + $ RetType [] + $ tuple_uarr (Scalar t_a) (Scalar t_b) + $ shape [n] ), ( "unzip", IntrinsicPolyFun [tp_a, tp_b, sp_n] [tuple_arr (Scalar t_a) (Scalar t_b) $ shape [n]] - $ RetType [] . Scalar . Record . M.fromList $ - zip tupleFieldNames [arr_a $ shape [n], arr_b $ shape [n]] + $ RetType [] . Scalar . Record . M.fromList + $ zip tupleFieldNames [arr_a $ shape [n], arr_b $ shape [n]] ), ( "hist_1d", IntrinsicPolyFun @@ -938,7 +832,9 @@ Array () Nonunique (shape [n]) (tupInt64 1), arr_a (shape [n]) ] - $ RetType [] $ uarr_a $ shape [m] + $ RetType [] + $ uarr_a + $ shape [m] ), ( "hist_2d", IntrinsicPolyFun @@ -950,7 +846,9 @@ Array () Nonunique (shape [n]) (tupInt64 2), arr_a (shape [n]) ] - $ RetType [] $ uarr_a $ shape [m, k] + $ RetType [] + $ uarr_a + $ shape [m, k] ), ( "hist_3d", IntrinsicPolyFun @@ -962,7 +860,9 @@ Array () Nonunique (shape [n]) (tupInt64 3), arr_a (shape [n]) ] - $ RetType [] $ uarr_a $ shape [m, k, l] + $ RetType [] + $ uarr_a + $ shape [m, k, l] ), ( "map", IntrinsicPolyFun @@ -970,7 +870,9 @@ [ Scalar t_a `arr` Scalar t_b, arr_a $ shape [n] ] - $ RetType [] $ uarr_b $ shape [n] + $ RetType [] + $ uarr_b + $ shape [n] ), ( "reduce", IntrinsicPolyFun @@ -979,7 +881,8 @@ Scalar t_a, arr_a $ shape [n] ] - $ RetType [] $ Scalar t_a + $ RetType [] + $ Scalar t_a ), ( "reduce_comm", IntrinsicPolyFun @@ -988,7 +891,8 @@ Scalar t_a, arr_a $ shape [n] ] - $ RetType [] $ Scalar t_a + $ RetType [] + $ Scalar t_a ), ( "scan", IntrinsicPolyFun @@ -997,7 +901,9 @@ Scalar t_a, arr_a $ shape [n] ] - $ RetType [] $ uarr_a $ shape [n] + $ RetType [] + $ uarr_a + $ shape [n] ), ( "partition", IntrinsicPolyFun @@ -1019,7 +925,9 @@ [ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` arr_kb), arr_a $ shape [n] ] - $ RetType [] $ uarr_b $ shape [n] + $ RetType [] + $ uarr_b + $ shape [n] ), ( "map_stream_per", IntrinsicPolyFun @@ -1027,7 +935,9 @@ [ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` arr_kb), arr_a $ shape [n] ] - $ RetType [] $ uarr_b $ shape [n] + $ RetType [] + $ uarr_b + $ shape [n] ), ( "reduce_stream", IntrinsicPolyFun @@ -1036,7 +946,8 @@ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` Scalar t_b), arr_a $ shape [n] ] - $ RetType [] $ Scalar t_b + $ RetType [] + $ Scalar t_b ), ( "reduce_stream_per", IntrinsicPolyFun @@ -1045,7 +956,8 @@ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` Scalar t_b), arr_a $ shape [n] ] - $ RetType [] $ Scalar t_b + $ RetType [] + $ Scalar t_b ), ( "acc_write", IntrinsicPolyFun @@ -1054,7 +966,9 @@ Scalar (Prim $ Signed Int64), Scalar t_a ] - $ RetType [] $ Scalar $ accType arr_ka + $ RetType [] + $ Scalar + $ accType arr_ka ), ( "scatter_stream", IntrinsicPolyFun @@ -1080,7 +994,9 @@ ), arr_b $ shape [n] ] - $ RetType [] $ uarr_a $ shape [k] + $ RetType [] + $ uarr_a + $ shape [k] ), ( "jvp2", IntrinsicPolyFun @@ -1089,7 +1005,9 @@ Scalar t_a, Scalar t_a ] - $ RetType [] $ Scalar $ tupleRecord [Scalar t_b, Scalar t_b] + $ RetType [] + $ Scalar + $ tupleRecord [Scalar t_b, Scalar t_b] ), ( "vjp2", IntrinsicPolyFun @@ -1098,7 +1016,9 @@ Scalar t_a, Scalar t_b ] - $ RetType [] $ Scalar $ tupleRecord [Scalar t_b, Scalar t_a] + $ RetType [] + $ Scalar + $ tupleRecord [Scalar t_b, Scalar t_a] ) ] ++ @@ -1113,7 +1033,9 @@ Scalar (Prim $ Signed Int64), Scalar (Prim $ Signed Int64) ] - $ RetType [m, k] $ arr_a $ shape [m, k] + $ RetType [m, k] + $ arr_a + $ shape [m, k] ), ( "flat_update_2d", IntrinsicPolyFun @@ -1124,7 +1046,9 @@ Scalar (Prim $ Signed Int64), arr_a $ shape [k, l] ] - $ RetType [] $ uarr_a $ shape [n] + $ RetType [] + $ uarr_a + $ shape [n] ), ( "flat_index_3d", IntrinsicPolyFun @@ -1138,7 +1062,9 @@ Scalar (Prim $ Signed Int64), Scalar (Prim $ Signed Int64) ] - $ RetType [m, k, l] $ arr_a $ shape [m, k, l] + $ RetType [m, k, l] + $ arr_a + $ shape [m, k, l] ), ( "flat_update_3d", IntrinsicPolyFun @@ -1150,7 +1076,9 @@ Scalar (Prim $ Signed Int64), arr_a $ shape [k, l, p] ] - $ RetType [] $ uarr_a $ shape [n] + $ RetType [] + $ uarr_a + $ shape [n] ), ( "flat_index_4d", IntrinsicPolyFun @@ -1166,7 +1094,9 @@ Scalar (Prim $ Signed Int64), Scalar (Prim $ Signed Int64) ] - $ RetType [m, k, l, p] $ arr_a $ shape [m, k, l, p] + $ RetType [m, k, l, p] + $ arr_a + $ shape [m, k, l, p] ), ( "flat_update_4d", IntrinsicPolyFun @@ -1179,25 +1109,27 @@ Scalar (Prim $ Signed Int64), arr_a $ shape [k, l, p, q] ] - $ RetType [] $ uarr_a $ shape [n] + $ RetType [] + $ uarr_a + $ shape [n] ) ] where [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) [] + t_a = TypeVar () Nonunique (qualName a) [] arr_a s = Array () Nonunique s t_a uarr_a s = Array () Unique s t_a tp_a = TypeParamType Unlifted a mempty - t_b = TypeVar () Nonunique (typeName b) [] + t_b = TypeVar () Nonunique (qualName b) [] arr_b s = Array () Nonunique s t_b uarr_b s = Array () Unique s t_b tp_b = TypeParamType Unlifted b mempty [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) + shape = Shape . map (NamedSize . qualName) tuple_arr x y s = Array @@ -1209,13 +1141,13 @@ arr x y = Scalar $ Arrow mempty Unnamed x (RetType [] y) - arr_ka = Array () Nonunique (ShapeDecl [NamedDim $ qualName k]) t_a - uarr_ka = Array () Unique (ShapeDecl [NamedDim $ qualName k]) t_a - arr_kb = Array () Nonunique (ShapeDecl [NamedDim $ qualName k]) t_b + arr_ka = Array () Nonunique (Shape [NamedSize $ qualName k]) t_a + uarr_ka = Array () Unique (Shape [NamedSize $ qualName k]) t_a + arr_kb = Array () Nonunique (Shape [NamedSize $ qualName k]) t_b karr x y = Scalar $ Arrow mempty (Named k) x (RetType [] y) accType t = - TypeVar () Unique (typeName (fst intrinsicAcc)) [TypeArgType t mempty] + TypeVar () Unique (qualName (fst intrinsicAcc)) [TypeArgType t mempty] namify i (x, y) = (VName (nameFromString x) i, y) @@ -1318,10 +1250,6 @@ qualify :: v -> QualName v -> QualName v qualify k (QualName ks v) = QualName (k : ks) v --- | Create a type name name with no qualifiers from a 'VName'. -typeName :: VName -> TypeName -typeName = typeNameFromQualName . qualName - -- | The modules imported by a Futhark program. progImports :: ProgBase f vn -> [(String, SrcLoc)] progImports = concatMap decImports . progDecs @@ -1461,7 +1389,7 @@ onExp e = astMap (identityMapper {mapOnExp = onExp}) e -- | A type with no aliasing information but shape annotations. -type UncheckedType = TypeBase (ShapeDecl Name) () +type UncheckedType = TypeBase (Shape Name) () -- | An expression with no type annotations. type UncheckedTypeExp = TypeExp 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 @@ -114,7 +114,8 @@ where vbind_t = foldFunType (map patternStructType (valBindParams vbind)) $ - unInfo $ valBindRetType vbind + unInfo $ + valBindRetType vbind typeBindDefs :: TypeBind -> Defs typeBindDefs tbind = @@ -232,7 +233,7 @@ where inArg (TypeArgExpDim dim _) = inDim dim inArg (TypeArgExpType e2) = atPosInTypeExp e2 pos - inDim (DimExpNamed qn loc) = do + inDim (SizeExpNamed qn loc) = do guard $ loc `contains` pos Just $ RawAtName qn $ locOf loc inDim _ = Nothing diff --git a/src/Language/Futhark/Semantic.hs b/src/Language/Futhark/Semantic.hs --- a/src/Language/Futhark/Semantic.hs +++ b/src/Language/Futhark/Semantic.hs @@ -174,15 +174,21 @@ ] where renderTypeBind (name, TypeAbbr l tps tp) = - p l <+> pprName name <> mconcat (map ((text " " <>) . ppr) tps) - <> text " =" <+> ppr tp + p l + <+> pprName name + <> mconcat (map ((text " " <>) . ppr) tps) + <> text " =" + <+> ppr tp where p Lifted = text "type^" p SizeLifted = text "type~" p Unlifted = text "type" renderValBind (name, BoundV tps t) = - text "val" <+> pprName name <> mconcat (map ((text " " <>) . ppr) tps) - <> text " =" <+> ppr t + text "val" + <+> pprName name + <> mconcat (map ((text " " <>) . ppr) tps) + <> text " =" + <+> ppr t renderModType (name, _sig) = text "module type" <+> pprName name renderMod (name, mod) = 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 @@ -10,6 +10,9 @@ -- the functor @f@, and all names are of type @vn@. See -- https://futhark.readthedocs.org for a language reference, or this -- module may be a little hard to understand. +-- +-- The system of primitive types is interesting in itself. See +-- "Language.Futhark.Primitive". module Language.Futhark.Syntax ( module Language.Futhark.Core, pretty, @@ -20,17 +23,13 @@ IntType (..), FloatType (..), PrimType (..), - ArrayDim (..), - DimDecl (..), - ShapeDecl (..), + Size (..), + Shape (..), shapeRank, stripDims, - TypeName (..), - typeNameFromQualName, - qualNameFromTypeName, TypeBase (..), TypeArg (..), - DimExp (..), + SizeExp (..), TypeExp (..), TypeArgExp (..), PName (..), @@ -112,15 +111,15 @@ import Data.Ord import qualified Data.Set as S import Data.Traversable -import Futhark.IR.Primitive +import Futhark.Util.Loc +import Futhark.Util.Pretty +import Language.Futhark.Core +import Language.Futhark.Primitive ( FloatType (..), FloatValue (..), IntType (..), IntValue (..), ) -import Futhark.Util.Loc -import Futhark.Util.Pretty -import Language.Futhark.Core import Prelude -- | No information functor. Usually used for placeholder type- or @@ -219,105 +218,53 @@ | AttrComp Name [AttrInfo vn] SrcLoc deriving (Eq, Ord, Show) --- | A type class for things that can be array dimensions. -class Eq dim => ArrayDim dim where - -- | @unifyDims x y@ combines @x@ and @y@ to contain their maximum - -- common information, and fails if they conflict. - unifyDims :: dim -> dim -> Maybe dim - -instance ArrayDim () where - unifyDims () () = Just () - --- | Declaration of a dimension size. -data DimDecl vn +-- | The elaborated size of a dimension. +data Size = -- | The size of the dimension is this name, which -- must be in scope. In a return type, this will -- give rise to an assertion. - NamedDim (QualName vn) + NamedSize (QualName VName) | -- | The size is a constant. - ConstDim Int + ConstSize Int | -- | No known size. If @Nothing@, then this is a name distinct -- from any other. The type checker should _never_ produce these -- - they are a (hopefully temporary) thing introduced by -- defunctorisation and monomorphisation. - AnyDim (Maybe vn) - deriving (Show) - -deriving instance Eq (DimDecl VName) - -deriving instance Ord (DimDecl VName) - -instance Functor DimDecl where - fmap = fmapDefault - -instance Foldable DimDecl where - foldMap = foldMapDefault - -instance Traversable DimDecl where - traverse f (NamedDim qn) = NamedDim <$> traverse f qn - traverse _ (ConstDim x) = pure $ ConstDim x - traverse f (AnyDim v) = AnyDim <$> traverse f v - --- Note that the notion of unifyDims here is intentionally not what we --- use when we do real type unification in the type checker. -instance ArrayDim (DimDecl VName) where - unifyDims AnyDim {} y = Just y - unifyDims x AnyDim {} = Just x - unifyDims (NamedDim x) (NamedDim y) | x == y = Just $ NamedDim x - unifyDims (ConstDim x) (ConstDim y) | x == y = Just $ ConstDim x - unifyDims _ _ = Nothing + AnySize (Maybe VName) + deriving (Eq, Ord, Show) -- | The size of an array type is a list of its dimension sizes. If -- 'Nothing', that dimension is of a (statically) unknown size. -newtype ShapeDecl dim = ShapeDecl {shapeDims :: [dim]} +newtype Shape dim = Shape {shapeDims :: [dim]} deriving (Eq, Ord, Show) -instance Foldable ShapeDecl where - foldr f x (ShapeDecl ds) = foldr f x ds +instance Foldable Shape where + foldr f x (Shape ds) = foldr f x ds -instance Traversable ShapeDecl where - traverse f (ShapeDecl ds) = ShapeDecl <$> traverse f ds +instance Traversable Shape where + traverse f (Shape ds) = Shape <$> traverse f ds -instance Functor ShapeDecl where - fmap f (ShapeDecl ds) = ShapeDecl $ map f ds +instance Functor Shape where + fmap f (Shape ds) = Shape $ map f ds -instance Semigroup (ShapeDecl dim) where - ShapeDecl l1 <> ShapeDecl l2 = ShapeDecl $ l1 ++ l2 +instance Semigroup (Shape dim) where + Shape l1 <> Shape l2 = Shape $ l1 ++ l2 -instance Monoid (ShapeDecl dim) where - mempty = ShapeDecl [] +instance Monoid (Shape dim) where + mempty = Shape [] -- | The number of dimensions contained in a shape. -shapeRank :: ShapeDecl dim -> Int +shapeRank :: Shape dim -> Int shapeRank = length . shapeDims -- | @stripDims n shape@ strips the outer @n@ dimensions from -- @shape@, returning 'Nothing' if this would result in zero or -- fewer dimensions. -stripDims :: Int -> ShapeDecl dim -> Maybe (ShapeDecl dim) -stripDims i (ShapeDecl l) - | i < length l = Just $ ShapeDecl $ drop i l +stripDims :: Int -> Shape dim -> Maybe (Shape dim) +stripDims i (Shape l) + | i < length l = Just $ Shape $ drop i l | otherwise = Nothing --- | A type name consists of qualifiers (for error messages) and a --- 'VName' (for equality checking). -data TypeName = TypeName {typeQuals :: [VName], typeLeaf :: VName} - deriving (Show) - -instance Eq TypeName where - TypeName _ x == TypeName _ y = x == y - -instance Ord TypeName where - TypeName _ x `compare` TypeName _ y = x `compare` y - --- | Convert a 'QualName' to a 'TypeName'. -typeNameFromQualName :: QualName VName -> TypeName -typeNameFromQualName (QualName qs x) = TypeName qs x - --- | Convert a 'TypeName' to a 'QualName'. -qualNameFromTypeName :: TypeName -> QualName VName -qualNameFromTypeName (TypeName qs x) = QualName qs x - -- | The name (if any) of a function parameter. The 'Eq' and 'Ord' -- instances always compare values of this type equal. data PName = Named VName | Unnamed @@ -351,7 +298,7 @@ -- convolutes the code too much if we try to statically rule it out. data ScalarTypeBase dim as = Prim PrimType - | TypeVar as Uniqueness TypeName [TypeArg dim] + | TypeVar as Uniqueness (QualName VName) [TypeArg dim] | Record (M.Map Name (TypeBase dim as)) | Sum (M.Map Name [TypeBase dim as]) | -- | The aliasing corresponds to the lexical @@ -381,7 +328,7 @@ -- out arrays-of-arrays. data TypeBase dim as = Scalar (ScalarTypeBase dim as) - | Array as Uniqueness (ShapeDecl dim) (ScalarTypeBase dim ()) + | Array as Uniqueness (Shape dim) (ScalarTypeBase dim ()) deriving (Eq, Ord, Show) instance Bitraversable TypeBase where @@ -426,39 +373,39 @@ -- | A type with aliasing information and shape annotations, used for -- describing the type patterns and expressions. -type PatType = TypeBase (DimDecl VName) Aliasing +type PatType = TypeBase Size Aliasing -- | A "structural" type with shape annotations and no aliasing -- information, used for declarations. -type StructType = TypeBase (DimDecl VName) () +type StructType = TypeBase Size () -- | A value type contains full, manifest size information. type ValueType = TypeBase Int64 () -- | The return type version of 'StructType'. -type StructRetType = RetTypeBase (DimDecl VName) () +type StructRetType = RetTypeBase Size () -- | The return type version of 'PatType'. -type PatRetType = RetTypeBase (DimDecl VName) Aliasing +type PatRetType = RetTypeBase Size Aliasing --- | A dimension declaration expression for use in a 'TypeExp'. -data DimExp vn +-- | A size expression for use in a 'TypeExp'. +data SizeExp vn = -- | The size of the dimension is this name, which -- must be in scope. - DimExpNamed (QualName vn) SrcLoc + SizeExpNamed (QualName vn) SrcLoc | -- | The size is a constant. - DimExpConst Int SrcLoc + SizeExpConst Int SrcLoc | -- | No dimension declaration. - DimExpAny + SizeExpAny deriving (Show) -deriving instance Eq (DimExp Name) +deriving instance Eq (SizeExp Name) -deriving instance Eq (DimExp VName) +deriving instance Eq (SizeExp VName) -deriving instance Ord (DimExp Name) +deriving instance Ord (SizeExp Name) -deriving instance Ord (DimExp VName) +deriving instance Ord (SizeExp VName) -- | An unstructured type with type variables and possibly shape -- declarations - this is what the user types in the source program. @@ -467,7 +414,7 @@ = TEVar (QualName vn) SrcLoc | TETuple [TypeExp vn] SrcLoc | TERecord [(Name, TypeExp vn)] SrcLoc - | TEArray (DimExp vn) (TypeExp vn) SrcLoc + | TEArray (SizeExp vn) (TypeExp vn) SrcLoc | TEUnique (TypeExp vn) SrcLoc | TEApply (TypeExp vn) (TypeArgExp vn) SrcLoc | TEArrow (Maybe vn) (TypeExp vn) (TypeExp vn) SrcLoc @@ -496,7 +443,7 @@ -- | A type argument expression passed to a type constructor. data TypeArgExp vn - = TypeArgExpDim (DimExp vn) SrcLoc + = TypeArgExpDim (SizeExp vn) SrcLoc | TypeArgExpType (TypeExp vn) deriving (Show) @@ -527,7 +474,7 @@ | -- | Only observes value in this position, does -- not consume. Observe - deriving (Eq, Show) + deriving (Eq, Ord, Show) -- | Simple Futhark values. Values are fully evaluated and their type -- is always unambiguous. @@ -636,8 +583,12 @@ deriving instance Eq (DimIndexBase NoInfo VName) +deriving instance Eq (DimIndexBase Info VName) + deriving instance Ord (DimIndexBase NoInfo VName) +deriving instance Ord (DimIndexBase Info VName) + -- | A slicing of an array (potentially multiple dimensions). type SliceBase f vn = [DimIndexBase f vn] @@ -749,8 +700,12 @@ deriving instance Eq (AppExpBase NoInfo VName) +deriving instance Eq (AppExpBase Info VName) + deriving instance Ord (AppExpBase NoInfo VName) +deriving instance Ord (AppExpBase Info VName) + instance Located (AppExpBase f vn) where locOf (Range _ _ _ pos) = locOf pos locOf (BinOp _ _ _ _ loc) = locOf loc @@ -857,6 +812,10 @@ deriving instance Ord (ExpBase NoInfo VName) +deriving instance Eq (ExpBase Info VName) + +deriving instance Ord (ExpBase Info VName) + instance Located (ExpBase f vn) where locOf (Literal _ loc) = locOf loc locOf (IntLit _ _ loc) = locOf loc @@ -897,8 +856,12 @@ deriving instance Eq (FieldBase NoInfo VName) +deriving instance Eq (FieldBase Info VName) + deriving instance Ord (FieldBase NoInfo VName) +deriving instance Ord (FieldBase Info VName) + instance Located (FieldBase f vn) where locOf (RecordFieldExplicit _ _ loc) = locOf loc locOf (RecordFieldImplicit _ _ loc) = locOf loc @@ -912,8 +875,12 @@ deriving instance Eq (CaseBase NoInfo VName) +deriving instance Eq (CaseBase Info VName) + deriving instance Ord (CaseBase NoInfo VName) +deriving instance Ord (CaseBase Info VName) + instance Located (CaseBase f vn) where locOf (CasePat _ _ loc) = locOf loc @@ -929,8 +896,12 @@ deriving instance Eq (LoopFormBase NoInfo VName) +deriving instance Eq (LoopFormBase Info VName) + deriving instance Ord (LoopFormBase NoInfo VName) +deriving instance Ord (LoopFormBase Info VName) + -- | A literal in a pattern. data PatLit = PatLitInt Integer @@ -957,7 +928,11 @@ deriving instance Eq (PatBase NoInfo VName) +deriving instance Eq (PatBase Info VName) + deriving instance Ord (PatBase NoInfo VName) + +deriving instance Ord (PatBase Info VName) instance Located (PatBase f vn) where locOf (TuplePat _ loc) = locOf loc 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 @@ -39,7 +39,6 @@ data ASTMapper m = ASTMapper { mapOnExp :: ExpBase Info VName -> m (ExpBase Info VName), mapOnName :: VName -> m VName, - mapOnQualName :: QualName VName -> m (QualName VName), mapOnStructType :: StructType -> m StructType, mapOnPatType :: PatType -> m PatType, mapOnStructRetType :: StructRetType -> m StructRetType, @@ -52,7 +51,6 @@ ASTMapper { mapOnExp = pure, mapOnName = pure, - mapOnQualName = pure, mapOnStructType = pure, mapOnPatType = pure, mapOnStructRetType = pure, @@ -67,9 +65,14 @@ -- into subexpressions. The mapping is done left-to-right. astMap :: Monad m => ASTMapper m -> x -> m x +instance ASTMappable (QualName VName) where + astMap tv = traverse (mapOnName tv) + instance ASTMappable (AppExpBase Info VName) where astMap tv (Range start next end loc) = - Range <$> mapOnExp tv start <*> traverse (mapOnExp tv) next + Range + <$> mapOnExp tv start + <*> traverse (mapOnExp tv) next <*> traverse (mapOnExp tv) end <*> pure loc astMap tv (If c texp fexp loc) = @@ -81,8 +84,11 @@ astMap tv (LetPat sizes pat e body loc) = LetPat <$> astMap tv sizes <*> astMap tv pat <*> mapOnExp tv e <*> mapOnExp tv body <*> pure loc astMap tv (LetFun name (fparams, params, ret, t, e) body loc) = - LetFun <$> mapOnName tv name - <*> ( (,,,,) <$> mapM (astMap tv) fparams <*> mapM (astMap tv) params + LetFun + <$> mapOnName tv name + <*> ( (,,,,) + <$> mapM (astMap tv) fparams + <*> mapM (astMap tv) params <*> traverse (astMap tv) ret <*> traverse (mapOnStructRetType tv) t <*> mapOnExp tv e @@ -100,17 +106,22 @@ astMap tv (Coerce e tdecl loc) = 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) + BinOp + <$> ((,) <$> astMap tv fname <*> pure fname_loc) <*> traverse (mapOnPatType tv) t - <*> ( (,) <$> mapOnExp tv x + <*> ( (,) + <$> mapOnExp tv x <*> (Info <$> ((,) <$> mapOnStructType tv xt <*> pure xext)) ) - <*> ( (,) <$> mapOnExp tv y + <*> ( (,) + <$> mapOnExp tv y <*> (Info <$> ((,) <$> mapOnStructType tv yt <*> pure yext)) ) <*> pure loc astMap tv (DoLoop sparams mergepat mergeexp form loopbody loc) = - DoLoop <$> mapM (mapOnName tv) sparams <*> astMap tv mergepat + DoLoop + <$> mapM (mapOnName tv) sparams + <*> astMap tv mergepat <*> mapOnExp tv mergeexp <*> astMap tv form <*> mapOnExp tv loopbody @@ -120,7 +131,9 @@ instance ASTMappable (ExpBase Info VName) where astMap tv (Var name t loc) = - Var <$> mapOnQualName tv name <*> traverse (mapOnPatType tv) t + Var + <$> astMap tv name + <*> traverse (mapOnPatType tv) t <*> pure loc astMap tv (Hole t loc) = Hole <$> traverse (mapOnPatType tv) t <*> pure loc @@ -135,7 +148,8 @@ astMap tv (Parens e loc) = Parens <$> mapOnExp tv e <*> pure loc astMap tv (QualParens (name, nameloc) e loc) = - QualParens <$> ((,) <$> mapOnQualName tv name <*> pure nameloc) + QualParens + <$> ((,) <$> astMap tv name <*> pure nameloc) <*> mapOnExp tv e <*> pure loc astMap tv (TupLit els loc) = @@ -151,11 +165,15 @@ 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 + Update + <$> mapOnExp tv src + <*> mapM (astMap tv) slice <*> mapOnExp tv v <*> pure loc astMap tv (RecordUpdate src fs v (Info t) loc) = - RecordUpdate <$> mapOnExp tv src <*> pure fs + RecordUpdate + <$> mapOnExp tv src + <*> pure fs <*> mapOnExp tv v <*> (Info <$> mapOnPatType tv t) <*> pure loc @@ -164,17 +182,20 @@ 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) = - Lambda <$> mapM (astMap tv) params + Lambda + <$> mapM (astMap tv) params <*> mapOnExp tv body <*> traverse (astMap tv) ret <*> traverse (traverse $ mapOnStructRetType tv) t <*> pure loc astMap tv (OpSection name t loc) = - OpSection <$> mapOnQualName tv name + OpSection + <$> astMap tv name <*> traverse (mapOnPatType tv) t <*> pure loc astMap tv (OpSectionLeft name t arg (Info (pa, t1a, argext), Info (pb, t1b)) (ret, retext) loc) = - OpSectionLeft <$> mapOnQualName tv name + OpSectionLeft + <$> astMap tv name <*> traverse (mapOnPatType tv) t <*> mapOnExp tv arg <*> ( (,) @@ -184,7 +205,8 @@ <*> ((,) <$> traverse (mapOnPatRetType tv) ret <*> traverse (mapM (mapOnName tv)) retext) <*> pure loc astMap tv (OpSectionRight name t arg (Info (pa, t1a), Info (pb, t1b, argext)) t2 loc) = - OpSectionRight <$> mapOnQualName tv name + OpSectionRight + <$> astMap tv name <*> traverse (mapOnPatType tv) t <*> mapOnExp tv arg <*> ( (,) @@ -196,7 +218,8 @@ astMap tv (ProjectSection fields t loc) = ProjectSection fields <$> traverse (mapOnPatType tv) t <*> pure loc astMap tv (IndexSection idxs t loc) = - IndexSection <$> mapM (astMap tv) idxs + IndexSection + <$> mapM (astMap tv) idxs <*> traverse (mapOnPatType tv) t <*> pure loc astMap tv (Constr name es ts loc) = @@ -212,7 +235,7 @@ astMap tv (While e) = While <$> mapOnExp tv e instance ASTMappable (TypeExp VName) where - astMap tv (TEVar qn loc) = TEVar <$> mapOnQualName tv qn <*> pure loc + astMap tv (TEVar qn loc) = TEVar <$> astMap tv qn <*> pure loc astMap tv (TETuple ts loc) = TETuple <$> traverse (astMap tv) ts <*> pure loc astMap tv (TERecord ts loc) = TERecord <$> traverse (traverse $ astMap tv) ts <*> pure loc @@ -234,16 +257,16 @@ astMap tv (TypeArgExpType te) = TypeArgExpType <$> astMap tv te -instance ASTMappable (DimExp VName) where - astMap tv (DimExpNamed vn loc) = - DimExpNamed <$> mapOnQualName tv vn <*> pure loc - astMap _ (DimExpConst k loc) = pure $ DimExpConst k loc - astMap _ DimExpAny = pure DimExpAny +instance ASTMappable (SizeExp VName) where + astMap tv (SizeExpNamed vn loc) = + SizeExpNamed <$> astMap tv vn <*> pure loc + astMap _ (SizeExpConst k loc) = pure $ SizeExpConst k loc + astMap _ SizeExpAny = pure SizeExpAny -instance ASTMappable (DimDecl VName) where - astMap tv (NamedDim vn) = NamedDim <$> mapOnQualName tv vn - astMap _ (ConstDim k) = pure $ ConstDim k - astMap tv (AnyDim vn) = AnyDim <$> traverse (mapOnName tv) vn +instance ASTMappable Size where + astMap tv (NamedSize vn) = NamedSize <$> astMap tv vn + astMap _ (ConstSize k) = pure $ ConstSize k + astMap tv (AnySize vn) = AnySize <$> traverse (mapOnName tv) vn instance ASTMappable (TypeParamBase VName) where astMap = traverse . mapOnName @@ -268,7 +291,7 @@ AppRes <$> mapOnPatType tv t <*> pure ext type TypeTraverser f t dim1 als1 dim2 als2 = - (TypeName -> f TypeName) -> + (QualName VName -> f (QualName VName)) -> (dim1 -> f dim2) -> (als1 -> f als2) -> t dim1 als1 -> @@ -282,7 +305,10 @@ traverseScalarType f g h (TypeVar als u t args) = TypeVar <$> h als <*> pure u <*> f t <*> traverse (traverseTypeArg f g) args traverseScalarType f g h (Arrow als v t1 (RetType dims t2)) = - Arrow <$> h als <*> pure v <*> traverseType f g pure t1 + Arrow + <$> h als + <*> pure v + <*> traverseType f g pure t1 <*> (RetType dims <$> traverseType f g h t2) traverseScalarType f g h (Sum cs) = Sum <$> (traverse . traverse) (traverseType f g h) cs @@ -295,7 +321,7 @@ traverseTypeArg :: Applicative f => - (TypeName -> f TypeName) -> + (QualName VName -> f (QualName VName)) -> (dim1 -> f dim2) -> TypeArg dim1 -> f (TypeArg dim2) @@ -305,14 +331,10 @@ TypeArgType <$> traverseType f g pure t <*> pure loc instance ASTMappable StructType where - astMap tv = traverseType f (astMap tv) pure - where - f = fmap typeNameFromQualName . mapOnQualName tv . qualNameFromTypeName + astMap tv = traverseType (astMap tv) (astMap tv) pure instance ASTMappable PatType where - astMap tv = traverseType f (astMap tv) (astMap tv) - where - f = fmap typeNameFromQualName . mapOnQualName tv . qualNameFromTypeName + astMap tv = traverseType (astMap tv) (astMap tv) (astMap tv) instance ASTMappable StructRetType where astMap tv (RetType ext t) = RetType ext <$> astMap tv t @@ -352,7 +374,8 @@ astMap tv (RecordFieldExplicit name e loc) = RecordFieldExplicit name <$> mapOnExp tv e <*> pure loc astMap tv (RecordFieldImplicit name t loc) = - RecordFieldImplicit <$> mapOnName tv name + RecordFieldImplicit + <$> mapOnName tv name <*> traverse (mapOnPatType tv) t <*> pure loc diff --git a/src/Language/Futhark/Tuple.hs b/src/Language/Futhark/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Language/Futhark/Tuple.hs @@ -0,0 +1,43 @@ +-- \* Basic utilities for interpreting tuples as records. +module Language.Futhark.Tuple + ( areTupleFields, + tupleFields, + tupleFieldNames, + sortFields, + ) +where + +import Data.Char (isDigit, ord) +import Data.List (sortOn) +import qualified Data.Map as M +import qualified Data.Text as T +import Language.Futhark.Core (Name, nameFromString, nameToText) + +-- | Does this record map correspond to a tuple? +areTupleFields :: M.Map Name a -> Maybe [a] +areTupleFields fs = + let fs' = sortFields fs + in if and $ zipWith (==) (map fst fs') tupleFieldNames + then Just $ map snd fs' + else Nothing + +-- | Construct a record map corresponding to a tuple. +tupleFields :: [a] -> M.Map Name a +tupleFields as = M.fromList $ zip tupleFieldNames as + +-- | Increasing field names for a tuple (starts at 0). +tupleFieldNames :: [Name] +tupleFieldNames = map (nameFromString . show) [(0 :: Int) ..] + +-- | Sort fields by their name; taking care to sort numeric fields by +-- their numeric value. This ensures that tuples and tuple-like +-- records match. +sortFields :: M.Map Name a -> [(Name, a)] +sortFields l = map snd $ sortOn fst $ zip (map (fieldish . fst) l') l' + where + l' = M.toList l + onDigit Nothing _ = Nothing + onDigit (Just d) c + | isDigit c = Just $ d * 10 + ord c - ord '0' + | otherwise = Nothing + fieldish s = maybe (Right s) Left $ T.foldl' onDigit (Just 0) $ nameToText s 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 @@ -11,6 +11,7 @@ checkExp, checkDec, checkModExp, + Notes, TypeError (..), Warnings, initialEnv, @@ -155,7 +156,8 @@ m a dupDefinitionError space name loc1 loc2 = typeError loc1 mempty $ - "Duplicate definition of" <+> ppr space + "Duplicate definition of" + <+> ppr space <+> pprName name <> ". Previously defined at" <+> text (locStr loc2) <> "." @@ -196,7 +198,7 @@ { envTypeTable = M.singleton v $ TypeAbbr l [] . RetType [] . Scalar $ - TypeVar () Nonunique (typeName v) [] + TypeVar () Nonunique (qualName v) [] } checkTypeDecl :: @@ -224,7 +226,8 @@ unless (null ext) $ typeError loc mempty $ "All function parameters must have non-anonymous sizes." - "Hint: add size parameters to" <+> pquote (pprName name') <> "." + "Hint: add size parameters to" + <+> pquote (pprName name') <> "." pure (tparams', vtype', vtype_t) @@ -260,7 +263,7 @@ envTypeTable = M.singleton name' $ TypeAbbr l ps' . RetType [] . Scalar $ - TypeVar () Nonunique (typeName name') $ + TypeVar () Nonunique (qualName name') $ map typeParamToArg ps' } (abstypes, env, specs') <- localEnv tenv $ checkSpecs specs @@ -551,7 +554,7 @@ (te', svars, RetType dims t, l') <- bindingTypeParams tps' $ checkTypeExp te let elab_t = RetType (svars ++ dims) t - let used_dims = typeDimNames t + let used_dims = freeInType t case filter ((`S.notMember` used_dims) . typeParamName) $ filter isSizeParam tps' of [] -> pure () @@ -598,7 +601,7 @@ -- Since the entry point type is not a RetType but just a plain -- StructType, we have to remove any existentially bound sizes. - extToAny (NamedDim v) | qualLeaf v `elem` ret = AnyDim Nothing + extToAny (NamedSize v) | qualLeaf v `elem` ret = AnySize Nothing extToAny d = d patternEntry (PatParens p _) = @@ -646,8 +649,8 @@ typeError loc mempty "Entry point functions may not be higher-order." | sizes_only_in_ret <- S.fromList (map typeParamName tparams') - `S.intersection` typeDimNames rettype' - `S.difference` foldMap typeDimNames (map patternStructType params' ++ rettype_params), + `S.intersection` freeInType rettype' + `S.difference` foldMap freeInType (map patternStructType params' ++ rettype_params), not $ S.null sizes_only_in_ret -> typeError loc mempty "Entry point functions must not be size-polymorphic in their return type." | p : _ <- filter nastyParameter params' -> @@ -730,7 +733,8 @@ checkOneDec (ImportDec name NoInfo loc) = do (name', env) <- lookupImport loc name when (isBuiltin name) $ - typeError loc mempty $ ppr name <+> "may not be explicitly imported." + typeError loc mempty $ + ppr name <+> "may not be explicitly imported." pure (mempty, env, ImportDec name (Info name') loc) checkOneDec (ValDec vb) = do (env, vb') <- checkValBind vb 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 @@ -58,7 +58,8 @@ allNamesInEnv :: Env -> S.Set VName allNamesInEnv (Env vtable ttable stable modtable _names) = S.fromList - ( M.keys vtable ++ M.keys ttable + ( M.keys vtable + ++ M.keys ttable ++ M.keys stable ++ M.keys modtable ) @@ -139,9 +140,9 @@ TypeParamType l (substitute p) loc substituteInType :: StructType -> StructType - substituteInType (Scalar (TypeVar () u (TypeName qs v) targs)) = + substituteInType (Scalar (TypeVar () u (QualName qs v) targs)) = Scalar $ - TypeVar () u (TypeName (map substitute qs) $ substitute v) $ + TypeVar () u (QualName (map substitute qs) $ substitute v) $ map substituteInTypeArg targs substituteInType (Scalar (Prim t)) = Scalar $ Prim t @@ -154,18 +155,18 @@ substituteInType (Scalar (Arrow als v t1 (RetType dims t2))) = Scalar $ Arrow als v (substituteInType t1) $ RetType dims $ substituteInType t2 - substituteInShape (ShapeDecl ds) = - ShapeDecl $ map substituteInDim ds - substituteInDim (NamedDim (QualName qs v)) = - NamedDim $ QualName (map substitute qs) $ substitute v + substituteInShape (Shape ds) = + Shape $ map substituteInDim ds + substituteInDim (NamedSize (QualName qs v)) = + NamedSize $ QualName (map substitute qs) $ substitute v substituteInDim d = d - substituteInTypeArg (TypeArgDim (NamedDim (QualName qs v)) loc) = - TypeArgDim (NamedDim $ QualName (map substitute qs) $ substitute v) loc - substituteInTypeArg (TypeArgDim (ConstDim x) loc) = - TypeArgDim (ConstDim x) loc - substituteInTypeArg (TypeArgDim (AnyDim v) loc) = - TypeArgDim (AnyDim v) loc + substituteInTypeArg (TypeArgDim (NamedSize (QualName qs v)) loc) = + TypeArgDim (NamedSize $ QualName (map substitute qs) $ substitute v) loc + substituteInTypeArg (TypeArgDim (ConstSize x) loc) = + TypeArgDim (ConstSize x) loc + substituteInTypeArg (TypeArgDim (AnySize v) loc) = + TypeArgDim (AnySize v) loc substituteInTypeArg (TypeArgType t loc) = TypeArgType (substituteInType t) loc @@ -193,7 +194,7 @@ StructType -> TypeM (QualName VName, TySet, Env) refineEnv loc tset env tname ps t - | Just (tname', TypeAbbr _ cur_ps (RetType _ (Scalar (TypeVar () _ (TypeName qs v) _)))) <- + | Just (tname', TypeAbbr _ cur_ps (RetType _ (Scalar (TypeVar () _ (QualName qs v) _)))) <- findTypeDef tname (ModEnv env), QualName (qualQuals tname') v `M.member` tset = if paramsMatch cur_ps ps @@ -285,7 +286,8 @@ Left . TypeError (locOf loc) mempty $ "Module defines" indent 2 (ppTypeAbbr abs name mod_t) - "but module type requires" <+> text what <> "." + "but module type requires" + <+> text what <> "." where what = case name_l of Unlifted -> "a non-lifted type" @@ -369,12 +371,14 @@ ppTypeAbbr :: [VName] -> QualName VName -> (Liftedness, [TypeParam], StructRetType) -> Doc ppTypeAbbr abs name (l, ps, RetType [] (Scalar (TypeVar () _ tn args))) - | typeLeaf tn `elem` abs, + | qualLeaf tn `elem` abs, map typeParamToArg ps == args = - "type" <> ppr l <+> ppr name + "type" <> ppr l + <+> ppr name <+> spread (map ppr ps) ppTypeAbbr _ name (l, ps, t) = - "type" <> ppr l <+> ppr name + "type" <> ppr l + <+> ppr name <+> spread (map ppr ps) <+> equals <+/> nest 2 (align (ppr t)) @@ -390,7 +394,7 @@ Either TypeError (M.Map VName VName) matchMTys orig_mty orig_mty_sig = matchMTys' - (M.map (SizeSubst . NamedDim) $ resolveMTyNames orig_mty orig_mty_sig) + (M.map (SizeSubst . NamedSize) $ resolveMTyNames orig_mty orig_mty_sig) [] orig_mty orig_mty_sig @@ -585,7 +589,10 @@ | otherwise -> Just Nothing ppValBind v (BoundV tps t) = - "val" <+> ppr v <+> spread (map ppr tps) <+> colon + "val" + <+> ppr v + <+> spread (map ppr tps) + <+> colon indent 2 (align (ppr t)) -- | Apply a parametric module to an argument. @@ -605,7 +612,7 @@ let a_abbrs = mtyTypeAbbrs a_mty isSub v = case M.lookup v a_abbrs of Just abbr -> Just $ substFromAbbr abbr - _ -> Just $ SizeSubst $ NamedDim $ qualName v + _ -> Just $ SizeSubst $ NamedSize $ qualName v type_subst = M.mapMaybe isSub p_subst body_mty' = substituteTypesInMTy (`M.lookup` type_subst) body_mty (body_mty'', body_subst) <- newNamesForMTy body_mty' 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 @@ -145,8 +145,9 @@ m a underscoreUse loc name = typeError loc mempty $ - "Use of" <+> pquote (ppr name) - <> ": variables prefixed with underscore may not be accessed." + "Use of" + <+> pquote (ppr name) + <> ": variables prefixed with underscore may not be accessed." -- | A mapping from import strings to 'Env's. This is used to resolve -- @import@ declarations. @@ -244,8 +245,10 @@ case M.lookup canonical_import imports of Nothing -> typeError loc mempty $ - "Unknown import" <+> dquotes (text canonical_import) - "Known:" <+> commasep (map text (M.keys imports)) + "Unknown import" + <+> dquotes (text canonical_import) + "Known:" + <+> commasep (map text (M.keys imports)) Just scope -> pure (canonical_import, scope) -- | Evaluate a 'TypeM' computation within an extended (/not/ @@ -280,14 +283,16 @@ lookupMod :: SrcLoc -> QualName Name -> m (QualName VName, Mod) lookupVar :: SrcLoc -> QualName Name -> m (QualName VName, PatType) - checkNamedDim :: SrcLoc -> QualName Name -> m (QualName VName) - checkNamedDim loc v = do + checkNamedSize :: SrcLoc -> QualName Name -> m (QualName VName) + checkNamedSize loc v = do (v', t) <- lookupVar loc v case t of Scalar (Prim (Signed Int64)) -> pure v' _ -> typeError loc mempty $ - "Sizes must have type i64, but" <+> pquote (ppr v) <+> "has type:" + "Sizes must have type i64, but" + <+> pquote (ppr v) + <+> "has type:" ppr t typeError :: Located loc => loc -> Notes -> Doc -> m a @@ -405,24 +410,22 @@ Env -> [VName] -> [VName] -> - TypeBase (DimDecl VName) as -> - TypeBase (DimDecl VName) as + TypeBase Size as -> + TypeBase Size as qualifyTypeVars outer_env orig_except ref_qs = onType (S.fromList orig_except) where onType :: S.Set VName -> - TypeBase (DimDecl VName) as -> - TypeBase (DimDecl VName) as + TypeBase Size as -> + TypeBase Size as onType except (Array as u shape et) = Array as u (fmap (onDim except) shape) (onScalar except et) onType except (Scalar t) = Scalar $ onScalar except t onScalar _ (Prim t) = Prim t - onScalar except (TypeVar as u tn targs) = - TypeVar as u tn' $ map (onTypeArg except) targs - where - tn' = typeNameFromQualName $ qual except $ qualNameFromTypeName tn + onScalar except (TypeVar as u qn targs) = + TypeVar as u (qual except qn) (map (onTypeArg except) targs) onScalar except (Record m) = Record $ M.map (onType except) m onScalar except (Sum m) = @@ -439,7 +442,7 @@ onTypeArg except (TypeArgType t loc) = TypeArgType (onType except t) loc - onDim except (NamedDim qn) = NamedDim $ qual except qn + onDim except (NamedSize qn) = NamedSize $ qual except qn onDim _ d = d qual except (QualName orig_qs name) @@ -458,7 +461,7 @@ name `M.member` envVtable env || isJust (find matches $ M.elems (envTypeTable env)) where - matches (TypeAbbr _ _ (RetType _ (Scalar (TypeVar _ _ (TypeName x_qs name') _)))) = + matches (TypeAbbr _ _ (RetType _ (Scalar (TypeVar _ _ (QualName x_qs name') _)))) = null x_qs && name == name' matches _ = False reachable (q : qs') name env diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -27,9 +27,9 @@ import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S -import Futhark.IR.Primitive (intByteSize) import Futhark.Util.Pretty hiding (bool, group, space) import Language.Futhark +import Language.Futhark.Primitive (intByteSize) import Language.Futhark.Traversals import Language.Futhark.TypeChecker.Match import Language.Futhark.TypeChecker.Monad hiding (BoundV) @@ -66,13 +66,13 @@ sliceShape :: Maybe (SrcLoc, Rigidity) -> Slice -> - TypeBase (DimDecl VName) as -> - TermTypeM (TypeBase (DimDecl VName) as, [VName]) -sliceShape r slice t@(Array als u (ShapeDecl orig_dims) et) = + TypeBase Size as -> + TermTypeM (TypeBase Size as, [VName]) +sliceShape r slice t@(Array als u (Shape orig_dims) et) = runStateT (setDims <$> adjustDims slice orig_dims) [] where setDims [] = stripArray (length orig_dims) t - setDims dims' = Array als u (ShapeDecl dims') et + setDims dims' = Array als u (Shape dims') et -- If the result is supposed to be a nonrigid size variable, then -- don't bother trying to create non-existential sizes. This is @@ -91,11 +91,11 @@ modify (maybeToList ext ++) pure d Just (loc, Nonrigid) -> - lift $ NamedDim . qualName <$> newDimVar loc Nonrigid "slice_dim" + lift $ NamedSize . qualName <$> newDimVar loc Nonrigid "slice_dim" Nothing -> do v <- lift $ newID "slice_anydim" modify (v :) - pure $ NamedDim $ qualName v + pure $ NamedSize $ qualName v where -- The original size does not matter if the slice is fully specified. orig_d' @@ -136,7 +136,7 @@ noAliasesIfOverloaded :: PatType -> TermTypeM PatType noAliasesIfOverloaded t@(Scalar (TypeVar _ u tn [])) = do - subst <- fmap snd . M.lookup (typeLeaf tn) <$> getConstraints + subst <- fmap snd . M.lookup (qualLeaf tn) <$> getConstraints case subst of Just Overloaded {} -> pure $ Scalar $ TypeVar mempty u tn [] _ -> pure t @@ -187,7 +187,7 @@ (t', m) <- runStateT (traverseDims onDim t) mempty pure (t' `addAliases` S.map unAlias, M.elems m) where - onDim bound _ (NamedDim d) + onDim bound _ (NamedSize d) | Just loc <- srclocOf <$> M.lookup (qualLeaf d) unscoped, not $ qualLeaf d `S.member` bound = inst loc $ qualLeaf d @@ -196,34 +196,15 @@ inst loc d = do prev <- gets $ M.lookup d case prev of - Just d' -> pure $ NamedDim $ qualName d' + Just d' -> pure $ NamedSize $ qualName d' Nothing -> do d' <- lift $ newDimVar tloc (Rigid $ RigidOutOfScope loc d) "d" modify $ M.insert d d' - pure $ NamedDim $ qualName d' + pure $ NamedSize $ qualName d' unAlias (AliasBound v) | v `M.member` unscoped = AliasFree v unAlias a = a --- 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 -> PatType -> TermTypeM PatType -addResultAliases r (Scalar (Record fs)) = - Scalar . Record <$> traverse (addResultAliases r) fs -addResultAliases r (Scalar (Sum fs)) = - Scalar . Sum <$> traverse (traverse (addResultAliases r)) fs -addResultAliases r (Scalar (TypeVar as u tn targs)) = do - v <- newID "internal_app_result" - modify $ \s -> s {stateNames = M.insert v r $ stateNames s} - pure $ Scalar $ TypeVar (S.insert (AliasFree v) as) u tn targs -addResultAliases _ (Scalar t@Prim {}) = pure (Scalar t) -addResultAliases _ (Scalar t@Arrow {}) = pure (Scalar t) -addResultAliases r (Array als u t shape) = do - v <- newID "internal_app_result" - modify $ \s -> s {stateNames = M.insert v r $ stateNames s} - pure $ Array (S.insert (AliasFree v) als) u t shape - -- 'checkApplyExp' is like 'checkExp', but tries to find the "root -- function", for better error messages. checkApplyExp :: UncheckedExp -> TermTypeM (Exp, ApplyOp) @@ -232,11 +213,10 @@ (e1', (fname, i)) <- checkApplyExp e1 t <- expType e1' (t1, rt, argext, exts) <- checkApply loc (fname, i) t arg - rt' <- addResultAliases (NameAppRes fname loc) rt pure ( AppExp (Apply e1' (argExp arg) (Info (diet t1, argext)) loc) - (Info $ AppRes rt' exts), + (Info $ AppRes rt exts), (fname, i + 1) ) checkApplyExp e = do @@ -288,7 +268,8 @@ case maybe_sloc of Just sloc -> lift . typeError rloc mempty $ - "Field" <+> pquote (ppr f) + "Field" + <+> pquote (ppr f) <+> "previously defined at" <+> text (locStrRel rloc sloc) <> "." Nothing -> pure () @@ -301,14 +282,14 @@ case all_es of [] -> do et <- newTypeVar loc "t" - t <- arrayOfM loc et (ShapeDecl [ConstDim 0]) Unique + t <- arrayOfM loc et (Shape [ConstSize 0]) Unique pure $ ArrayLit [] (Info t) loc e : es -> do e' <- checkExp e et <- expType e' es' <- mapM (unifies "type of first array element" (toStruct et) <=< checkExp) es et' <- normTypeFully et - t <- arrayOfM loc et' (ShapeDecl [ConstDim $ length all_es]) Unique + t <- arrayOfM loc et' (Shape [ConstSize $ length all_es]) Unique pure $ ArrayLit (e' : es') (Info t) loc checkExp (AppExp (Range start maybe_step end loc) _) = do start' <- require "use in range expression" anySignedType =<< checkExp start @@ -346,9 +327,9 @@ dimFromBound end'' _ -> do d <- newDimVar loc (Rigid RigidRange) "range_dim" - pure (NamedDim $ qualName d, Just d) + pure (NamedSize $ qualName d, Just d) - t <- arrayOfM loc start_t (ShapeDecl [dim]) Unique + t <- arrayOfM loc start_t (Shape [dim]) Unique let res = AppRes (t `setAliases` mempty) (maybeToList retext) pure $ AppExp (Range start' maybe_step' end' loc) (Info res) @@ -650,7 +631,7 @@ named (Unnamed, _) = Nothing param_names = mapMaybe (named . patternParam) params' pos_sizes = - typeDimNamesPos . foldFunType (map patternStructType params') $ + sizeNamesPos . foldFunType (map patternStructType params') $ RetType [] ret hide k (lvl, _) = lvl >= cur_lvl && k `notElem` param_names && k `S.notMember` pos_sizes @@ -658,11 +639,11 @@ hidden_sizes <- S.fromList . M.keys . M.filterWithKey hide <$> getConstraints - let onDim (NamedDim name) - | qualLeaf name `S.member` hidden_sizes = S.singleton $ qualLeaf name + let onDim name + | name `S.member` hidden_sizes = S.singleton name onDim _ = mempty - pure $ RetType (S.toList $ foldMap onDim $ nestedDims ret) ret + pure $ RetType (S.toList $ foldMap onDim $ freeInType ret) ret checkExp (OpSection op _ loc) = do (op', ftype) <- lookupVar loc op pure $ OpSection op' (Info ftype) loc @@ -801,20 +782,6 @@ 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 - where - checkUnmatched' (AppExp (Match _ cs loc) _) = - let ps = fmap (\(CasePat p _ _) -> p) cs - in case unmatched $ NE.toList ps of - [] -> pure () - ps' -> - typeError loc mempty . withIndexLink "unmatched-cases" $ - "Unmatched cases in match expression:" - indent 2 (stack (map ppr ps')) - checkUnmatched' _ = pure () - tv = identityMapper {mapOnExp = \e' -> checkUnmatched' e' >> pure e'} - checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident checkIdent (Ident name _ loc) = do (QualName _ name', vt) <- lookupVar loc (qualName name) @@ -854,8 +821,8 @@ instantiateDimsInReturnType :: SrcLoc -> Maybe (QualName VName) -> - RetTypeBase (DimDecl VName) als -> - TermTypeM (TypeBase (DimDecl VName) als, [VName]) + RetTypeBase Size als -> + TermTypeM (TypeBase Size als, [VName]) instantiateDimsInReturnType tloc fname = instantiateEmptyArrayDims tloc $ Rigid $ RigidRet fname @@ -865,7 +832,7 @@ type ApplyOp = (Maybe (QualName VName), Int) -- | Extract all those names that are bound inside the type. -boundInsideType :: TypeBase (DimDecl VName) as -> S.Set VName +boundInsideType :: TypeBase Size as -> S.Set VName boundInsideType (Array _ _ _ t) = boundInsideType (Scalar t) boundInsideType (Scalar Prim {}) = mempty boundInsideType (Scalar (TypeVar _ _ _ targs)) = foldMap f targs @@ -886,9 +853,9 @@ dimUses :: StructType -> (Names, Names) dimUses = flip execState mempty . traverseDims f where - f bound _ (NamedDim v) | qualLeaf v `S.member` bound = pure () - f _ PosImmediate (NamedDim v) = modify ((S.singleton (qualLeaf v), mempty) <>) - f _ PosParam (NamedDim v) = modify ((mempty, S.singleton (qualLeaf v)) <>) + f bound _ (NamedSize v) | qualLeaf v `S.member` bound = pure () + f _ PosImmediate (NamedSize v) = modify ((S.singleton (qualLeaf v), mempty) <>) + f _ PosParam (NamedSize v) = modify ((mempty, S.singleton (qualLeaf v)) <>) f _ _ _ = pure () checkApply :: @@ -943,14 +910,22 @@ case pname of Named pname' | (Scalar (Prim (Signed Int64))) <- tp1' -> do - (d, argext) <- dimFromArg fname argexp + (d, argext) <- sizeFromArg fname argexp pure ( argext, (`M.lookup` M.singleton pname' (SizeSubst d)) ) _ -> pure (Nothing, const Nothing) - let tp2'' = applySubst parsubst $ returnType tp2' (diet tp1') argtype' + -- In case 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, + -- uniqueness-error60.fut). + v <- newID "internal_app_result" + modify $ \s -> s {stateNames = M.insert v (NameAppRes fname loc) $ stateNames s} + let appres = S.singleton $ AliasFree v + let tp2'' = applySubst parsubst $ returnType appres tp2' (diet tp1') argtype' + pure (tp1', tp2'', argext, ext) checkApply loc fname tfun@(Scalar TypeVar {}) arg = do tv <- newTypeVar loc "b" @@ -958,7 +933,9 @@ -- to infer that a function is consuming. let argt_nonunique = toStruct (argType arg) `setUniqueness` Nonunique unify (mkUsage loc "use as function") (toStruct tfun) $ - Scalar $ Arrow mempty Unnamed argt_nonunique $ RetType [] tv + Scalar $ + Arrow mempty Unnamed argt_nonunique $ + RetType [] tv tfun' <- normPatType tfun checkApply loc fname tfun' arg checkApply loc (fname, prev_applied) ftype (argexp, _, _, _) = do @@ -967,10 +944,14 @@ typeError loc mempty $ if prev_applied == 0 then - "Cannot apply" <+> fname' <+> "as function, as it has type:" + "Cannot apply" + <+> fname' + <+> "as function, as it has type:" indent 2 (ppr ftype) else - "Cannot apply" <+> fname' <+> "to argument #" <> ppr (prev_applied + 1) + "Cannot apply" + <+> fname' + <+> "to argument #" <> ppr (prev_applied + 1) <+> pquote (shorten $ pretty $ flatten $ ppr argexp) <> "," <+/> "as" <+> fname' @@ -982,39 +963,40 @@ | prev_applied == 1 = "argument" | otherwise = "arguments" --- | @returnType ret_type arg_diet arg_type@ gives result of applying +-- | @returnType appres ret_type arg_diet arg_type@ gives result of applying -- an argument the given types to a function with the given return -- type, consuming the argument with the given diet. returnType :: + Aliasing -> PatType -> Diet -> PatType -> PatType -returnType (Array _ Unique et shape) _ _ = +returnType _ (Array _ Unique et shape) _ _ = Array mempty Nonunique et shape -- Intentional! -returnType (Array als Nonunique et shape) d arg = - Array (als <> arg_als) Nonunique et shape +returnType appres (Array als Nonunique et shape) d arg = + Array (appres <> als <> arg_als) Nonunique et shape where arg_als = aliases $ maskAliases arg d -returnType (Scalar (Record fs)) d arg = - Scalar $ Record $ fmap (\et -> returnType et d arg) fs -returnType (Scalar (Prim t)) _ _ = +returnType appres (Scalar (Record fs)) d arg = + Scalar $ Record $ fmap (\et -> returnType appres et d arg) fs +returnType _ (Scalar (Prim t)) _ _ = Scalar $ Prim t -returnType (Scalar (TypeVar _ Unique t targs)) _ _ = +returnType _ (Scalar (TypeVar _ Unique t targs)) _ _ = Scalar $ TypeVar mempty Nonunique t targs -- Intentional! -returnType (Scalar (TypeVar als Nonunique t targs)) d arg = - Scalar $ TypeVar (als <> arg_als) Unique t targs +returnType appres (Scalar (TypeVar als Nonunique t targs)) d arg = + Scalar $ TypeVar (appres <> als <> arg_als) Unique t targs where arg_als = aliases $ maskAliases arg d -returnType (Scalar (Arrow old_als v t1 (RetType dims t2))) d arg = +returnType _ (Scalar (Arrow old_als v t1 (RetType dims t2))) d arg = Scalar $ Arrow als v (t1 `setAliases` mempty) $ RetType dims $ t2 `setAliases` als where -- Make sure to propagate the aliases of an existing closure. als = old_als <> aliases (maskAliases arg d) -returnType (Scalar (Sum cs)) d arg = - Scalar $ Sum $ (fmap . fmap) (\et -> returnType et d arg) cs +returnType appres (Scalar (Sum cs)) d arg = + Scalar $ Sum $ (fmap . fmap) (\et -> returnType appres et d arg) cs --- | @t `maskAliases` d@ removes aliases (sets them to 'mempty') from +-- @t `maskAliases` d@ removes aliases (sets them to 'mempty') from -- the parts of @t@ that are denoted as consumed by the 'Diet' @d@. maskAliases :: Monoid as => @@ -1064,9 +1046,8 @@ letGeneralise (nameFromString "") (srclocOf e) [] [] t fixOverloadedTypes $ typeVars t e'' <- updateTypes e' - checkUnmatched e'' + localChecks e'' causalityCheck e'' - literalOverflowCheck e'' pure (tparams, e'') -- Verify that all sum type constructors and empty array literals have @@ -1079,7 +1060,9 @@ let checkCausality what known t loc | (d, dloc) : _ <- mapMaybe (unknown constraints known) $ - S.toList $ typeDimNames $ toStruct t = + S.toList $ + freeInType $ + toStruct t = Just $ lift $ causality what (locOf loc) d dloc t | otherwise = Nothing @@ -1162,7 +1145,8 @@ causality what loc d dloc t = Left . TypeError loc mempty . withIndexLink "causality-check" $ - "Causality check: size" <+/> pquote (pprName d) + "Causality check: size" + <+/> pquote (pprName d) <+/> "needed for type of" <+> what <> colon indent 2 (ppr t) @@ -1173,31 +1157,53 @@ "" "Hint:" <+> align - ( textwrap "Bind the expression producing" <+> pquote (pprName d) + ( textwrap "Bind the expression producing" + <+> pquote (pprName d) <+> "with 'let' beforehand." ) --- | Traverse the expression, emitting warnings if any of the literals overflow --- their inferred types +-- | Traverse the expression, emitting warnings and errors for various +-- problems: -- --- Note: currently unable to detect float underflow (such as 1e-400 -> 0) -literalOverflowCheck :: Exp -> TermTypeM () -literalOverflowCheck = void . check +-- * Unmatched cases. +-- +-- * If any of the literals overflow their inferred types. Note: +-- currently unable to detect float underflow (such as 1e-400 -> 0) +localChecks :: Exp -> TermTypeM () +localChecks = void . check where + check e@(AppExp (Match _ cs loc) _) = do + let ps = fmap (\(CasePat p _ _) -> p) cs + case unmatched $ NE.toList ps of + [] -> recurse e + ps' -> + typeError loc mempty . withIndexLink "unmatched-cases" $ + "Unmatched cases in match expression:" + indent 2 (stack (map ppr ps')) check e@(IntLit x ty loc) = e <$ case ty of - Info (Scalar (Prim t)) -> warnBounds (inBoundsI x t) x t loc + Info (Scalar (Prim t)) -> errorBounds (inBoundsI x t) x t loc _ -> error "Inferred type of int literal is not a number" check e@(FloatLit x ty loc) = e <$ case ty of - Info (Scalar (Prim (FloatType t))) -> warnBounds (inBoundsF x t) x t loc + Info (Scalar (Prim (FloatType t))) -> errorBounds (inBoundsF x t) x t loc _ -> error "Inferred type of float literal is not a float" check e@(Negate (IntLit x ty loc1) loc2) = e <$ case ty of - Info (Scalar (Prim t)) -> warnBounds (inBoundsI (-x) t) (-x) t (loc1 <> loc2) + Info (Scalar (Prim t)) -> errorBounds (inBoundsI (-x) t) (-x) t (loc1 <> loc2) _ -> error "Inferred type of int literal is not a number" - check e = astMap identityMapper {mapOnExp = check} e + check e@(AppExp (BinOp (QualName [] v, _) _ (_, Info (Array {}, _)) _ loc) _) + | baseName v == "==", + baseTag v <= maxIntrinsicTag = do + warn loc $ + textwrap + "Comparing arrays with \"==\" is deprecated and will stop working in a future revision of the language." + recurse e + check e = recurse e + recurse = astMap identityMapper {mapOnExp = check} + 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) @@ -1207,10 +1213,12 @@ 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 = + + errorBounds inBounds x ty loc = unless inBounds $ typeError loc mempty . withIndexLink "literal-out-of-bounds" $ - "Literal " <> ppr x + "Literal " + <> ppr x <> " out of bounds for inferred type " <> ppr ty <> "." @@ -1250,14 +1258,11 @@ maybe_retdecl'' <- traverse updateTypes maybe_retdecl' rettype'' <- normTypeFully rettype' - -- Check if pattern matches are exhaustive and yield - -- errors if not. - checkUnmatched body'' - -- Check if the function body can actually be evaluated. causalityCheck body'' - literalOverflowCheck body'' + -- Check for various problems. + localChecks body'' bindSpaced [(Term, fname)] $ do fname' <- checkName Term fname loc @@ -1275,23 +1280,29 @@ where fixOverloaded (v, Overloaded ots usage) | Signed Int32 `elem` ots = do - unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $ - Scalar $ Prim $ Signed Int32 + unify usage (Scalar (TypeVar () Nonunique (qualName v) [])) $ + Scalar $ + Prim $ + Signed Int32 when (v `S.member` tyvars_at_toplevel) $ warn usage "Defaulting ambiguous type to i32." | FloatType Float64 `elem` ots = do - unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $ - Scalar $ Prim $ FloatType Float64 + unify usage (Scalar (TypeVar () Nonunique (qualName v) [])) $ + Scalar $ + Prim $ + FloatType Float64 when (v `S.member` tyvars_at_toplevel) $ warn usage "Defaulting ambiguous type to f64." | otherwise = typeError usage mempty . withIndexLink "ambiguous-type" $ - "Type is ambiguous (could be one of" <+> commasep (map ppr ots) <> ")." + "Type is ambiguous (could be one of" + <+> commasep (map ppr ots) <> ")." "Add a type annotation to disambiguate the type." fixOverloaded (v, NoConstraint _ usage) = do -- See #1552. - unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $ - Scalar $ tupleRecord [] + unify usage (Scalar (TypeVar () Nonunique (qualName v) [])) $ + Scalar $ + tupleRecord [] when (v `S.member` tyvars_at_toplevel) $ warn usage "Defaulting ambiguous type to ()." fixOverloaded (_, Equality usage) = @@ -1335,7 +1346,8 @@ -- These we must turn into fresh type variables, which will be -- existential in the return type. fmap (toStruct . fst) $ - unscopeType loc hidden_params $ inferReturnUniqueness params t + unscopeType loc hidden_params $ + inferReturnUniqueness params t where hidden_params = M.filterWithKey (const . (`S.member` hidden)) $ foldMap patternMap params hidden = hiddenParamNames params @@ -1429,18 +1441,18 @@ -- | Extract all the shape names that occur in positive position -- (roughly, left side of an arrow) in a given type. -typeDimNamesPos :: TypeBase (DimDecl VName) als -> S.Set VName -typeDimNamesPos (Scalar (Arrow _ _ t1 (RetType _ t2))) = onParam t1 <> typeDimNamesPos t2 +sizeNamesPos :: TypeBase Size als -> S.Set VName +sizeNamesPos (Scalar (Arrow _ _ t1 (RetType _ t2))) = onParam t1 <> sizeNamesPos t2 where - onParam :: TypeBase (DimDecl VName) als -> S.Set VName + onParam :: TypeBase Size als -> S.Set VName onParam (Scalar Arrow {}) = mempty onParam (Scalar (Record fs)) = mconcat $ map onParam $ M.elems fs onParam (Scalar (TypeVar _ _ _ targs)) = mconcat $ map onTypeArg targs - onParam t = typeDimNames t - onTypeArg (TypeArgDim (NamedDim d) _) = S.singleton $ qualLeaf d + onParam t = freeInType t + onTypeArg (TypeArgDim (NamedSize d) _) = S.singleton $ qualLeaf d onTypeArg (TypeArgDim _ _) = mempty onTypeArg (TypeArgType t _) = onParam t -typeDimNamesPos _ = mempty +sizeNamesPos _ = mempty checkGlobalAliases :: [Pat] -> PatType -> SrcLoc -> TermTypeM () checkGlobalAliases params body_t loc = do @@ -1457,7 +1469,9 @@ "Function result aliases the free variable " <> pquote (pprName v) <> "." - "Use" <+> pquote "copy" <+> "to break the aliasing." + "Use" + <+> pquote "copy" + <+> "to break the aliasing." _ -> pure () @@ -1521,17 +1535,19 @@ verifyParams (foldMap patNames params) =<< mapM updateTypes params where verifyParams forbidden (p : ps) - | d : _ <- S.toList $ patternDimNames p `S.intersection` forbidden = + | d : _ <- S.toList $ freeInPat p `S.intersection` forbidden = typeError p mempty . withIndexLink "inaccessible-size" $ - "Parameter" <+> pquote (ppr p) - <+/> "refers to size" <+> pquote (pprName d) - <> comma + "Parameter" + <+> pquote (ppr p) + <+/> "refers to size" + <+> pquote (pprName d) + <> comma <+/> textwrap "which will not be accessible to the caller" - <> comma + <> comma <+/> textwrap "possibly because it is nested in a tuple or record." <+/> textwrap "Consider ascribing an explicit type that does not reference " - <> pquote (pprName d) - <> "." + <> pquote (pprName d) + <> "." | otherwise = verifyParams forbidden' ps where forbidden' = @@ -1587,20 +1603,18 @@ (more_tparams, retext) <- partitionEithers . catMaybes <$> mapM closeOver (M.toList $ M.map snd to_close_over) - let mkExt (NamedDim v) = - case M.lookup (qualLeaf v) substs of - Just (_, UnknowableSize {}) -> Just $ qualLeaf v + let mkExt v = + case M.lookup v substs of + Just (_, UnknowableSize {}) -> Just v _ -> Nothing - mkExt ConstDim {} = Nothing - mkExt AnyDim {} = error "closeOverTypes: AnyDim" pure ( tparams ++ more_tparams, - injectExt (retext ++ mapMaybe mkExt (nestedDims ret)) ret + injectExt (retext ++ mapMaybe mkExt (S.toList $ freeInType ret)) ret ) where t = foldFunType paramts $ RetType [] ret to_close_over = M.filterWithKey (\k _ -> k `S.member` visible) substs - visible = typeVars t <> typeDimNames t + visible = typeVars t <> freeInType t (produced_sizes, param_sizes) = dimUses t @@ -1617,12 +1631,13 @@ closeOver (k, UnknowableSize _ _) | k `S.member` param_sizes, k `S.notMember` produced_sizes = do - notes <- dimNotes defloc $ NamedDim $ qualName k + notes <- dimNotes defloc $ NamedSize $ qualName k typeError defloc notes . withIndexLink "unknowable-param-def" $ - "Unknowable size" <+> pquote (pprName k) + "Unknowable size" + <+> pquote (pprName k) <+> "in parameter of" <+> pquote (pprName defname) - <> ", which is inferred as:" + <> ", which is inferred as:" indent 2 (ppr t) | k `S.member` produced_sizes = pure $ Just $ Right k @@ -1672,7 +1687,7 @@ rettype'' <- updateTypes rettype' let used_sizes = - foldMap typeDimNames $ rettype'' : map patternStructType params + foldMap freeInType $ rettype'' : map patternStructType params case filter ((`S.notMember` used_sizes) . typeParamName) $ filter isSizeParam tparams' of [] -> pure () @@ -1710,16 +1725,17 @@ let usage = mkUsage (srclocOf body) "return type annotation" onFailure (CheckingReturn rettype (toStruct body_t')) $ - expect usage rettype $ toStruct body_t' + expect usage rettype $ + toStruct body_t' Nothing -> pure () pure body' arrayOfM :: - (Pretty (ShapeDecl dim), Monoid as) => + (Pretty (Shape dim), Monoid as) => SrcLoc -> TypeBase dim as -> - ShapeDecl dim -> + Shape dim -> Uniqueness -> TermTypeM (TypeBase dim as) arrayOfM loc t shape u = do diff --git a/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs b/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs --- a/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs +++ b/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs @@ -36,14 +36,14 @@ Rigidity -> Name -> S.Set VName -> - TypeBase (DimDecl VName) als -> - TermTypeM (TypeBase (DimDecl VName) als) + TypeBase Size als -> + TermTypeM (TypeBase Size als) someDimsFreshInType loc r desc sizes = bitraverse onDim pure where - onDim (NamedDim d) + onDim (NamedSize d) | qualLeaf d `S.member` sizes = do v <- newDimVar loc r desc - pure $ NamedDim $ qualName v + pure $ NamedSize $ qualName v onDim d = pure d -- | Replace the specified sizes with fresh size variables of the @@ -53,20 +53,20 @@ Rigidity -> Name -> S.Set VName -> - TypeBase (DimDecl VName) als -> - TermTypeM (TypeBase (DimDecl VName) als, [VName]) + TypeBase Size als -> + TermTypeM (TypeBase Size als, [VName]) freshDimsInType loc r desc sizes t = second M.elems <$> runStateT (bitraverse onDim pure t) mempty where - onDim (NamedDim d) + onDim (NamedSize d) | qualLeaf d `S.member` sizes = do prev_subst <- gets $ M.lookup $ qualLeaf d case prev_subst of - Just d' -> pure $ NamedDim $ qualName d' + Just d' -> pure $ NamedSize $ qualName d' Nothing -> do v <- lift $ newDimVar loc r desc modify $ M.insert (qualLeaf d) v - pure $ NamedDim $ qualName v + pure $ NamedSize $ qualName v onDim d = pure d -- | Mark bindings of names in "consumed" as Unique. @@ -132,10 +132,10 @@ ( unique pat_v_t && not (S.null (aliases t `S.intersection` (cons <> obs))) ) - $ lift . typeError loop_loc mempty $ - "Return value for consuming loop parameter" - <+> pquote (pprName pat_v) - <+> "aliases previously returned value." + $ lift . typeError loop_loc mempty + $ "Return value for consuming loop parameter" + <+> pquote (pprName pat_v) + <+> "aliases previously returned value." if unique pat_v_t then put (cons <> aliases t, obs) else put (cons, obs <> aliases t) @@ -171,7 +171,8 @@ wellTypedLoopArg src sparams pat arg = do (merge_t, _) <- freshDimsInType (srclocOf arg) Nonrigid "loop" (S.fromList sparams) $ - toStruct $ patternType pat + toStruct $ + patternType pat arg_t <- toStruct <$> expTypeFully arg onFailure (checking merge_t arg_t) $ unify @@ -255,7 +256,7 @@ -- new_dims in the pattern is unique and distinct. let onDims _ x y | x == y = pure x - onDims _ (NamedDim v) d + onDims _ (NamedSize v) d | qualLeaf v `elem` new_dims = do case M.lookup (qualLeaf v) new_dims_to_initial_dim of Just d' @@ -263,7 +264,7 @@ modify $ first $ M.insert (qualLeaf v) (SizeSubst d) _ -> modify $ second (qualLeaf v :) - pure $ NamedDim v + pure $ NamedSize v onDims _ x _ = pure x loopbody_t' <- normTypeFully loopbody_t merge_t' <- normTypeFully merge_t @@ -345,7 +346,8 @@ <+> ppr t While cond -> noUnique . bindingPat [] mergepat (Ascribed merge_t) $ \mergepat' -> - onlySelfAliasing . tapOccurrences + onlySelfAliasing + . tapOccurrences . sequentially ( checkExp cond >>= unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool) diff --git a/src/Language/Futhark/TypeChecker/Terms/Monad.hs b/src/Language/Futhark/TypeChecker/Terms/Monad.hs --- a/src/Language/Futhark/TypeChecker/Terms/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Terms/Monad.hs @@ -45,7 +45,7 @@ isInt64, maybeDimFromExp, dimFromExp, - dimFromArg, + sizeFromArg, noSizeEscape, -- * Control flow @@ -241,7 +241,8 @@ useAfterConsume name rloc wloc = do name' <- describeVar rloc name typeError rloc mempty . withIndexLink "use-after-consume" $ - "Using" <+> name' <> ", but this was consumed at" + "Using" + <+> name' <> ", but this was consumed at" <+> text (locStrRel rloc wloc) <> ". (Possibly through aliasing.)" badLetWithValue :: (Pretty arr, Pretty src) => arr -> src -> SrcLoc -> TermTypeM a @@ -251,7 +252,9 @@ indent 2 (ppr arre) "might alias update value" indent 2 (ppr vale) - "Hint: use" <+> pquote "copy" <+> "to remove aliases from the value." + "Hint: use" + <+> pquote "copy" + <+> "to remove aliases from the value." returnAliased :: Name -> SrcLoc -> TermTypeM () returnAliased name loc = @@ -296,8 +299,10 @@ instance Pretty Checking where ppr (CheckingApply f e expected actual) = header - "Expected:" <+> align (ppr expected) - "Actual: " <+> align (ppr actual) + "Expected:" + <+> align (ppr expected) + "Actual: " + <+> align (ppr actual) where header = case f of @@ -305,16 +310,22 @@ "Cannot apply function to" <+> pquote (shorten $ pretty $ flatten $ ppr e) <> " (invalid type)." Just fname -> - "Cannot apply" <+> pquote (ppr fname) <+> "to" + "Cannot apply" + <+> pquote (ppr fname) + <+> "to" <+> pquote (shorten $ pretty $ flatten $ ppr e) <> " (invalid type)." ppr (CheckingReturn expected actual) = "Function body does not have expected type." - "Expected:" <+> align (ppr expected) - "Actual: " <+> align (ppr actual) + "Expected:" + <+> align (ppr expected) + "Actual: " + <+> align (ppr actual) ppr (CheckingAscription expected actual) = "Expression does not have expected type from explicit ascription." - "Expected:" <+> align (ppr expected) - "Actual: " <+> align (ppr actual) + "Expected:" + <+> align (ppr expected) + "Actual: " + <+> align (ppr actual) ppr (CheckingLetGeneralise fname) = "Cannot generalise type of" <+> pquote (ppr fname) <> "." ppr (CheckingParams fname) = @@ -324,35 +335,49 @@ ppr (CheckingPat pat NoneInferred) = "Invalid pattern" <+> pquote (ppr pat) <> "." ppr (CheckingPat pat (Ascribed t)) = - "Pat" <+> pquote (ppr pat) + "Pat" + <+> pquote (ppr pat) <+> "cannot match value of type" indent 2 (ppr t) ppr (CheckingLoopBody expected actual) = "Loop body does not have expected type." - "Expected:" <+> align (ppr expected) - "Actual: " <+> align (ppr actual) + "Expected:" + <+> align (ppr expected) + "Actual: " + <+> align (ppr actual) ppr (CheckingLoopInitial expected actual) = "Initial loop values do not have expected type." - "Expected:" <+> align (ppr expected) - "Actual: " <+> align (ppr actual) + "Expected:" + <+> align (ppr expected) + "Actual: " + <+> align (ppr actual) ppr (CheckingRecordUpdate fs expected actual) = - "Type mismatch when updating record field" <+> pquote fs' <> "." - "Existing:" <+> align (ppr expected) - "New: " <+> align (ppr actual) + "Type mismatch when updating record field" + <+> pquote fs' <> "." + "Existing:" + <+> align (ppr expected) + "New: " + <+> align (ppr actual) where fs' = mconcat $ punctuate "." $ map ppr fs ppr (CheckingRequired [expected] actual) = - "Expression must must have type" <+> ppr expected <> "." - "Actual type:" <+> align (ppr actual) + "Expression must must have type" + <+> ppr expected <> "." + "Actual type:" + <+> align (ppr actual) ppr (CheckingRequired expected actual) = - "Type of expression must must be one of " <+> expected' <> "." - "Actual type:" <+> align (ppr actual) + "Type of expression must must be one of " + <+> expected' <> "." + "Actual type:" + <+> align (ppr actual) where expected' = commasep (map ppr expected) ppr (CheckingBranches t1 t2) = "Branches differ in type." - "Former:" <+> ppr t1 - "Latter:" <+> ppr t2 + "Former:" + <+> ppr t1 + "Latter:" + <+> ppr t2 -- | Type checking happens with access to this environment. The -- 'TermScope' will be extended during type-checking as bindings come into @@ -413,7 +438,7 @@ = SourceArg FName (ExpBase NoInfo VName) | SourceBound (ExpBase NoInfo VName) | SourceSlice - (Maybe (DimDecl VName)) + (Maybe Size) (Maybe (ExpBase NoInfo VName)) (Maybe (ExpBase NoInfo VName)) (Maybe (ExpBase NoInfo VName)) @@ -429,7 +454,8 @@ nameReason loc (NameAppRes Nothing apploc) = "result of application at" <+> text (locStrRel loc apploc) nameReason loc (NameAppRes fname apploc) = - "result of applying" <+> pquote (ppr fname) + "result of applying" + <+> pquote (ppr fname) <+> parens ("at" <+> text (locStrRel loc apploc)) -- | The state is a set of constraints and a counter for generating @@ -481,7 +507,7 @@ i <- incCounter v <- newID $ mkTypeVarName desc i constrain v $ NoConstraint Lifted $ mkUsage' loc - pure $ Scalar $ TypeVar mempty Nonunique (typeName v) [] + pure $ Scalar $ TypeVar mempty Nonunique (qualName v) [] curLevel = asks termLevel @@ -556,11 +582,11 @@ TypeParamType x _ _ -> do constrain v . NoConstraint x . mkUsage loc $ "instantiated type parameter of " <> quote (pretty qn) <> "." - pure (v, Subst [] $ RetType [] $ Scalar $ TypeVar mempty Nonunique (typeName v) []) + pure (v, Subst [] $ RetType [] $ Scalar $ TypeVar mempty Nonunique (qualName v) []) TypeParamDim {} -> do constrain v . Size Nothing . mkUsage loc $ "instantiated size parameter of " <> quote (pretty qn) <> "." - pure (v, SizeSubst $ NamedDim $ qualName v) + pure (v, SizeSubst $ NamedSize $ qualName v) checkQualNameWithEnv :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName) checkQualNameWithEnv space qn@(QualName quals name) loc = do @@ -660,7 +686,11 @@ equalityType usage argtype pure $ Scalar . Arrow mempty Unnamed argtype . RetType [] $ - Scalar $ Arrow mempty Unnamed argtype $ RetType [] $ Scalar $ Prim Bool + Scalar $ + Arrow mempty Unnamed argtype $ + RetType [] $ + Scalar $ + Prim Bool Just (OverloadedF ts pts rt) -> do argtype <- newTypeVar loc "t" mustBeOneOf ts usage argtype @@ -676,11 +706,13 @@ maybe (toStruct argtype) (Scalar . Prim) rt ) - checkNamedDim loc v = do + checkNamedSize loc v = do (v', t) <- lookupVar loc v onFailure (CheckingRequired [Scalar $ Prim $ Signed Int64] (toStruct t)) $ unify (mkUsage loc "use as array size") (toStruct t) $ - Scalar $ Prim $ Signed Int64 + Scalar $ + Prim $ + Signed Int64 pure v' typeError loc notes s = do @@ -694,7 +726,7 @@ onFailure :: Checking -> TermTypeM a -> TermTypeM a onFailure c = local $ \env -> env {termChecking = Just c} -extSize :: SrcLoc -> SizeSource -> TermTypeM (DimDecl VName, Maybe VName) +extSize :: SrcLoc -> SizeSource -> TermTypeM (Size, Maybe VName) extSize loc e = do prev <- gets $ M.lookup e . stateDimTable case prev of @@ -709,12 +741,12 @@ d <- newDimVar loc (Rigid rsrc) "n" modify $ \s -> s {stateDimTable = M.insert e d $ stateDimTable s} pure - ( NamedDim $ qualName d, + ( NamedSize $ qualName d, Just d ) Just d -> pure - ( NamedDim $ qualName d, + ( NamedSize $ qualName d, Just d ) @@ -739,9 +771,9 @@ v <- newTypeName desc constrain v $ NoConstraint Unlifted $ mkUsage' loc dims <- replicateM r $ newDimVar loc Nonrigid "dim" - let rowt = TypeVar () Nonunique (typeName v) [] + let rowt = TypeVar () Nonunique (qualName v) [] pure - ( Array () Nonunique (ShapeDecl $ map (NamedDim . qualName) dims) rowt, + ( Array () Nonunique (Shape $ map (NamedSize . qualName) dims) rowt, Scalar rowt ) @@ -750,15 +782,15 @@ SrcLoc -> Rigidity -> Name -> - TypeBase (DimDecl VName) als -> - TermTypeM (TypeBase (DimDecl VName) als, M.Map VName (DimDecl VName)) + TypeBase Size als -> + TermTypeM (TypeBase Size als, M.Map VName Size) allDimsFreshInType loc r desc t = runStateT (bitraverse onDim pure t) mempty where onDim d = do v <- lift $ newDimVar loc r desc modify $ M.insert v d - pure $ NamedDim $ qualName v + pure $ NamedSize $ qualName v -- | Replace all type variables with their concrete types. updateTypes :: ASTMappable e => e -> TermTypeM e @@ -768,7 +800,6 @@ ASTMapper { mapOnExp = astMap tv, mapOnName = pure, - mapOnQualName = pure, mapOnStructType = normTypeFully, mapOnPatType = normTypeFully, mapOnStructRetType = normTypeFully, @@ -801,12 +832,11 @@ -- Observe the sizes so we do not get any warnings about them not -- being used. - mapM_ observeDim $ nestedDims st + mapM_ observeDim $ freeInType st pure (te', svars, RetType dims st) where - observeDim (NamedDim v) = - observe $ Ident (qualLeaf v) (Info $ Scalar $ Prim $ Signed Int64) mempty - observeDim _ = pure () + observeDim v = + observe $ Ident v (Info $ Scalar $ Prim $ Signed Int64) mempty checkTypeExpNonrigid :: TypeExp Name -> TermTypeM (TypeExp VName, StructType, [VName]) checkTypeExpNonrigid te = do @@ -833,13 +863,13 @@ isInt64 (Negate x _) = negate <$> isInt64 x isInt64 _ = Nothing -maybeDimFromExp :: Exp -> Maybe (DimDecl VName) -maybeDimFromExp (Var v _ _) = Just $ NamedDim v +maybeDimFromExp :: Exp -> Maybe Size +maybeDimFromExp (Var v _ _) = Just $ NamedSize v maybeDimFromExp (Parens e _) = maybeDimFromExp e maybeDimFromExp (QualParens _ e _) = maybeDimFromExp e -maybeDimFromExp e = ConstDim . fromIntegral <$> isInt64 e +maybeDimFromExp e = ConstSize . fromIntegral <$> isInt64 e -dimFromExp :: (Exp -> SizeSource) -> Exp -> TermTypeM (DimDecl VName, Maybe VName) +dimFromExp :: (Exp -> SizeSource) -> Exp -> TermTypeM (Size, Maybe VName) dimFromExp rf (Attr _ e _) = dimFromExp rf e dimFromExp rf (Assert _ e _ _) = dimFromExp rf e dimFromExp rf (Parens e _) = dimFromExp rf e @@ -850,8 +880,8 @@ | otherwise = extSize (srclocOf e) $ rf e -dimFromArg :: Maybe (QualName VName) -> Exp -> TermTypeM (DimDecl VName, Maybe VName) -dimFromArg fname = dimFromExp $ SourceArg (FName fname) . bareExp +sizeFromArg :: Maybe (QualName VName) -> Exp -> TermTypeM (Size, Maybe VName) +sizeFromArg fname = dimFromExp $ SourceArg (FName fname) . bareExp -- | Any argument sizes created with 'extSize' inside the given action -- will be removed once the action finishes. This is to ensure that @@ -1003,7 +1033,9 @@ Just ( name, BoundV Global tvs $ - fromStruct $ Scalar $ Arrow mempty Unnamed pts' rt + fromStruct $ + Scalar $ + Arrow mempty Unnamed pts' rt ) where pts' = case pts of diff --git a/src/Language/Futhark/TypeChecker/Terms/Pat.hs b/src/Language/Futhark/TypeChecker/Terms/Pat.hs --- a/src/Language/Futhark/TypeChecker/Terms/Pat.hs +++ b/src/Language/Futhark/TypeChecker/Terms/Pat.hs @@ -38,7 +38,7 @@ nonrigidFor [] t = pure t -- Minor optimisation. nonrigidFor sizes t = evalStateT (bitraverse onDim pure t) mempty where - onDim (NamedDim (QualName _ v)) + onDim (NamedSize (QualName _ v)) | Just size <- find ((== v) . sizeName) sizes = do prev <- gets $ lookup v case prev of @@ -46,9 +46,9 @@ v' <- lift $ newID $ baseName v lift $ constrain v' $ Size Nothing $ mkUsage' $ srclocOf size modify ((v, v') :) - pure $ NamedDim $ qualName v' + pure $ NamedSize $ qualName v' Just v' -> - pure $ NamedDim $ qualName v' + pure $ NamedSize $ qualName v' onDim d = pure d -- | The set of in-scope variables that are being aliased. @@ -61,7 +61,7 @@ checkIfUsed :: Bool -> Occurrences -> Ident -> TermTypeM () checkIfUsed allow_consume occs v | not allow_consume, - not $ unique $ unInfo $ identType v, + not $ consumable $ unInfo $ identType v, Just occ <- find consumes occs = typeError (srclocOf occ) mempty $ "Consuming" @@ -76,6 +76,13 @@ where consumes = maybe False (identName v `S.member`) . consumed + consumable (Scalar (Record fs)) = all consumable fs + consumable (Scalar (Sum cs)) = all (all consumable) cs + consumable (Scalar (TypeVar _ u _ _)) = u == Unique + consumable (Scalar Arrow {}) = True + consumable (Scalar Prim {}) = True + consumable (Array _ u _ _) = u == Unique + -- | Bind these identifiers locally while running the provided action. -- Checks that the identifiers are used properly within the scope -- (e.g. consumption). @@ -171,7 +178,7 @@ . bindingTypes (concatMap typeParamType tparams) where typeParamType (TypeParamType l v loc) = - [ Left (v, TypeAbbr l [] $ RetType [] $ Scalar (TypeVar () Nonunique (typeName v) [])), + [ Left (v, TypeAbbr l [] $ RetType [] $ Scalar (TypeVar () Nonunique (qualName v) [])), Right (v, ParamType l loc) ] typeParamType (TypeParamDim v loc) = @@ -240,7 +247,7 @@ Ident v (Info (Scalar $ Prim $ Signed Int64)) loc mapM_ (observe . ident) sizes - let used_sizes = typeDimNames $ patternStructType p' + let used_sizes = freeInType $ patternStructType p' case filter ((`S.notMember` used_sizes) . sizeName) sizes of [] -> m p' size : _ -> unusedSize size @@ -314,7 +321,8 @@ fields' <- traverse (const $ newTypeVar loc "t") $ M.fromList fields when (sort (M.keys fields') /= sort (map fst fields)) $ - typeError loc mempty $ "Duplicate fields in record pattern" <+> ppr p <> "." + typeError loc mempty $ + "Duplicate fields in record pattern" <+> ppr p <> "." unify (mkUsage loc "matching a record pattern") (Scalar (Record fields')) $ toStruct t t' <- normTypeFully t @@ -337,7 +345,8 @@ <*> pure t' <*> pure loc NoneInferred -> - PatAscription <$> checkPat' sizes p (Ascribed (fromStruct st)) + PatAscription + <$> checkPat' sizes p (Ascribed (fromStruct st)) <*> pure t' <*> pure loc checkPat' _ (PatLit l NoInfo loc) (Ascribed t) = do @@ -388,7 +397,8 @@ case filter ((`S.member` explicit) . sizeName) sizes of size : _ -> typeError size mempty $ - "Cannot bind" <+> ppr size + "Cannot bind" + <+> ppr size <+> "as it is never used as the size of a concrete (non-function) value." [] -> bindNameMap (patNameMap p') $ m p' 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 @@ -19,6 +19,11 @@ TypeSubs, Substitutable (..), substTypesAny, + + -- * Witnesses + mustBeExplicitInType, + mustBeExplicitInBinding, + determineSizeWitnesses, ) where @@ -36,6 +41,55 @@ import Language.Futhark.Traversals import Language.Futhark.TypeChecker.Monad +mustBeExplicitAux :: StructType -> M.Map VName Bool +mustBeExplicitAux t = + execState (traverseDims onDim t) mempty + where + onDim bound _ (NamedSize d) + | qualLeaf d `S.member` bound = + modify $ \s -> M.insertWith (&&) (qualLeaf d) False s + onDim _ PosImmediate (NamedSize d) = + modify $ \s -> M.insertWith (&&) (qualLeaf d) False s + onDim _ _ (NamedSize d) = + modify $ M.insertWith (&&) (qualLeaf d) True + onDim _ _ _ = + pure () + +-- | Determine which of the sizes in a type are used as sizes outside +-- of functions in the type, and which are not. The former are said +-- to be "witnessed" by this type, while the latter are not. In +-- practice, the latter means that the actual sizes must come from +-- somewhere else. +determineSizeWitnesses :: StructType -> (S.Set VName, S.Set VName) +determineSizeWitnesses t = + bimap (S.fromList . M.keys) (S.fromList . M.keys) $ + M.partition not $ + mustBeExplicitAux t + +-- | Figure out which of the sizes in a binding type must be passed +-- explicitly, because their first use is as something else than just +-- an array dimension. +mustBeExplicitInBinding :: StructType -> S.Set VName +mustBeExplicitInBinding bind_t = + let (ts, ret) = unfoldFunType bind_t + alsoRet = + M.unionWith (&&) $ + M.fromList $ + zip (S.toList $ freeInType ret) $ + repeat True + in S.fromList $ M.keys $ M.filter id $ alsoRet $ foldl' onType mempty ts + where + onType uses t = uses <> mustBeExplicitAux t -- Left-biased union. + +-- | Figure out which of the sizes in a parameter type must be passed +-- explicitly, because their first use is as something else than just +-- an array dimension. +mustBeExplicitInType :: StructType -> S.Set VName +mustBeExplicitInType = snd . determineSizeWitnesses + +-- | The two types are assumed to be structurally equal, but not +-- necessarily regarding sizes. Adds aliases from the latter to the +-- former. addAliasesFromType :: StructType -> PatType -> PatType addAliasesFromType (Array _ u1 et1 shape1) (Array als _ _ _) = Array als u1 et1 shape1 @@ -67,20 +121,21 @@ -- Uniqueness is unified with @uf@. Assumes sizes already match, and -- always picks the size of the leftmost type. unifyTypesU :: - (Monoid als, ArrayDim dim) => + (Monoid als) => (Uniqueness -> Uniqueness -> Maybe Uniqueness) -> TypeBase dim als -> TypeBase dim als -> Maybe (TypeBase dim als) unifyTypesU uf (Array als1 u1 shape1 et1) (Array als2 u2 _shape2 et2) = - Array (als1 <> als2) <$> uf u1 u2 + Array (als1 <> als2) + <$> uf u1 u2 <*> pure shape1 <*> unifyScalarTypes uf et1 et2 unifyTypesU uf (Scalar t1) (Scalar t2) = Scalar <$> unifyScalarTypes uf t1 t2 unifyTypesU _ _ _ = Nothing unifyScalarTypes :: - (Monoid als, ArrayDim dim) => + (Monoid als) => (Uniqueness -> Uniqueness -> Maybe Uniqueness) -> ScalarTypeBase dim als -> ScalarTypeBase dim als -> @@ -112,7 +167,8 @@ uf (Arrow as1 mn1 t1 (RetType dims1 t1')) (Arrow as2 _ t2 (RetType _ t2')) = - Arrow (as1 <> as2) mn1 <$> unifyTypesU (flip uf) t1 t2 + Arrow (as1 <> as2) mn1 + <$> unifyTypesU (flip uf) t1 t2 <*> (RetType dims1 <$> unifyTypesU uf t1' t2') unifyScalarTypes uf (Sum cs1) (Sum cs2) | length cs1 == length cs2, @@ -142,7 +198,7 @@ renameRetType (RetType dims st) | dims /= mempty = do dims' <- mapM newName dims - let m = M.fromList $ zip dims $ map (SizeSubst . NamedDim . qualName) dims' + let m = M.fromList $ zip dims $ map (SizeSubst . NamedSize . qualName) dims' st' = applySubst (`M.lookup` m) st pure $ RetType dims' st' | otherwise = @@ -159,7 +215,8 @@ [] -> pure (TEVar name' loc, [], t', l) _ -> typeError loc mempty $ - "Type constructor" <+> pquote (spread (ppr name : map ppr ps)) + "Type constructor" + <+> pquote (spread (ppr name : map ppr ps)) <+> "used without any arguments." -- evalTypeExp (TETuple ts loc) = do @@ -175,7 +232,8 @@ -- Check for duplicate field names. let field_names = map fst fs unless (sort field_names == sort (nubOrd field_names)) $ - typeError loc mempty $ "Duplicate record fields in" <+> ppr t <> "." + typeError loc mempty $ + "Duplicate record fields in" <+> ppr t <> "." checked <- traverse evalTypeExp $ M.fromList fs let fs' = fmap (\(x, _, _, _) -> x) checked @@ -190,9 +248,9 @@ ) -- evalTypeExp (TEArray d t loc) = do - (d_svars, d', d'') <- checkDimExp d + (d_svars, d', d'') <- checkSizeExp d (t', svars, RetType dims st, l) <- evalTypeExp t - case (l, arrayOf Nonunique (ShapeDecl [d'']) st) of + case (l, arrayOf Nonunique (Shape [d'']) st) of (Unlifted, st') -> pure ( TEArray d' t' loc, @@ -202,26 +260,29 @@ ) (SizeLifted, _) -> typeError loc mempty $ - "Cannot create array with elements of size-lifted type" <+> pquote (ppr t) + "Cannot create array with elements of size-lifted type" + <+> pquote (ppr t) <+/> "(might cause irregular array)." (Lifted, _) -> typeError loc mempty $ - "Cannot create array with elements of lifted type" <+> pquote (ppr t) + "Cannot create array with elements of lifted type" + <+> pquote (ppr t) <+/> "(might contain function)." where - checkDimExp DimExpAny = do + checkSizeExp SizeExpAny = do dv <- newTypeName "d" - pure ([dv], DimExpAny, NamedDim $ qualName dv) - checkDimExp (DimExpConst k dloc) = - pure ([], DimExpConst k dloc, ConstDim k) - checkDimExp (DimExpNamed v dloc) = do - v' <- checkNamedDim loc v - pure ([], DimExpNamed v' dloc, NamedDim v') + pure ([dv], SizeExpAny, NamedSize $ qualName dv) + checkSizeExp (SizeExpConst k dloc) = + pure ([], SizeExpConst k dloc, ConstSize k) + checkSizeExp (SizeExpNamed v dloc) = do + v' <- checkNamedSize loc v + pure ([], SizeExpNamed v' dloc, NamedSize v') -- evalTypeExp (TEUnique t loc) = do (t', svars, RetType dims st, l) <- evalTypeExp t unless (mayContainArray st) $ - warn loc $ "Declaring" <+> pquote (ppr st) <+> "as unique has no effect." + warn loc $ + "Declaring" <+> pquote (ppr st) <+> "as unique has no effect." pure (TEUnique t' loc, svars, RetType dims $ st `setUniqueness` Unique, l) where mayContainArray (Scalar Prim {}) = False @@ -263,7 +324,8 @@ case find (`S.notMember` witnessed) dims' of Just d -> typeError loc mempty . withIndexLink "unused-existential" $ - "Existential size " <> pquote (pprName d) + "Existential size " + <> pquote (pprName d) <> " not used as array size." Nothing -> pure @@ -280,7 +342,8 @@ evalTypeExp t@(TESum cs loc) = do let constructors = map fst cs unless (sort constructors == sort (nubOrd constructors)) $ - typeError loc mempty $ "Duplicate constructors in" <+> ppr t + typeError loc mempty $ + "Duplicate constructors in" <+> ppr t unless (length constructors < 256) $ typeError loc mempty "Sum types must have less than 256 constructors." @@ -294,7 +357,9 @@ ( TESum (M.toList cs') loc, cs_svars, RetType (foldMap (foldMap retDims) ts_s) $ - Scalar $ Sum $ M.map (map retType) ts_s, + Scalar $ + Sum $ + M.map (map retType) ts_s, foldl' max Unlifted ls ) evalTypeExp ote@TEApply {} = do @@ -304,7 +369,10 @@ if length ps /= length targs then typeError tloc mempty $ - "Type constructor" <+> pquote (ppr tname) <+> "requires" <+> ppr (length ps) + "Type constructor" + <+> pquote (ppr tname) + <+> "requires" + <+> ppr (length ps) <+> "arguments, but provided" <+> ppr (length targs) <> "." else do @@ -327,25 +395,25 @@ typeError (srclocOf te') mempty $ "Type" <+> pquote (ppr te') <+> "is not a type constructor." - checkArgApply (TypeParamDim pv _) (TypeArgExpDim (DimExpNamed v dloc) loc) = do - v' <- checkNamedDim loc v + checkArgApply (TypeParamDim pv _) (TypeArgExpDim (SizeExpNamed v dloc) loc) = do + v' <- checkNamedSize loc v pure - ( TypeArgExpDim (DimExpNamed v' dloc) loc, + ( TypeArgExpDim (SizeExpNamed v' dloc) loc, [], - M.singleton pv $ SizeSubst $ NamedDim v' + M.singleton pv $ SizeSubst $ NamedSize v' ) - checkArgApply (TypeParamDim pv _) (TypeArgExpDim (DimExpConst x dloc) loc) = + checkArgApply (TypeParamDim pv _) (TypeArgExpDim (SizeExpConst x dloc) loc) = pure - ( TypeArgExpDim (DimExpConst x dloc) loc, + ( TypeArgExpDim (SizeExpConst x dloc) loc, [], - M.singleton pv $ SizeSubst $ ConstDim x + M.singleton pv $ SizeSubst $ ConstSize x ) - checkArgApply (TypeParamDim pv _) (TypeArgExpDim DimExpAny loc) = do + checkArgApply (TypeParamDim pv _) (TypeArgExpDim SizeExpAny loc) = do d <- newTypeName "d" pure - ( TypeArgExpDim DimExpAny loc, + ( TypeArgExpDim SizeExpAny loc, [d], - M.singleton pv $ SizeSubst $ NamedDim $ qualName d + M.singleton pv $ SizeSubst $ NamedSize $ qualName d ) checkArgApply (TypeParamType _ pv _) (TypeArgExpType te) = do (te', svars, RetType dims st, _) <- evalTypeExp te @@ -356,7 +424,8 @@ ) checkArgApply p a = typeError tloc mempty $ - "Type argument" <+> ppr a + "Type argument" + <+> ppr a <+> "not valid for a type parameter" <+> ppr p <> "." @@ -400,7 +469,9 @@ Just prev_loc -> lift $ typeError loc mempty $ - "Name" <+> pquote (ppr v) <+> "also bound at" + "Name" + <+> pquote (ppr v) + <+> "also bound at" <+> text (locStr prev_loc) <> "." Nothing -> modify $ M.insert (ns, v) loc @@ -418,7 +489,8 @@ where bad v loc prev_loc = typeError loc mempty $ - text "Name" <+> pquote (ppr v) + text "Name" + <+> pquote (ppr v) <+> "also bound at" <+> text (locStr prev_loc) <> "." @@ -470,7 +542,8 @@ Just prev -> lift $ typeError loc mempty $ - text "Type parameter" <+> pquote (ppr v) + text "Type parameter" + <+> pquote (ppr v) <+> "previously defined at" <+> text (locStr prev) <> "." Nothing -> do @@ -485,15 +558,15 @@ -- | Construct a type argument corresponding to a type parameter. typeParamToArg :: TypeParam -> StructTypeArg typeParamToArg (TypeParamDim v ploc) = - TypeArgDim (NamedDim $ qualName v) ploc + TypeArgDim (NamedSize $ qualName v) ploc typeParamToArg (TypeParamType _ v ploc) = - TypeArgType (Scalar $ TypeVar () Nonunique (typeName v) []) ploc + TypeArgType (Scalar $ TypeVar () Nonunique (qualName v) []) ploc -- | A type substitution may be a substitution or a yet-unknown -- substitution (but which is certainly an overloaded primitive -- type!). The latter is used to remove aliases from types that are -- yet-unknown but that we know cannot carry aliases (see issue #682). -data Subst t = Subst [TypeParam] t | PrimSubst | SizeSubst (DimDecl VName) +data Subst t = Subst [TypeParam] t | PrimSubst | SizeSubst Size deriving (Show) instance Pretty t => Pretty (Subst t) where @@ -519,30 +592,30 @@ class Substitutable a where applySubst :: TypeSubs -> a -> a -instance Substitutable (RetTypeBase (DimDecl VName) ()) where +instance Substitutable (RetTypeBase Size ()) where applySubst f (RetType dims t) = let RetType more_dims t' = substTypesRet f t in RetType (dims ++ more_dims) t' -instance Substitutable (RetTypeBase (DimDecl VName) Aliasing) where +instance Substitutable (RetTypeBase Size Aliasing) where applySubst f (RetType dims t) = let RetType more_dims t' = substTypesRet f' t in RetType (dims ++ more_dims) t' where f' = fmap (fmap (second (const mempty))) . f -instance Substitutable (TypeBase (DimDecl VName) ()) where +instance Substitutable (TypeBase Size ()) where applySubst = substTypesAny -instance Substitutable (TypeBase (DimDecl VName) Aliasing) where +instance Substitutable (TypeBase Size Aliasing) where applySubst = substTypesAny . (fmap (fmap (second (const mempty))) .) -instance Substitutable (DimDecl VName) where - applySubst f (NamedDim (QualName _ v)) +instance Substitutable Size where + applySubst f (NamedSize (QualName _ v)) | Just (SizeSubst d) <- f v = d applySubst _ d = d -instance Substitutable d => Substitutable (ShapeDecl d) where +instance Substitutable d => Substitutable (Shape d) where applySubst f = fmap $ applySubst f instance Substitutable Pat where @@ -552,7 +625,6 @@ ASTMapper { mapOnExp = pure, mapOnName = pure, - mapOnQualName = pure, mapOnStructType = pure . applySubst f, mapOnPatType = pure . applySubst f, mapOnStructRetType = pure . applySubst f, @@ -562,9 +634,9 @@ applyType :: Monoid als => [TypeParam] -> - TypeBase (DimDecl VName) als -> + TypeBase Size als -> [StructTypeArg] -> - TypeBase (DimDecl VName) als + TypeBase Size als applyType ps t args = substTypesAny (`M.lookup` substs) t where substs = M.fromList $ zipWith mkSubst ps args @@ -578,9 +650,9 @@ substTypesRet :: Monoid as => - (VName -> Maybe (Subst (RetTypeBase (DimDecl VName) as))) -> - TypeBase (DimDecl VName) as -> - RetTypeBase (DimDecl VName) as + (VName -> Maybe (Subst (RetTypeBase Size as))) -> + TypeBase Size as -> + RetTypeBase Size as substTypesRet lookupSubst ot = uncurry (flip RetType) $ runState (onType ot) [] where @@ -601,15 +673,15 @@ else do let start = maximum $ map baseTag seen_ext ext' = zipWith VName (map baseName ext) [start + 1 ..] - extsubsts = M.fromList $ zip ext $ map (SizeSubst . NamedDim . qualName) ext' + extsubsts = M.fromList $ zip ext $ map (SizeSubst . NamedSize . qualName) ext' RetType [] t' = substTypesRet (`M.lookup` extsubsts) t pure $ RetType ext' t' onType :: forall as. Monoid as => - TypeBase (DimDecl VName) as -> - State [VName] (TypeBase (DimDecl VName) as) + TypeBase Size as -> + State [VName] (TypeBase Size as) onType (Array als u shape et) = do t <- arrayOf u (applySubst lookupSubst' shape) <$> onType (Scalar et) @@ -617,13 +689,14 @@ onType (Scalar (Prim t)) = pure $ Scalar $ Prim t onType (Scalar (TypeVar als u v targs)) = do targs' <- mapM subsTypeArg targs - case lookupSubst $ qualLeaf (qualNameFromTypeName v) of + case lookupSubst $ qualLeaf v of Just (Subst ps rt) -> do RetType ext t <- freshDims rt modify (ext ++) pure $ applyType ps (t `setAliases` mempty) targs' - `setUniqueness` u `addAliases` (<> als) + `setUniqueness` u + `addAliases` (<> als) Just PrimSubst -> pure $ Scalar $ TypeVar mempty u v targs' _ -> @@ -659,23 +732,23 @@ -- regardless of what shape and uniqueness information is attached to the type. substTypesAny :: Monoid as => - (VName -> Maybe (Subst (RetTypeBase (DimDecl VName) as))) -> - TypeBase (DimDecl VName) as -> - TypeBase (DimDecl VName) as + (VName -> Maybe (Subst (RetTypeBase Size as))) -> + TypeBase Size as -> + TypeBase Size as substTypesAny lookupSubst ot = case substTypesRet lookupSubst ot of RetType [] ot' -> ot' RetType dims ot' -> -- XXX HACK FIXME: turn any sizes that propagate to the top into - -- AnyDim. This should _never_ happen during type-checking, but + -- AnySize. This should _never_ happen during type-checking, but -- may happen as we substitute types during monomorphisation and - -- defunctorisation later on. See Note [AnyDim] - let toAny (NamedDim v) - | qualLeaf v `elem` dims = AnyDim Nothing + -- defunctorisation later on. See Note [AnySize] + let toAny (NamedSize v) + | qualLeaf v `elem` dims = AnySize Nothing toAny d = d in first toAny ot' --- Note [AnyDim] +-- Note [AnySize] -- -- Consider a program: -- @@ -695,13 +768,13 @@ -- -- let f (x: []bool) (y: []bool) = 0 -- --- I.e. we put in empty dimensions (AnyDim), which are much later +-- I.e. we put in empty dimensions (AnySize), which are much later -- turned into distinct sizes in Futhark.Internalise.Exps. This will -- result in unnecessary dynamic size checks, which will hopefully be -- optimised away. -- -- Important: The type checker will _never_ produce programs with --- AnyDim, but unfortunately some of the compilation steps +-- AnySize, but unfortunately some of the compilation steps -- (defunctorisation, monomorphisation, defunctionalisation) will do -- so. Similarly, the core language is also perfectly well behaved. -- 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 @@ -45,7 +45,7 @@ import Data.Maybe import qualified Data.Set as S import Futhark.Util.Pretty hiding (empty) -import Language.Futhark hiding (unifyDims) +import Language.Futhark import Language.Futhark.TypeChecker.Monad hiding (BoundV) import Language.Futhark.TypeChecker.Types @@ -60,7 +60,8 @@ instance Pretty BreadCrumb where ppr (MatchingTypes t1 t2) = - "When matching type" indent 2 (ppr t1) + "When matching type" + indent 2 (ppr t1) "with" indent 2 (ppr t2) ppr (MatchingFields fields) = @@ -132,7 +133,7 @@ | ParamSize SrcLoc | -- | Is not actually a type, but a term-level size, -- possibly already set to something specific. - Size (Maybe (DimDecl VName)) Usage + Size (Maybe Size) Usage | -- | A size that does not unify with anything - -- created from the result of applying a function -- whose return size is existential, or otherwise @@ -174,7 +175,7 @@ RigidRet (Maybe (QualName VName)) | RigidLoop | -- | Produced by a complicated slice expression. - RigidSlice (Maybe (DimDecl VName)) String + RigidSlice (Maybe Size) String | -- | Produced by a complicated range expression. RigidRange | -- | Produced by a range expression with this bound. @@ -198,19 +199,24 @@ "is unknown size returned by function at" <+> text (locStrRel ctx loc) <> "." prettySource ctx loc (RigidRet (Just fname)) = - "is unknown size returned by" <+> pquote (ppr fname) + "is unknown size returned by" + <+> pquote (ppr fname) <+> "at" <+> text (locStrRel ctx loc) <> "." prettySource ctx loc (RigidArg fname arg) = "is value of argument" indent 2 (shorten arg) - "passed to" <+> fname' <+> "at" <+> text (locStrRel ctx loc) <> "." + "passed to" + <+> fname' + <+> "at" + <+> text (locStrRel ctx loc) <> "." where fname' = maybe "function" (pquote . ppr) fname prettySource ctx loc (RigidSlice d slice) = "is size produced by slice" indent 2 (shorten slice) - d_desc <> "at" <+> text (locStrRel ctx loc) <> "." + d_desc <> "at" + <+> text (locStrRel ctx loc) <> "." where d_desc = case d of Just d' -> "of dimension of size " <> pquote (ppr d') <> " " @@ -224,13 +230,14 @@ indent 2 (shorten bound) "used in range at " <> text (locStrRel ctx loc) <> "." prettySource ctx loc (RigidOutOfScope boundloc v) = - "is an unknown size arising from " <> pquote (pprName v) + "is an unknown size arising from " + <> pquote (pprName v) <> " going out of scope at " <> text (locStrRel ctx loc) <> "." "Originally bound at " - <> text (locStrRel ctx boundloc) - <> "." + <> text (locStrRel ctx boundloc) + <> "." prettySource ctx loc RigidCoerce = "is an unknown size arising from empty dimension in coercion at" <+> text (locStrRel ctx loc) <> "." @@ -241,42 +248,43 @@ <> text (locStrRel ctx loc) <> "." "One branch returns array of type: " - <> align (ppr t1) + <> align (ppr t1) "The other an array of type: " - <> align (ppr t2) + <> align (ppr t2) -- | Retrieve notes describing the purpose or origin of the given --- 'DimDecl'. The location is used as the *current* location, for the +-- t'Size'. The location is used as the *current* location, for the -- purpose of reporting relative locations. -dimNotes :: (Located a, MonadUnify m) => a -> DimDecl VName -> m Notes -dimNotes ctx (NamedDim d) = do +dimNotes :: (Located a, MonadUnify m) => a -> Size -> m Notes +dimNotes ctx (NamedSize d) = do c <- M.lookup (qualLeaf d) <$> getConstraints case c of Just (_, UnknowableSize loc rsrc) -> - pure $ - aNote $ - pretty $ - pquote (ppr d) <+> prettySource (srclocOf ctx) loc rsrc + pure . aNote . pretty $ + pquote (ppr d) <+> prettySource (srclocOf ctx) loc rsrc _ -> pure mempty dimNotes _ _ = pure mempty typeNotes :: (Located a, MonadUnify m) => a -> StructType -> m Notes typeNotes ctx = - fmap mconcat . mapM (dimNotes ctx . NamedDim . qualName) + fmap mconcat + . mapM (dimNotes ctx . NamedSize . qualName) . S.toList - . typeDimNames + . freeInType typeVarNotes :: MonadUnify m => VName -> m Notes typeVarNotes v = maybe mempty (aNote . note . snd) . M.lookup v <$> getConstraints where note (HasConstrs cs _) = - pprName v <+> "=" + pprName v + <+> "=" <+> mconcat (map ppConstr (M.toList cs)) <+> "..." note (Overloaded ts _) = pprName v <+> "must be one of" <+> mconcat (punctuate ", " (map ppr ts)) note (HasFields fs _) = - pprName v <+> "=" + pprName v + <+> "=" <+> braces (mconcat (punctuate ", " (map ppField (M.toList fs)))) note _ = mempty @@ -323,7 +331,7 @@ -- | Replace any top-level type variable with its substitution. normType :: MonadUnify m => StructType -> m StructType -normType t@(Scalar (TypeVar _ _ (TypeName [] v) [])) = do +normType t@(Scalar (TypeVar _ _ (QualName [] v) [])) = do constraints <- getConstraints case snd <$> M.lookup v constraints of Just (Constraint (RetType [] t') _) -> normType t' @@ -332,7 +340,7 @@ -- | Replace any top-level type variable with its substitution. normPatType :: MonadUnify m => PatType -> m PatType -normPatType t@(Scalar (TypeVar als u (TypeName [] v) [])) = do +normPatType t@(Scalar (TypeVar als u (QualName [] v) [])) = do constraints <- getConstraints case snd <$> M.lookup v constraints of Just (Constraint (RetType [] t') _) -> @@ -351,15 +359,15 @@ MonadUnify m => SrcLoc -> Rigidity -> - RetTypeBase (DimDecl VName) als -> - m (TypeBase (DimDecl VName) als, [VName]) + RetTypeBase Size als -> + m (TypeBase Size als, [VName]) instantiateEmptyArrayDims tloc r (RetType dims t) = do dims' <- mapM new dims pure (first (onDim $ zip dims dims') t, dims') where new = newDimVar tloc r . nameFromString . takeWhile isAscii . baseString - onDim dims' (NamedDim d) = - NamedDim $ maybe d qualName (lookup (qualLeaf d) dims') + onDim dims' (NamedSize d) = + NamedSize $ maybe d qualName (lookup (qualLeaf d) dims') onDim _ d = d -- | Is the given type variable the name of an abstract type or type @@ -376,7 +384,7 @@ pure lvl type UnifyDims m = - BreadCrumbs -> [VName] -> (VName -> Maybe Int) -> DimDecl VName -> DimDecl VName -> m () + BreadCrumbs -> [VName] -> (VName -> Maybe Int) -> Size -> Size -> m () flipUnifyDims :: UnifyDims m -> UnifyDims m flipUnifyDims onDims bcs bound nonrigid t1 t2 = @@ -448,15 +456,15 @@ ++ filter (`notElem` M.keys fs) (M.keys arg_fs) unifyError usage mempty bcs $ "Unshared fields:" <+> commasep (map ppr missing) <> "." - ( Scalar (TypeVar _ _ (TypeName _ tn) targs), - Scalar (TypeVar _ _ (TypeName _ arg_tn) arg_targs) + ( Scalar (TypeVar _ _ (QualName _ tn) targs), + Scalar (TypeVar _ _ (QualName _ arg_tn) arg_targs) ) | tn == arg_tn, length targs == length arg_targs -> do let bcs' = breadCrumb (Matching "When matching type arguments.") bcs zipWithM_ (unifyTypeArg bcs') targs arg_targs - ( Scalar (TypeVar _ _ (TypeName [] v1) []), - Scalar (TypeVar _ _ (TypeName [] v2) []) + ( Scalar (TypeVar _ _ (QualName [] v1) []), + Scalar (TypeVar _ _ (QualName [] v2) []) ) -> case (nonrigid v1, nonrigid v2) of (Nothing, Nothing) -> failure @@ -465,10 +473,10 @@ (Just lvl1, Just lvl2) | lvl1 <= lvl2 -> link ord v1 lvl1 t2' | otherwise -> link (not ord) v2 lvl2 t1' - (Scalar (TypeVar _ _ (TypeName [] v1) []), _) + (Scalar (TypeVar _ _ (QualName [] v1) []), _) | Just lvl <- nonrigid v1 -> link ord v1 lvl t2' - (_, Scalar (TypeVar _ _ (TypeName [] v2) [])) + (_, Scalar (TypeVar _ _ (QualName [] v2) [])) | Just lvl <- nonrigid v2 -> link (not ord) v2 lvl t1' ( Scalar (Arrow _ p1 a1 (RetType b1_dims b1)), @@ -512,7 +520,7 @@ case (p1, p2) of (Named p1', Named p2') -> let f v - | v == p2' = Just $ SizeSubst $ NamedDim $ qualName p1' + | v == p2' = Just $ SizeSubst $ NamedSize $ qualName p1' | otherwise = Nothing in (b1, applySubst f b2) (_, _) -> @@ -521,8 +529,8 @@ pname (Named x) = Just x pname Unnamed = Nothing (Array {}, Array {}) - | ShapeDecl (t1_d : _) <- arrayShape t1', - ShapeDecl (t2_d : _) <- arrayShape t2', + | Shape (t1_d : _) <- arrayShape t1', + Shape (t2_d : _) <- arrayShape t2', Just t1'' <- peelArray 1 t1', Just t2'' <- peelArray 1 t2' -> do onDims' bcs (swap ord t1_d t2_d) @@ -545,16 +553,17 @@ unifyDims :: MonadUnify m => Usage -> UnifyDims m unifyDims _ _ _ _ d1 d2 | d1 == d2 = pure () -unifyDims usage bcs _ nonrigid (NamedDim (QualName _ d1)) d2 +unifyDims usage bcs _ nonrigid (NamedSize (QualName _ d1)) d2 | Just lvl1 <- nonrigid d1 = linkVarToDim usage bcs d1 lvl1 d2 -unifyDims usage bcs _ nonrigid d1 (NamedDim (QualName _ d2)) +unifyDims usage bcs _ nonrigid d1 (NamedSize (QualName _ d2)) | Just lvl2 <- nonrigid d2 = linkVarToDim usage bcs d2 lvl2 d1 unifyDims usage bcs _ _ d1 d2 = do notes <- (<>) <$> dimNotes usage d1 <*> dimNotes usage d2 unifyError usage notes bcs $ - "Dimensions" <+> pquote (ppr d1) + "Dimensions" + <+> pquote (ppr d1) <+> "and" <+> pquote (ppr d2) <+> "do not match." @@ -571,23 +580,24 @@ | d1 == d2 = pure () -- We identify existentially bound names by them being nonrigid -- and yet bound. It's OK to unify with those. - onDims bcs bound nonrigid (NamedDim (QualName _ d1)) d2 + onDims bcs bound nonrigid (NamedSize (QualName _ d1)) d2 | Just lvl1 <- nonrigid d1, not (boundParam bound d2) || (d1 `elem` bound) = linkVarToDim usage bcs d1 lvl1 d2 - onDims bcs bound nonrigid d1 (NamedDim (QualName _ d2)) + onDims bcs bound nonrigid d1 (NamedSize (QualName _ d2)) | Just lvl2 <- nonrigid d2, not (boundParam bound d1) || (d2 `elem` bound) = linkVarToDim usage bcs d2 lvl2 d1 onDims bcs _ _ d1 d2 = do notes <- (<>) <$> dimNotes usage d1 <*> dimNotes usage d2 unifyError usage notes bcs $ - "Dimensions" <+> pquote (ppr d1) + "Dimensions" + <+> pquote (ppr d1) <+> "and" <+> pquote (ppr d2) <+> "do not match." - boundParam bound (NamedDim (QualName _ d)) = d `elem` bound + boundParam bound (NamedSize (QualName _ d)) = d `elem` bound boundParam _ _ = False occursCheck :: @@ -618,7 +628,7 @@ checkType constraints tp where checkType constraints t = - mapM_ (check constraints) $ typeVars t <> typeDimNames t + mapM_ (check constraints) $ typeVars t <> freeInType t check constraints v | Just (lvl, c) <- M.lookup v constraints, @@ -669,7 +679,8 @@ M.insert vn (lvl, Constraint (RetType ext tp) usage) problems -> unifyError usage mempty bcs . withIndexLink "unify-param-existential" $ - "Parameter(s) " <> commasep (map (pquote . pprName) problems) + "Parameter(s) " + <> commasep (map (pquote . pprName) problems) <> " used as size(s) would go out of scope." case snd <$> M.lookup vn constraints of @@ -677,7 +688,8 @@ let bcs' = breadCrumb ( Matching $ - "When verifying that" <+> pquote (pprName vn) + "When verifying that" + <+> pquote (pprName vn) <+> textwrap "is not instantiated with a function type, due to" <+> ppr unlift_usage ) @@ -686,9 +698,10 @@ link arrayElemTypeWith usage bcs' tp - when (any (`elem` bound) (typeDimNames tp)) $ + when (any (`elem` bound) (freeInType tp)) $ unifyError usage mempty bcs $ - "Type variable" <+> pprName vn + "Type variable" + <+> pprName vn <+> "cannot be instantiated with type containing anonymous sizes:" indent 2 (ppr tp) textwrap "This is usually because the size of an array returned by a higher-order function argument cannot be determined statically. This can also be due to the return size being a value parameter. Add type annotation to clarify." @@ -699,14 +712,17 @@ | tp `notElem` map (Scalar . Prim) ts -> do link case tp of - Scalar (TypeVar _ _ (TypeName [] v) []) + Scalar (TypeVar _ _ (QualName [] v) []) | not $ isRigid v constraints -> linkVarToTypes usage v ts _ -> unifyError usage mempty bcs $ - "Cannot instantiate" <+> pquote (pprName vn) - <+> "with type" indent 2 (ppr tp) "as" + "Cannot instantiate" <+> pquote (pprName vn) + <+> "with type" + indent 2 (ppr tp) + "as" + <+> pquote (pprName vn) <+> "must be one of" <+> commasep (map ppr ts) <+/> "due to" @@ -730,7 +746,7 @@ mapM_ (uncurry $ unifyWith onDims usage bound bcs') $ M.elems $ M.intersectionWith (,) required_fields tp_fields - Scalar (TypeVar _ _ (TypeName [] v) []) + Scalar (TypeVar _ _ (QualName [] v) []) | not $ isRigid v constraints -> modifyConstraints $ M.insert @@ -738,22 +754,27 @@ (lvl, HasFields required_fields old_usage) _ -> unifyError usage mempty bcs $ - "Cannot instantiate" <+> pquote (pprName vn) <+> "with type" + "Cannot instantiate" + <+> pquote (pprName vn) + <+> "with type" indent 2 (ppr tp) - "as" <+> pquote (pprName vn) <+> "must be a record with fields" + "as" + <+> pquote (pprName vn) + <+> "must be a record with fields" indent 2 (ppr (Record required_fields)) - "due to" <+> ppr old_usage <> "." + "due to" + <+> ppr old_usage <> "." -- See Note [Linking variables to sum types] Just (HasConstrs required_cs old_usage) -> case tp of Scalar (Sum ts) | all (`M.member` ts) $ M.keys required_cs -> do let tp' = Scalar $ Sum $ required_cs <> ts -- Crucially left-biased. - ext = filter (`S.member` typeDimNames tp') bound + ext = filter (`S.member` freeInType tp') bound modifyConstraints $ M.insert vn (lvl, Constraint (RetType ext tp') usage) unifySharedConstructors onDims usage bound bcs required_cs ts - Scalar (TypeVar _ _ (TypeName [] v) []) -> do + Scalar (TypeVar _ _ (QualName [] v) []) -> do case M.lookup v constraints of Just (_, HasConstrs v_cs _) -> do unifySharedConstructors onDims usage bound bcs required_cs v_cs @@ -788,20 +809,21 @@ BreadCrumbs -> VName -> Level -> - DimDecl VName -> + Size -> m () linkVarToDim usage bcs vn lvl dim = do constraints <- getConstraints case dim of - NamedDim dim' + NamedSize dim' | Just (dim_lvl, c) <- qualLeaf dim' `M.lookup` constraints, dim_lvl > lvl -> case c of ParamSize {} -> do notes <- dimNotes usage dim unifyError usage notes bcs $ - "Cannot unify size variable" <+> pquote (ppr dim') + "Cannot unify size variable" + <+> pquote (ppr dim') <+> "with" <+> pquote (pprName vn) <+> "(scope violation)." @@ -822,14 +844,15 @@ let isRigid' v = isRigid v constraints case t' of - Scalar (TypeVar _ _ (TypeName [] v) []) + Scalar (TypeVar _ _ (QualName [] v) []) | not $ isRigid' v -> linkVarToTypes usage v ts Scalar (Prim pt) | pt `elem` ts -> pure () _ -> failure where failure = unifyError usage mempty noBreadCrumbs $ - text "Cannot unify type" <+> pquote (ppr t) + text "Cannot unify type" + <+> pquote (ppr t) <+> "with any of " <> commasep (map ppr ts) <> "." linkVarToTypes :: MonadUnify m => Usage -> VName -> [PrimType] -> m () @@ -849,14 +872,18 @@ ts' -> modifyConstraints $ M.insert vn (lvl, Overloaded ts' usage) Just (_, HasConstrs _ vn_usage) -> unifyError usage mempty noBreadCrumbs $ - "Type constrained to one of" <+> commasep (map ppr ts) - <> ", but also inferred to be sum type due to" <+> ppr vn_usage - <> "." + "Type constrained to one of" + <+> commasep (map ppr ts) + <> ", but also inferred to be sum type due to" + <+> ppr vn_usage + <> "." Just (_, HasFields _ vn_usage) -> unifyError usage mempty noBreadCrumbs $ - "Type constrained to one of" <+> commasep (map ppr ts) - <> ", but also inferred to be record due to" <+> ppr vn_usage - <> "." + "Type constrained to one of" + <+> commasep (map ppr ts) + <> ", but also inferred to be record due to" + <+> ppr vn_usage + <> "." Just (lvl, _) -> modifyConstraints $ M.insert vn (lvl, Overloaded ts usage) Nothing -> unifyError usage mempty noBreadCrumbs $ @@ -864,7 +891,7 @@ -- | Assert that this type must support equality. equalityType :: - (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) => + (MonadUnify m, Pretty (Shape dim), Monoid as) => Usage -> TypeBase dim as -> m () @@ -877,13 +904,17 @@ mustBeEquality vn = do constraints <- getConstraints case M.lookup vn constraints of - Just (_, Constraint (RetType [] (Scalar (TypeVar _ _ (TypeName [] vn') []))) _) -> + Just (_, Constraint (RetType [] (Scalar (TypeVar _ _ (QualName [] vn') []))) _) -> mustBeEquality vn' Just (_, Constraint (RetType _ vn_t) cusage) | not $ orderZero vn_t -> unifyError usage mempty noBreadCrumbs $ - "Type" <+> pquote (ppr t) <+> "does not support equality." - "Constrained to be higher-order due to" <+> ppr cusage <+> "." + "Type" + <+> pquote (ppr t) + <+> "does not support equality." + "Constrained to be higher-order due to" + <+> ppr cusage + <+> "." | otherwise -> pure () Just (lvl, NoConstraint _ _) -> modifyConstraints $ M.insert vn (lvl, Equality usage) @@ -898,7 +929,7 @@ "Type" <+> pprName vn <+> "does not support equality." zeroOrderTypeWith :: - (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) => + (MonadUnify m, Pretty (Shape dim), Monoid as) => Usage -> BreadCrumbs -> TypeBase dim as -> @@ -925,7 +956,7 @@ -- | Assert that this type must be zero-order. zeroOrderType :: - (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) => + (MonadUnify m, Pretty (Shape dim), Monoid as) => Usage -> String -> TypeBase dim as -> @@ -936,7 +967,7 @@ bc = Matching $ "When checking" <+> textwrap desc arrayElemTypeWith :: - (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) => + (MonadUnify m, Pretty (Shape dim), Monoid as) => Usage -> BreadCrumbs -> TypeBase dim as -> @@ -964,7 +995,7 @@ -- | Assert that this type must be valid as an array element. arrayElemType :: - (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) => + (MonadUnify m, Pretty (Shape dim), Monoid as) => Usage -> String -> TypeBase dim as -> @@ -1007,7 +1038,7 @@ mustHaveConstr usage c t fs = do constraints <- getConstraints case t of - Scalar (TypeVar _ _ (TypeName _ tn) []) + Scalar (TypeVar _ _ (QualName _ tn) []) | Just (lvl, NoConstraint {}) <- M.lookup tn constraints -> do mapM_ (scopeCheck usage noBreadCrumbs tn lvl) fs modifyConstraints $ M.insert tn (lvl, HasConstrs (M.singleton c fs) usage) @@ -1046,7 +1077,7 @@ l_type <- newTypeVar (srclocOf usage) "t" let l_type' = l_type `setAliases` aliases t case t of - Scalar (TypeVar _ _ (TypeName _ tn) []) + Scalar (TypeVar _ _ (QualName _ tn) []) | Just (lvl, NoConstraint {}) <- M.lookup tn constraints -> do scopeCheck usage bcs tn lvl l_type modifyConstraints $ M.insert tn (lvl, HasFields (M.singleton l l_type) usage) @@ -1066,7 +1097,9 @@ pure t' | otherwise -> unifyError usage mempty bcs $ - "Attempt to access field" <+> pquote (ppr l) <+> " of value of type" + "Attempt to access field" + <+> pquote (ppr l) + <+> " of value of type" <+> ppr (toStructural t) <> "." _ -> do unify usage (toStruct t) $ Scalar $ Record $ M.singleton l l_type @@ -1084,9 +1117,9 @@ newDimOnMismatch :: (Monoid as, MonadUnify m) => SrcLoc -> - TypeBase (DimDecl VName) as -> - TypeBase (DimDecl VName) as -> - m (TypeBase (DimDecl VName) as, [VName]) + TypeBase Size as -> + TypeBase Size as -> + m (TypeBase Size as, [VName]) newDimOnMismatch loc t1 t2 = do (t, seen) <- runStateT (matchDims onDims t1 t2) mempty pure (t, M.elems seen) @@ -1099,11 +1132,11 @@ -- same new size. maybe_d <- gets $ M.lookup (d1, d2) case maybe_d of - Just d -> pure $ NamedDim $ qualName d + Just d -> pure $ NamedSize $ qualName d Nothing -> do d <- lift $ newDimVar loc r "differ" modify $ M.insert (d1, d2) d - pure $ NamedDim $ qualName d + pure $ NamedSize $ qualName d -- | Like unification, but creates new size variables where mismatches -- occur. Returns the new dimensions thus created. @@ -1148,7 +1181,7 @@ newTypeVar loc name = do v <- newVar name modifyConstraints $ M.insert v (0, NoConstraint Lifted $ Usage Nothing loc) - pure $ Scalar $ TypeVar mempty Nonunique (typeName v) [] + pure $ Scalar $ TypeVar mempty Nonunique (qualName v) [] newDimVar loc rigidity name = do dim <- newVar name diff --git a/unittests/Futhark/AD/DerivativesTests.hs b/unittests/Futhark/AD/DerivativesTests.hs --- a/unittests/Futhark/AD/DerivativesTests.hs +++ b/unittests/Futhark/AD/DerivativesTests.hs @@ -14,7 +14,8 @@ "Futhark.AD.DerivativesTests" [ testGroup "Primitive functions" $ map primFunTest $ - filter (not . (`elem` missing_primfuns) . fst) $ M.toList primFuns, + filter (not . (`elem` missing_primfuns) . fst) $ + M.toList primFuns, testGroup "BinOps" $ map binOpTest allBinOps, testGroup "UnOps" $ map unOpTest allUnOps ] diff --git a/unittests/Futhark/BenchTests.hs b/unittests/Futhark/BenchTests.hs --- a/unittests/Futhark/BenchTests.hs +++ b/unittests/Futhark/BenchTests.hs @@ -21,7 +21,9 @@ <*> oneof [ Left <$> arbText, Right - <$> ( Result <$> arbitrary <*> arbMap + <$> ( Result + <$> arbitrary + <*> arbMap <*> oneof [pure Nothing, Just <$> arbText] ) ] 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 @@ -57,7 +57,8 @@ ppr (Index fun is) = ppr fun <> ppr is ppr (FlatIndex fun is) = ppr fun <> ppr is ppr (Reshape fun oldshape) = - ppr fun <> text "->reshape" + ppr fun + <> text "->reshape" <> parens (commasep (map ppr oldshape)) ppr (OffsetIndex fun i) = ppr fun <> text "->offset_index" <> parens (ppr i) 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 @@ -51,7 +51,9 @@ resLMAD = map (IxFunLMAD.index ixfunLMAD) points resAlg = map (IxFunAlg.index ixfunAlg) points errorMessage = - "lmad ixfun: " ++ PR.pretty ixfunLMAD ++ "\n" + "lmad ixfun: " + ++ PR.pretty ixfunLMAD + ++ "\n" ++ "alg ixfun: " ++ PR.pretty ixfunAlg ++ "\n" diff --git a/unittests/Futhark/IR/PrimitiveTests.hs b/unittests/Futhark/IR/PrimitiveTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/PrimitiveTests.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.IR.PrimitiveTests - ( tests, - arbitraryPrimValOfType, - ) -where - -import Control.Applicative -import Futhark.IR.Primitive -import Futhark.Util (convFloat) -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.HUnit -import Prelude - -tests :: TestTree -tests = testGroup "PrimitiveTests" [propPrimValuesHaveRightType] - -propPrimValuesHaveRightType :: TestTree -propPrimValuesHaveRightType = - testGroup - "propPrimValuesHaveRightTypes" - [ testCase (show t ++ " has blank of right type") $ - primValueType (blankPrimValue t) @?= t - | t <- [minBound .. maxBound] - ] - -instance Arbitrary IntType where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary FloatType where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary PrimType where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary IntValue where - arbitrary = - oneof - [ Int8Value <$> arbitrary, - Int16Value <$> arbitrary, - Int32Value <$> arbitrary, - Int64Value <$> arbitrary - ] - -instance Arbitrary Half where - arbitrary = (convFloat :: Float -> Half) <$> arbitrary - -instance Arbitrary FloatValue where - arbitrary = - oneof - [ Float16Value <$> arbitrary, - Float32Value <$> arbitrary, - Float64Value <$> arbitrary - ] - -instance Arbitrary PrimValue where - arbitrary = - oneof - [ IntValue <$> arbitrary, - FloatValue <$> arbitrary, - BoolValue <$> arbitrary, - pure UnitValue - ] - -arbitraryPrimValOfType :: PrimType -> Gen PrimValue -arbitraryPrimValOfType (IntType Int8) = IntValue . Int8Value <$> arbitrary -arbitraryPrimValOfType (IntType Int16) = IntValue . Int16Value <$> arbitrary -arbitraryPrimValOfType (IntType Int32) = IntValue . Int32Value <$> arbitrary -arbitraryPrimValOfType (IntType Int64) = IntValue . Int64Value <$> arbitrary -arbitraryPrimValOfType (FloatType Float16) = FloatValue . Float16Value <$> arbitrary -arbitraryPrimValOfType (FloatType Float32) = FloatValue . Float32Value <$> arbitrary -arbitraryPrimValOfType (FloatType Float64) = FloatValue . Float32Value <$> arbitrary -arbitraryPrimValOfType Bool = BoolValue <$> arbitrary -arbitraryPrimValOfType Unit = pure UnitValue diff --git a/unittests/Futhark/IR/Syntax/CoreTests.hs b/unittests/Futhark/IR/Syntax/CoreTests.hs --- a/unittests/Futhark/IR/Syntax/CoreTests.hs +++ b/unittests/Futhark/IR/Syntax/CoreTests.hs @@ -5,9 +5,9 @@ import Control.Applicative import Futhark.IR.Pretty (pretty) -import Futhark.IR.PrimitiveTests () import Futhark.IR.Syntax.Core import Language.Futhark.CoreTests () +import Language.Futhark.PrimitiveTests () import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit @@ -40,7 +40,9 @@ subShapeTest :: ExtShape -> ExtShape -> Bool -> TestTree subShapeTest shape1 shape2 expected = testCase - ( "subshapeOf " ++ pretty shape1 ++ " " + ( "subshapeOf " + ++ pretty shape1 + ++ " " ++ pretty shape2 ++ " == " ++ show expected diff --git a/unittests/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs b/unittests/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs --- a/unittests/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs +++ b/unittests/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs @@ -19,33 +19,35 @@ psumTest :: TestTree psumTest = - testCase "psumTest" $ - assertEqual + testCase "psumTest" + $ assertEqual "Color simple 1-2-3 using two colors" ([(0, "local"), (1, "local")], [(1 :: Int, 0), (2, 1), (3, 0)]) - $ (M.toList *** M.toList) $ - GreedyColoring.colorGraph - (M.fromList [(1, "local"), (2, "local"), (3, "local")]) - $ S.fromList [(1, 2), (2, 3)] + $ (M.toList *** M.toList) + $ GreedyColoring.colorGraph + (M.fromList [(1, "local"), (2, "local"), (3, "local")]) + $ S.fromList [(1, 2), (2, 3)] allIntersect :: TestTree allIntersect = - testCase "allIntersect" $ - assertEqual + testCase "allIntersect" + $ assertEqual "Color a graph where all values intersect" ([(0, "local"), (1, "local"), (2, "local")], [(1 :: Int, 2), (2, 1), (3, 0)]) - $ (M.toList *** M.toList) $ - GreedyColoring.colorGraph - (M.fromList [(1, "local"), (2, "local"), (3, "local")]) - $ S.fromList [(1, 2), (2, 3), (1, 3)] + $ (M.toList *** M.toList) + $ GreedyColoring.colorGraph + (M.fromList [(1, "local"), (2, "local"), (3, "local")]) + $ S.fromList [(1, 2), (2, 3), (1, 3)] emptyGraph :: TestTree emptyGraph = - testCase "emptyGraph" $ - assertEqual + testCase "emptyGraph" + $ assertEqual "Color an empty graph" ([] :: [(Int, Char)], [] :: [(Int, Int)]) - $ (M.toList *** M.toList) $ GreedyColoring.colorGraph M.empty $ S.fromList [] + $ (M.toList *** M.toList) + $ GreedyColoring.colorGraph M.empty + $ S.fromList [] noIntersections :: TestTree noIntersections = diff --git a/unittests/Language/Futhark/CoreTests.hs b/unittests/Language/Futhark/CoreTests.hs --- a/unittests/Language/Futhark/CoreTests.hs +++ b/unittests/Language/Futhark/CoreTests.hs @@ -3,8 +3,8 @@ module Language.Futhark.CoreTests () where -import Futhark.IR.PrimitiveTests () import Language.Futhark.Core +import Language.Futhark.PrimitiveTests () import Test.QuickCheck instance Arbitrary Name where diff --git a/unittests/Language/Futhark/PrimitiveTests.hs b/unittests/Language/Futhark/PrimitiveTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Language/Futhark/PrimitiveTests.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Futhark.PrimitiveTests + ( tests, + arbitraryPrimValOfType, + ) +where + +import Control.Applicative +import Futhark.Util (convFloat) +import Language.Futhark.Primitive +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Prelude + +tests :: TestTree +tests = testGroup "PrimitiveTests" [propPrimValuesHaveRightType] + +propPrimValuesHaveRightType :: TestTree +propPrimValuesHaveRightType = + testGroup + "propPrimValuesHaveRightTypes" + [ testCase (show t ++ " has blank of right type") $ + primValueType (blankPrimValue t) @?= t + | t <- [minBound .. maxBound] + ] + +instance Arbitrary IntType where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary FloatType where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary PrimType where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary IntValue where + arbitrary = + oneof + [ Int8Value <$> arbitrary, + Int16Value <$> arbitrary, + Int32Value <$> arbitrary, + Int64Value <$> arbitrary + ] + +instance Arbitrary Half where + arbitrary = (convFloat :: Float -> Half) <$> arbitrary + +instance Arbitrary FloatValue where + arbitrary = + oneof + [ Float16Value <$> arbitrary, + Float32Value <$> arbitrary, + Float64Value <$> arbitrary + ] + +instance Arbitrary PrimValue where + arbitrary = + oneof + [ IntValue <$> arbitrary, + FloatValue <$> arbitrary, + BoolValue <$> arbitrary, + pure UnitValue + ] + +arbitraryPrimValOfType :: PrimType -> Gen PrimValue +arbitraryPrimValOfType (IntType Int8) = IntValue . Int8Value <$> arbitrary +arbitraryPrimValOfType (IntType Int16) = IntValue . Int16Value <$> arbitrary +arbitraryPrimValOfType (IntType Int32) = IntValue . Int32Value <$> arbitrary +arbitraryPrimValOfType (IntType Int64) = IntValue . Int64Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float16) = FloatValue . Float16Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float32) = FloatValue . Float32Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float64) = FloatValue . Float32Value <$> arbitrary +arbitraryPrimValOfType Bool = BoolValue <$> arbitrary +arbitraryPrimValOfType Unit = pure UnitValue diff --git a/unittests/Language/Futhark/SyntaxTests.hs b/unittests/Language/Futhark/SyntaxTests.hs --- a/unittests/Language/Futhark/SyntaxTests.hs +++ b/unittests/Language/Futhark/SyntaxTests.hs @@ -12,10 +12,10 @@ import Data.String import qualified Data.Text as T import Data.Void -import Futhark.IR.Primitive.Parse (constituent, keyword, lexeme) -import Futhark.IR.PrimitiveTests () import Language.Futhark import Language.Futhark.Parser +import Language.Futhark.Primitive.Parse (constituent, keyword, lexeme) +import Language.Futhark.PrimitiveTests () import Test.QuickCheck import Test.Tasty import Text.Megaparsec @@ -78,7 +78,8 @@ pVName :: Parser VName pVName = lexeme $ do (s, tag) <- - satisfy constituent `manyTill_` try pTag + satisfy constituent + `manyTill_` try pTag "variable name" pure $ VName (nameFromString s) tag where @@ -88,9 +89,6 @@ pQualName :: Parser (QualName VName) pQualName = QualName [] <$> pVName -pTypeName :: Parser TypeName -pTypeName = TypeName [] <$> pVName - pPrimType :: Parser PrimType pPrimType = choice $ @@ -114,15 +112,15 @@ pUniqueness :: Parser Uniqueness pUniqueness = choice [lexeme "*" $> Unique, pure Nonunique] -pDimDecl :: Parser (DimDecl VName) -pDimDecl = +pSize :: Parser Size +pSize = brackets $ choice - [ ConstDim <$> lexeme L.decimal, - NamedDim <$> pQualName + [ ConstSize <$> lexeme L.decimal, + NamedSize <$> pQualName ] -pScalarNonFun :: Parser (ScalarTypeBase (DimDecl VName) ()) +pScalarNonFun :: Parser (ScalarTypeBase Size ()) pScalarNonFun = choice [ Prim <$> pPrimType, @@ -132,10 +130,10 @@ ] where pField = (,) <$> pName <* lexeme ":" <*> pStructType - pTypeVar = TypeVar () <$> pUniqueness <*> pTypeName <*> many pTypeArg + pTypeVar = TypeVar () <$> pUniqueness <*> pQualName <*> many pTypeArg pTypeArg = choice - [ TypeArgDim <$> pDimDecl <*> pure mempty, + [ TypeArgDim <$> pSize <*> pure mempty, TypeArgType <$> pTypeArgType <*> pure mempty ] pTypeArgType = @@ -146,13 +144,13 @@ pArrayType :: Parser StructType pArrayType = - Array () <$> pUniqueness <*> (ShapeDecl <$> some pDimDecl) <*> pScalarNonFun + Array () <$> pUniqueness <*> (Shape <$> some pSize) <*> pScalarNonFun pNonFunType :: Parser StructType pNonFunType = choice [try pArrayType, try $ parens pStructType, Scalar <$> pScalarNonFun] -pScalarType :: Parser (ScalarTypeBase (DimDecl VName) ()) +pScalarType :: Parser (ScalarTypeBase Size ()) pScalarType = choice [try pFun, pScalarNonFun] where pFun = @@ -180,7 +178,7 @@ onError e = error $ "not a " <> what <> ": " <> s <> "\n" <> errorBundlePretty e -instance IsString (ScalarTypeBase (DimDecl VName) ()) where +instance IsString (ScalarTypeBase Size ()) where fromString = fromStringParse pScalarType "ScalarType" instance IsString StructType where diff --git a/unittests/futhark_tests.hs b/unittests/futhark_tests.hs --- a/unittests/futhark_tests.hs +++ b/unittests/futhark_tests.hs @@ -3,11 +3,11 @@ import qualified Futhark.AD.DerivativesTests import qualified Futhark.BenchTests import qualified Futhark.IR.Mem.IxFunTests -import qualified Futhark.IR.PrimitiveTests import qualified Futhark.IR.PropTests import qualified Futhark.IR.Syntax.CoreTests import qualified Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests import qualified Futhark.Pkg.SolveTests +import qualified Language.Futhark.PrimitiveTests import qualified Language.Futhark.SyntaxTests import qualified Language.Futhark.TypeCheckerTests import Test.Tasty @@ -23,7 +23,7 @@ Futhark.IR.Syntax.CoreTests.tests, Futhark.Pkg.SolveTests.tests, Futhark.IR.Mem.IxFunTests.tests, - Futhark.IR.PrimitiveTests.tests, + Language.Futhark.PrimitiveTests.tests, Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests.tests, Language.Futhark.TypeCheckerTests.tests ]