diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -496,11 +496,13 @@ Immediately conduct an interactive dialogue on standard output to select the platform and device from a list. -.. c:function:: struct futhark_context *futhark_context_new_with_command_queue(struct futhark_context_config *cfg, cl_command_queue queue) +.. c:function:: void futhark_context_config_set_command_queue(struct futhark_context_config *cfg, cl_command_queue queue) - Construct a context that uses a pre-existing command queue. This - allows the caller to directly customise which device and platform - is used. + Use exactly this command queue for the context. If this is set, + all other device/platform configuration options are ignored. Once + the context is active, the command queue belongs to Futhark and + should not be used by anything else. This is useful for + implementing custom device selection logic in application code. .. c:function:: cl_command_queue futhark_context_get_command_queue(struct futhark_context *ctx) diff --git a/docs/error-index.rst b/docs/error-index.rst --- a/docs/error-index.rst +++ b/docs/error-index.rst @@ -533,6 +533,32 @@ technique, but often necessary when writing advanced size-dependent code. +.. _unify-consuming-param: + +"Parameter types *x* and *y* are incompatible regarding consuming their arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This error occurs when you provide a function that *does* consume its +argument in a context that expects a function that *does not* allow a +function that consumes its argument. + +As a simple example, consider the following contrived function that +does consume its argument: + +.. code-block:: futhark + + def f (xs: *[]f32) : f32 = 0f32 + +Now we define another function that is merely ``f``, but with a type +annotation that tries to hide the consumption: + +.. code-block:: futhark + + def g : []f32 -> f32 = f + +Allowing this would permit us to hide the fact that ``f`` consumes its +argument, which would not be sound, so the type checker complains. + .. _ambiguous-size: "Ambiguous size *x*" diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -542,12 +542,20 @@ * Function and type application, and prefix operators, bind more tightly than any infix operator. Note that the only prefix - operators are ``!`` and ``-``, and more cannot be defined. + operators are the builtin ``!`` and ``-``, and more cannot be + defined. In particular, a user-defined operator beginning with + ``!`` binds as ``!=``, as on the table below, not as the prefix + operator ``!`` * ``#foo #bar`` is interpreted as a constructor with a ``#bar`` payload, not as applying ``#foo`` to ``#bar`` (the latter would be semantically invalid anyway). +* A type application ``pt [n]t`` is parsed as an application of the + type constructor ``pt`` to the size argument ``[n]`` and the type + ``t``. To pass a single array-typed parameter, enclose it in + parens. + * The following table describes the precedence and associativity of infix operators in both expressions and type expressions. All operators in the same row have the same precedence. The rows are @@ -563,7 +571,7 @@ left ```op``` left ``||`` left ``&&`` - left ``<=`` ``>=`` ``>`` ``<`` ``==`` ``!=`` + left ``<=`` ``>=`` ``>`` ``<`` ``==`` ``!=`` ``!`` ``=`` left ``&`` ``^`` ``|`` left ``<<`` ``>>`` left ``+`` ``-`` @@ -767,8 +775,8 @@ Apply an operator to ``x`` and ``y``. Operators are functions like any other, and can be user-defined. Futhark pre-defines certain -"magical" *overloaded* operators that work on many different types. -Overloaded functions cannot be defined by the user. Both operands +"magical" *overloaded* operators that work on several types. +Overloaded operators cannot be defined by the user. Both operands must have the same type. The predefined operators and their semantics are: @@ -801,16 +809,16 @@ ``==``, ``!=`` - Compare any two values of builtin or compound type for equality. + Compare any two values of builtin or compound type for equality. ``<``, ``<=``. ``>``, ``>=`` - Company any two values of numeric type for equality. + Company any two values of numeric type for equality. ```op``` - Use ``op``, which may be any non-operator function name, as an - infix operator. + Use ``op``, which may be any non-operator function name, as an + infix operator. ``x && y`` .......... @@ -927,7 +935,9 @@ Evaluate ``e`` and bind the result to the irrefutable pattern ``pat`` (see :ref:`patterns`) while evaluating ``body``. The ``in`` keyword -is optional if ``body`` is a ``let`` expression. +is optional if ``body`` is a ``let`` expression. The binding is not +let-generalised, meaning it has a monomorphic type. This can be +significant if ``e`` is of functional type. ``let [n] pat = e in body`` ........................... @@ -1072,6 +1082,10 @@ definition site. Specifically, if a top-level function uses overloaded arithmetic operators, the resolution of those overloads cannot be influenced by later uses of the function. + +Local bindings made with ``let`` are not made polymorphic through +let-generalisation *unless* they are syntactically functions, meaning +they have at least one named parameter. .. _size-types: diff --git a/docs/man/futhark-dataset.rst b/docs/man/futhark-dataset.rst --- a/docs/man/futhark-dataset.rst +++ b/docs/man/futhark-dataset.rst @@ -42,7 +42,7 @@ generated. -s int - Set the seed used for the RNG. Zero by default. + Set the seed used for the RNG. 1 by default. --T-bounds= Set inclusive lower and upper bounds on generated values of type 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 @@ -270,6 +270,11 @@ of values is returned, which should be destructured before use. For example: ``let (a, b) = $loaddata "foo.in" in bar a b``. +* ``$loadaudio "file"`` reads audio from the given file and returns it as a + ``[][]f64``, where each row corresponds to a channel of the original + soundfile. Most common audio-formats are supported, including mp3, ogg, wav, + flac and opus. + SAFETY ====== diff --git a/docs/man/futhark-pkg.rst b/docs/man/futhark-pkg.rst --- a/docs/man/futhark-pkg.rst +++ b/docs/man/futhark-pkg.rst @@ -53,8 +53,8 @@ Most commands take a ``-v``/``--verbose`` option that makes ``futhark pkg`` write running diagnostics to stderr. -Network requests (exclusively HTTP GETs) are done via ``curl``, which -must be available on the ``PATH``. +Packages must correspond to Git repositories, and all interactions are +done by invoking ``git``. COMMANDS ======== @@ -159,10 +159,8 @@ the dependencies of its dependencies, without the ``futhark.pkg`` file reflecting this. -There is no caching of zipballs and version lists between invocations, -so the network traffic can be rather heavy. - -Only GitHub and GitLab are supported as code hosting sites. +There is no caching of package metadata between invocations, so the +network traffic can be rather heavy. SEE ALSO ======== diff --git a/docs/man/futhark-test.rst b/docs/man/futhark-test.rst --- a/docs/man/futhark-test.rst +++ b/docs/man/futhark-test.rst @@ -37,9 +37,14 @@ [tags { tags... }] [entry: names...] - [compiled|nobench|random|script] input ({ values... } | @ filename) + ["name..."] [compiled|nobench|random|script] input ({ values... } | @ filename) output { values... } | auto output | error: regex +If a test case begins with a quoted string, that string is reported as +the dataset name, including in the JSON file produced by +:ref:`futhark-bench(1)`. If no name is provided, one is automatically +generated. The name must be unique across all test cases. + If ``compiled`` is present before the ``input`` keyword, this test case will never be passed to the interpreter. This is useful for test cases that are annoyingly slow to interpret. The ``nobench`` keyword @@ -60,6 +65,7 @@ It must use only functions explicitly declared as entry points. If the expression produces an *n*-element tuple, it will be unpacked and its components passed as *n* distinct arguments to the test function. +The only builtin function supported is ``$loaddata``. If ``input`` is followed by an ``@`` and a file name (which must not contain any whitespace) instead of curly braces, values or diff --git a/docs/man/futhark.rst b/docs/man/futhark.rst --- a/docs/man/futhark.rst +++ b/docs/man/futhark.rst @@ -24,6 +24,13 @@ COMMANDS ======== +futhark benchcmp FILE_A FILE_B +------------------------------ + +Compares two Futhark benchmarks and reports changes in performance. +The files must be formatted in the same manner as a JSON file returned +from :ref:`futhark-bench(1)`. + futhark check [-w] PROGRAM -------------------------- @@ -65,6 +72,12 @@ A Futhark compiler development command, intentionally undocumented and intended for use in developing the Futhark compiler, not for programmers writing in Futhark. + +futhark eval [-f FILE] [-w] +-------------------------------------- + +Evaluates expressions given as command-line arguments. Optionally +allows a file import using ``-f``. futhark hash PROGRAM -------------------- diff --git a/docs/package-management.rst b/docs/package-management.rst --- a/docs/package-management.rst +++ b/docs/package-management.rst @@ -14,9 +14,11 @@ A package is uniquely identified with a *package path*, which is similar to a URL, except without a protocol. At the moment, package -paths are always links to Git repositories hosted on GitHub or GitLab. -In the future, this will become more flexible. As an example, a -package path may be ``github.com/athas/fut-foo``. +paths must be something that can be passed to ``git clone``. In +particular, this includes paths to repositories on major code hosting +sites such as GitLab and GitHub. In the future, this will become more +flexible. As an example, a package path may be +``github.com/athas/fut-foo``. Packages are versioned with `semantic version numbers `_ of the form ``X.Y.Z``. Whenever versions are @@ -359,3 +361,23 @@ (but the ``--safe`` compiler option may help). However, this is not any worse than calling external code in a conventional impure language, which generally can perform any conceivable harmful action. + +Private repositories +-------------------- + +The Futhark package manager is intentionally very simple - perhaps +even simplistic. The key philosophy is that if you can ``git clone`` +a repository from the command line, then ``futhark pkg`` can also +access it. However, ``futhark pkg`` always uses the ``https://`` +protocol when converting package paths to the URLs that are passed to +``git``, which is sometimes inconvenient for self-hosted or private +repositories. As a workaround, you can modify your Git configuration +file to transparently replace ``https://`` with ``ssh://`` for certain +repositories. For example, you can add the following entry +``$HOME/.gitconfig``:: + + [url "ssh://git@github.com/sturluson"] + insteadOf = https://github.com/sturluson + +This will make all interactions with repositories owned by the +``sturluson`` user on GitHub use SSH instead of HTTPS. diff --git a/docs/performance.rst b/docs/performance.rst --- a/docs/performance.rst +++ b/docs/performance.rst @@ -242,12 +242,13 @@ (u8, [n]i32) +However the type .. code-block:: futhark #foo [n]i32 | #bar [n]f32 -becomes +is represented as .. code-block:: futhark 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.22.7 +version: 0.23.1 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to @@ -39,6 +39,10 @@ rts/c/atomics.h rts/c/context.h rts/c/context_prototypes.h + rts/c/backends/c.h + rts/c/backends/cuda.h + rts/c/backends/multicore.h + rts/c/backends/opencl.h rts/c/lock.h rts/c/timing.h rts/c/errors.h @@ -46,8 +50,6 @@ 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 @@ -172,7 +174,6 @@ Futhark.Analysis.PrimExp.Convert Futhark.Analysis.PrimExp.Parse Futhark.Analysis.PrimExp.Simplify - Futhark.Analysis.Rephrase Futhark.Analysis.SymbolTable Futhark.Analysis.UsageTable Futhark.Bench @@ -183,11 +184,13 @@ Futhark.CLI.C Futhark.CLI.CUDA Futhark.CLI.Check + Futhark.CLI.Benchcmp Futhark.CLI.Datacmp Futhark.CLI.Dataset Futhark.CLI.Defs Futhark.CLI.Dev Futhark.CLI.Doc + Futhark.CLI.Eval Futhark.CLI.Literate Futhark.CLI.LSP Futhark.CLI.Main @@ -223,6 +226,7 @@ Futhark.CodeGen.Backends.GenericPython.Options Futhark.CodeGen.Backends.GenericWASM Futhark.CodeGen.Backends.MulticoreC + Futhark.CodeGen.Backends.MulticoreC.Boilerplate Futhark.CodeGen.Backends.MulticoreISPC Futhark.CodeGen.Backends.MulticoreWASM Futhark.CodeGen.Backends.PyOpenCL @@ -263,7 +267,6 @@ Futhark.CodeGen.ImpGen.Sequential Futhark.CodeGen.ImpGen.Transpose Futhark.CodeGen.OpenCL.Heuristics - Futhark.CodeGen.SetDefaultSpace Futhark.Compiler Futhark.Compiler.CLI Futhark.Compiler.Config @@ -299,6 +302,7 @@ Futhark.IR.Prop.TypeOf Futhark.IR.Prop.Types Futhark.IR.Rep + Futhark.IR.Rephrase Futhark.IR.RetType Futhark.IR.SOACS Futhark.IR.SOACS.SOAC @@ -348,7 +352,6 @@ Futhark.Optimise.ArrayShortCircuiting Futhark.Optimise.ArrayShortCircuiting.ArrayCoalescing Futhark.Optimise.ArrayShortCircuiting.DataStructs - Futhark.Optimise.ArrayShortCircuiting.LastUse Futhark.Optimise.ArrayShortCircuiting.MemRefAggreg Futhark.Optimise.ArrayShortCircuiting.TopdownAnalysis Futhark.Optimise.MergeGPUBodies @@ -507,7 +510,6 @@ , transformers >=0.3 , vector >=0.12 , versions >=5.0.0 - , zip-archive >=0.3.1.1 , zlib >=0.6.1.2 , statistics , mwc-random @@ -517,7 +519,7 @@ executable futhark import: common main-is: src/main.hs - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -qg1 -A16M" + ghc-options: -threaded -rtsopts "-with-rtsopts=-maxN16 -qg1 -A16M" build-depends: base, futhark test-suite unit diff --git a/prelude/math.fut b/prelude/math.fut --- a/prelude/math.fut +++ b/prelude/math.fut @@ -187,6 +187,8 @@ val log2: t -> t -- | Base-10 logarithm. val log10: t -> t + -- | Compute `log (1 + x)` accurately even when `x` is very small. + val log1p: t -> t -- | Round towards infinity. val ceil : t -> t @@ -927,6 +929,7 @@ def log (x: f64) = intrinsics.log64 x def log2 (x: f64) = intrinsics.log2_64 x def log10 (x: f64) = intrinsics.log10_64 x + def log1p (x: f64) = intrinsics.log1p_64 x def exp (x: f64) = intrinsics.exp64 x def sin (x: f64) = intrinsics.sin64 x def cos (x: f64) = intrinsics.cos64 x @@ -1041,6 +1044,7 @@ def log (x: f32) = intrinsics.log32 x def log2 (x: f32) = intrinsics.log2_32 x def log10 (x: f32) = intrinsics.log10_32 x + def log1p (x: f32) = intrinsics.log1p_32 x def exp (x: f32) = intrinsics.exp32 x def sin (x: f32) = intrinsics.sin32 x def cos (x: f32) = intrinsics.cos32 x @@ -1159,6 +1163,7 @@ def log (x: f16) = intrinsics.log16 x def log2 (x: f16) = intrinsics.log2_16 x def log10 (x: f16) = intrinsics.log10_16 x + def log1p (x: f16) = intrinsics.log1p_16 x def exp (x: f16) = intrinsics.exp16 x def sin (x: f16) = intrinsics.sin16 x def cos (x: f16) = intrinsics.cos16 x diff --git a/prelude/soacs.fut b/prelude/soacs.fut --- a/prelude/soacs.fut +++ b/prelude/soacs.fut @@ -211,7 +211,7 @@ def any [n] 'a (f: a -> bool) (as: [n]a): bool = reduce (||) false (map f as) --- | `r = spread x k is vs` produces an array `r` such that `r[i] = +-- | `r = spread k x 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 diff --git a/rts/c/backends/c.h b/rts/c/backends/c.h new file mode 100644 --- /dev/null +++ b/rts/c/backends/c.h @@ -0,0 +1,61 @@ +// Start of backends/c.h + +struct futhark_context_config { + int in_use; + int debugging; + int profiling; + int logging; + const char *cache_fname; + int num_tuning_params; + int64_t *tuning_params; + const char** tuning_param_names; + const char** tuning_param_vars; + const char** tuning_param_classes; +}; + +static void backend_context_config_setup(struct futhark_context_config* cfg) { + (void)cfg; +} + +static void backend_context_config_teardown(struct futhark_context_config* cfg) { + (void)cfg; +} + +int futhark_context_config_set_tuning_param(struct futhark_context_config* cfg, const char *param_name, size_t param_value) { + (void)cfg; (void)param_name; (void)param_value; + return 1; +} + +struct futhark_context { + struct futhark_context_config* cfg; + int detail_memory; + int debugging; + int profiling; + int profiling_paused; + int logging; + lock_t lock; + char *error; + lock_t error_lock; + FILE *log; + struct constants *constants; + struct free_list free_list; + int64_t peak_mem_usage_default; + int64_t cur_mem_usage_default; + struct program* program; +}; + +int backend_context_setup(struct futhark_context* ctx) { + (void)ctx; + return 0; +} + +void backend_context_teardown(struct futhark_context* ctx) { + (void)ctx; +} + +int futhark_context_sync(struct futhark_context* ctx) { + (void)ctx; + return 0; +} + +// End of backends/c.h diff --git a/rts/c/backends/cuda.h b/rts/c/backends/cuda.h new file mode 100644 --- /dev/null +++ b/rts/c/backends/cuda.h @@ -0,0 +1,947 @@ +// Start of backends/cuda.h. + +// Forward declarations. +// Invoked by setup_opencl() after the platform and device has been +// found, but before the program is loaded. Its intended use is to +// tune constants based on the selected platform and device. +static void set_tuning_params(struct futhark_context* ctx); +static char* get_failure_msg(int failure_idx, int64_t args[]); + +#define CUDA_SUCCEED_FATAL(x) cuda_api_succeed_fatal(x, #x, __FILE__, __LINE__) +#define CUDA_SUCCEED_NONFATAL(x) cuda_api_succeed_nonfatal(x, #x, __FILE__, __LINE__) +#define NVRTC_SUCCEED_FATAL(x) nvrtc_api_succeed_fatal(x, #x, __FILE__, __LINE__) +#define NVRTC_SUCCEED_NONFATAL(x) nvrtc_api_succeed_nonfatal(x, #x, __FILE__, __LINE__) +// Take care not to override an existing error. +#define CUDA_SUCCEED_OR_RETURN(e) { \ + char *serror = CUDA_SUCCEED_NONFATAL(e); \ + if (serror) { \ + if (!ctx->error) { \ + ctx->error = serror; \ + return bad; \ + } else { \ + free(serror); \ + } \ + } \ + } + +// CUDA_SUCCEED_OR_RETURN returns the value of the variable 'bad' in +// scope. By default, it will be this one. Create a local variable +// of some other type if needed. This is a bit of a hack, but it +// saves effort in the code generator. +static const int bad = 1; + +static inline void cuda_api_succeed_fatal(CUresult res, const char *call, + const char *file, int line) { + if (res != CUDA_SUCCESS) { + const char *err_str; + cuGetErrorString(res, &err_str); + if (err_str == NULL) { err_str = "Unknown"; } + futhark_panic(-1, "%s:%d: CUDA call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } +} + +static char* cuda_api_succeed_nonfatal(CUresult res, const char *call, + const char *file, int line) { + if (res != CUDA_SUCCESS) { + const char *err_str; + cuGetErrorString(res, &err_str); + if (err_str == NULL) { err_str = "Unknown"; } + return msgprintf("%s:%d: CUDA call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } else { + return NULL; + } +} + +static inline void nvrtc_api_succeed_fatal(nvrtcResult res, const char *call, + const char *file, int line) { + if (res != NVRTC_SUCCESS) { + const char *err_str = nvrtcGetErrorString(res); + futhark_panic(-1, "%s:%d: NVRTC call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } +} + +static char* nvrtc_api_succeed_nonfatal(nvrtcResult res, const char *call, + const char *file, int line) { + if (res != NVRTC_SUCCESS) { + const char *err_str = nvrtcGetErrorString(res); + return msgprintf("%s:%d: NVRTC call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } else { + return NULL; + } +} + +struct futhark_context_config { + int in_use; + int debugging; + int profiling; + int logging; + const char *cache_fname; + int num_tuning_params; + int64_t *tuning_params; + const char** tuning_param_names; + const char** tuning_param_vars; + const char** tuning_param_classes; + // Uniform fields above. + + int num_nvrtc_opts; + const char **nvrtc_opts; + + const char *preferred_device; + int preferred_device_num; + + const char *dump_program_to; + const char *load_program_from; + + const char *dump_ptx_to; + const char *load_ptx_from; + + size_t default_block_size; + size_t default_grid_size; + size_t default_tile_size; + size_t default_reg_tile_size; + size_t default_threshold; + + int default_block_size_changed; + int default_grid_size_changed; + int default_tile_size_changed; +}; + +static void backend_context_config_setup(struct futhark_context_config *cfg) { + cfg->num_nvrtc_opts = 0; + cfg->nvrtc_opts = (const char**) malloc(sizeof(const char*)); + cfg->nvrtc_opts[0] = NULL; + + cfg->preferred_device_num = 0; + cfg->preferred_device = ""; + cfg->dump_program_to = NULL; + cfg->load_program_from = NULL; + + cfg->dump_ptx_to = NULL; + cfg->load_ptx_from = NULL; + + cfg->default_block_size = 256; + cfg->default_grid_size = 0; // Set properly later. + cfg->default_tile_size = 32; + cfg->default_reg_tile_size = 2; + cfg->default_threshold = 32*1024; + + cfg->default_block_size_changed = 0; + cfg->default_grid_size_changed = 0; + cfg->default_tile_size_changed = 0; +} + +static void backend_context_config_teardown(struct futhark_context_config* cfg) { + free(cfg->nvrtc_opts); +} + +void futhark_context_config_add_nvrtc_option(struct futhark_context_config *cfg, const char *opt) { + cfg->nvrtc_opts[cfg->num_nvrtc_opts] = opt; + cfg->num_nvrtc_opts++; + cfg->nvrtc_opts = (const char **) realloc(cfg->nvrtc_opts, (cfg->num_nvrtc_opts + 1) * sizeof(const char *)); + cfg->nvrtc_opts[cfg->num_nvrtc_opts] = NULL; +} + +void futhark_context_config_set_device(struct futhark_context_config *cfg, const char *s) { + int x = 0; + if (*s == '#') { + s++; + while (isdigit(*s)) { + x = x * 10 + (*s++)-'0'; + } + // Skip trailing spaces. + while (isspace(*s)) { + s++; + } + } + cfg->preferred_device = s; + cfg->preferred_device_num = x; +} + +void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path) { + cfg->dump_program_to = path; +} + +void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path) { + cfg->load_program_from = path; +} + +void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char *path) { + cfg->dump_ptx_to = path; +} + +void futhark_context_config_load_ptx_from(struct futhark_context_config *cfg, const char *path) { + cfg->load_ptx_from = path; +} + +void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size) { + cfg->default_block_size = size; + cfg->default_block_size_changed = 1; +} + +void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int num) { + cfg->default_grid_size = num; + cfg->default_grid_size_changed = 1; +} + +void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size) { + cfg->default_tile_size = size; + cfg->default_tile_size_changed = 1; +} + +void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size) { + cfg->default_reg_tile_size = size; +} + +void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size) { + cfg->default_threshold = size; +} + +int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg, + const char *param_name, + size_t new_value) { + for (int i = 0; i < cfg->num_tuning_params; i++) { + if (strcmp(param_name, cfg->tuning_param_names[i]) == 0) { + cfg->tuning_params[i] = new_value; + return 0; + } + } + if (strcmp(param_name, "default_group_size") == 0) { + cfg->default_block_size = new_value; + return 0; + } + if (strcmp(param_name, "default_num_groups") == 0) { + cfg->default_grid_size = new_value; + return 0; + } + if (strcmp(param_name, "default_threshold") == 0) { + cfg->default_threshold = new_value; + return 0; + } + if (strcmp(param_name, "default_tile_size") == 0) { + cfg->default_tile_size = new_value; + return 0; + } + if (strcmp(param_name, "default_reg_tile_size") == 0) { + cfg->default_reg_tile_size = new_value; + return 0; + } + return 1; +} + +// A record of something that happened. +struct profiling_record { + cudaEvent_t *events; // Points to two events. + int *runs; + int64_t *runtime; +}; + +struct futhark_context { + struct futhark_context_config* cfg; + int detail_memory; + int debugging; + int profiling; + int profiling_paused; + int logging; + lock_t lock; + char *error; + lock_t error_lock; + FILE *log; + struct constants *constants; + struct free_list cu_free_list; + int64_t peak_mem_usage_default; + int64_t cur_mem_usage_default; + // Uniform above + + CUdeviceptr global_failure; + CUdeviceptr global_failure_args; + struct tuning_params tuning_params; + // True if a potentially failing kernel has been enqueued. + int32_t failure_is_an_option; + int total_runs; + long int total_runtime; + int64_t peak_mem_usage_device; + int64_t cur_mem_usage_device; + struct program* program; + + CUdevice dev; + CUcontext cu_ctx; + CUmodule module; + + struct free_list free_list; + + size_t max_block_size; + size_t max_grid_size; + size_t max_tile_size; + size_t max_threshold; + size_t max_shared_memory; + size_t max_bespoke; + + size_t lockstep_width; + + struct profiling_record *profiling_records; + int profiling_records_capacity; + int profiling_records_used; +}; + +#define CU_DEV_ATTR(x) (CU_DEVICE_ATTRIBUTE_##x) +#define device_query(dev,attrib) _device_query(dev, CU_DEV_ATTR(attrib)) +static int _device_query(CUdevice dev, CUdevice_attribute attrib) { + int val; + CUDA_SUCCEED_FATAL(cuDeviceGetAttribute(&val, attrib, dev)); + return val; +} + +#define CU_FUN_ATTR(x) (CU_FUNC_ATTRIBUTE_##x) +#define function_query(fn,attrib) _function_query(dev, CU_FUN_ATTR(attrib)) +static int _function_query(CUfunction dev, CUfunction_attribute attrib) { + int val; + CUDA_SUCCEED_FATAL(cuFuncGetAttribute(&val, attrib, dev)); + return val; +} + +static int cuda_device_setup(struct futhark_context *ctx) { + struct futhark_context_config *cfg = ctx->cfg; + char name[256]; + int count, chosen = -1, best_cc = -1; + int cc_major_best, cc_minor_best; + int cc_major, cc_minor; + CUdevice dev; + + CUDA_SUCCEED_FATAL(cuDeviceGetCount(&count)); + if (count == 0) { return 1; } + + int num_device_matches = 0; + + // XXX: Current device selection policy is to choose the device with the + // highest compute capability (if no preferred device is set). + // This should maybe be changed, since greater compute capability is not + // necessarily an indicator of better performance. + for (int i = 0; i < count; i++) { + CUDA_SUCCEED_FATAL(cuDeviceGet(&dev, i)); + + cc_major = device_query(dev, COMPUTE_CAPABILITY_MAJOR); + cc_minor = device_query(dev, COMPUTE_CAPABILITY_MINOR); + + CUDA_SUCCEED_FATAL(cuDeviceGetName(name, sizeof(name) - 1, dev)); + name[sizeof(name) - 1] = 0; + + if (cfg->logging) { + fprintf(stderr, "Device #%d: name=\"%s\", compute capability=%d.%d\n", + i, name, cc_major, cc_minor); + } + + if (device_query(dev, COMPUTE_MODE) == CU_COMPUTEMODE_PROHIBITED) { + if (cfg->logging) { + fprintf(stderr, "Device #%d is compute-prohibited, ignoring\n", i); + } + continue; + } + + if (best_cc == -1 || cc_major > cc_major_best || + (cc_major == cc_major_best && cc_minor > cc_minor_best)) { + best_cc = i; + cc_major_best = cc_major; + cc_minor_best = cc_minor; + } + + if (strstr(name, cfg->preferred_device) != NULL && + num_device_matches++ == cfg->preferred_device_num) { + chosen = i; + break; + } + } + + if (chosen == -1) { chosen = best_cc; } + if (chosen == -1) { return 1; } + + if (cfg->logging) { + fprintf(stderr, "Using device #%d\n", chosen); + } + + CUDA_SUCCEED_FATAL(cuDeviceGet(&ctx->dev, chosen)); + return 0; +} + +static char *concat_fragments(const char *src_fragments[]) { + size_t src_len = 0; + const char **p; + + for (p = src_fragments; *p; p++) { + src_len += strlen(*p); + } + + char *src = (char*) malloc(src_len + 1); + size_t n = 0; + for (p = src_fragments; *p; p++) { + strcpy(src + n, *p); + n += strlen(*p); + } + + return src; +} + +static const char *cuda_nvrtc_get_arch(CUdevice dev) { + struct { + int major; + int minor; + const char *arch_str; + } static const x[] = { + { 3, 0, "compute_30" }, + { 3, 2, "compute_32" }, + { 3, 5, "compute_35" }, + { 3, 7, "compute_37" }, + { 5, 0, "compute_50" }, + { 5, 2, "compute_52" }, + { 5, 3, "compute_53" }, + { 6, 0, "compute_60" }, + { 6, 1, "compute_61" }, + { 6, 2, "compute_62" }, + { 7, 0, "compute_70" }, + { 7, 2, "compute_72" }, + { 7, 5, "compute_75" }, + { 8, 0, "compute_80" }, + { 8, 6, "compute_80" }, + { 8, 7, "compute_80" } + }; + + int major = device_query(dev, COMPUTE_CAPABILITY_MAJOR); + int minor = device_query(dev, COMPUTE_CAPABILITY_MINOR); + + int chosen = -1; + int num_archs = sizeof(x)/sizeof(x[0]); + for (int i = 0; i < num_archs; i++) { + if (x[i].major < major || (x[i].major == major && x[i].minor <= minor)) { + chosen = i; + } else { + break; + } + } + + if (chosen == -1) { + futhark_panic(-1, "Unsupported compute capability %d.%d\n", major, minor); + } + + if (x[chosen].major != major || x[chosen].minor != minor) { + fprintf(stderr, + "Warning: device compute capability is %d.%d, but newest supported by Futhark is %d.%d.\n", + major, minor, x[chosen].major, x[chosen].minor); + } + + return x[chosen].arch_str; +} + +static void cuda_nvrtc_mk_build_options(struct futhark_context *ctx, const char *extra_opts[], + char*** opts_out, size_t *n_opts) { + int arch_set = 0, num_extra_opts; + struct futhark_context_config *cfg = ctx->cfg; + + // nvrtc cannot handle multiple -arch options. Hence, if one of the + // extra_opts is -arch, we have to be careful not to do our usual + // automatic generation. + for (num_extra_opts = 0; extra_opts[num_extra_opts] != NULL; num_extra_opts++) { + if (strstr(extra_opts[num_extra_opts], "-arch") + == extra_opts[num_extra_opts] || + strstr(extra_opts[num_extra_opts], "--gpu-architecture") + == extra_opts[num_extra_opts]) { + arch_set = 1; + } + } + + size_t i = 0, n_opts_alloc = 20 + num_extra_opts + cfg->num_tuning_params; + char **opts = (char**) malloc(n_opts_alloc * sizeof(char *)); + if (!arch_set) { + opts[i++] = strdup("-arch"); + opts[i++] = strdup(cuda_nvrtc_get_arch(ctx->dev)); + } + opts[i++] = strdup("-default-device"); + if (cfg->debugging) { + opts[i++] = strdup("-G"); + opts[i++] = strdup("-lineinfo"); + } else { + opts[i++] = strdup("--disable-warnings"); + } + opts[i++] = msgprintf("-D%s=%d", + "max_group_size", + (int)ctx->max_block_size); + for (int j = 0; j < cfg->num_tuning_params; j++) { + opts[i++] = msgprintf("-D%s=%zu", cfg->tuning_param_vars[j], + cfg->tuning_params[j]); + } + opts[i++] = msgprintf("-DLOCKSTEP_WIDTH=%zu", ctx->lockstep_width); + opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_block_size); + + // Time for the best lines of the code in the entire compiler. + if (getenv("CUDA_HOME") != NULL) { + opts[i++] = msgprintf("-I%s/include", getenv("CUDA_HOME")); + } + if (getenv("CUDA_ROOT") != NULL) { + opts[i++] = msgprintf("-I%s/include", getenv("CUDA_ROOT")); + } + if (getenv("CUDA_PATH") != NULL) { + opts[i++] = msgprintf("-I%s/include", getenv("CUDA_PATH")); + } + opts[i++] = msgprintf("-I/usr/local/cuda/include"); + opts[i++] = msgprintf("-I/usr/include"); + + for (int j = 0; extra_opts[j] != NULL; j++) { + opts[i++] = strdup(extra_opts[j]); + } + + *n_opts = i; + *opts_out = opts; +} + +static char* cuda_nvrtc_build(const char *src, const char *opts[], size_t n_opts, + char **ptx) { + nvrtcProgram prog; + char *problem = NULL; + + problem = NVRTC_SUCCEED_NONFATAL(nvrtcCreateProgram(&prog, src, "futhark-cuda", 0, NULL, NULL)); + + if (problem) { + return problem; + } + + nvrtcResult res = nvrtcCompileProgram(prog, n_opts, opts); + if (res != NVRTC_SUCCESS) { + size_t log_size; + if (nvrtcGetProgramLogSize(prog, &log_size) == NVRTC_SUCCESS) { + char *log = (char*) malloc(log_size); + if (nvrtcGetProgramLog(prog, log) == NVRTC_SUCCESS) { + problem = msgprintf("NVRTC compilation failed.\n\n%s\n", log); + } else { + problem = msgprintf("Could not retrieve compilation log\n"); + } + free(log); + } + return problem; + } + + size_t ptx_size; + NVRTC_SUCCEED_FATAL(nvrtcGetPTXSize(prog, &ptx_size)); + *ptx = (char*) malloc(ptx_size); + NVRTC_SUCCEED_FATAL(nvrtcGetPTX(prog, *ptx)); + + NVRTC_SUCCEED_FATAL(nvrtcDestroyProgram(&prog)); + + return NULL; +} + +static void cuda_load_ptx_from_cache(struct futhark_context_config *cfg, + const char *src, + const char *opts[], size_t n_opts, + struct cache_hash *h, const char *cache_fname, + char **ptx) { + if (cfg->logging) { + fprintf(stderr, "Restoring cache from from %s...\n", cache_fname); + } + cache_hash_init(h); + for (size_t i = 0; i < n_opts; i++) { + cache_hash(h, opts[i], strlen(opts[i])); + } + cache_hash(h, src, strlen(src)); + size_t ptxsize; + errno = 0; + if (cache_restore(cache_fname, h, (unsigned char**)ptx, &ptxsize) != 0) { + if (cfg->logging) { + fprintf(stderr, "Failed to restore cache (errno: %s)\n", strerror(errno)); + } + } +} + +static void cuda_size_setup(struct futhark_context *ctx) +{ + struct futhark_context_config *cfg = ctx->cfg; + if (cfg->default_block_size > ctx->max_block_size) { + if (cfg->default_block_size_changed) { + fprintf(stderr, + "Note: Device limits default block size to %zu (down from %zu).\n", + ctx->max_block_size, cfg->default_block_size); + } + cfg->default_block_size = ctx->max_block_size; + } + if (cfg->default_grid_size > ctx->max_grid_size) { + if (cfg->default_grid_size_changed) { + fprintf(stderr, + "Note: Device limits default grid size to %zu (down from %zu).\n", + ctx->max_grid_size, cfg->default_grid_size); + } + cfg->default_grid_size = ctx->max_grid_size; + } + if (cfg->default_tile_size > ctx->max_tile_size) { + if (cfg->default_tile_size_changed) { + fprintf(stderr, + "Note: Device limits default tile size to %zu (down from %zu).\n", + ctx->max_tile_size, cfg->default_tile_size); + } + cfg->default_tile_size = ctx->max_tile_size; + } + + if (!cfg->default_grid_size_changed) { + cfg->default_grid_size = + (device_query(ctx->dev, MULTIPROCESSOR_COUNT) * + device_query(ctx->dev, MAX_THREADS_PER_MULTIPROCESSOR)) + / cfg->default_block_size; + } + + for (int i = 0; i < cfg->num_tuning_params; i++) { + const char *size_class = cfg->tuning_param_classes[i]; + int64_t *size_value = &cfg->tuning_params[i]; + const char* size_name = cfg->tuning_param_names[i]; + int64_t max_value = 0, default_value = 0; + + if (strstr(size_class, "group_size") == size_class) { + max_value = ctx->max_block_size; + default_value = cfg->default_block_size; + } else if (strstr(size_class, "num_groups") == size_class) { + max_value = ctx->max_grid_size; + default_value = cfg->default_grid_size; + // XXX: as a quick and dirty hack, use twice as many threads for + // histograms by default. We really should just be smarter + // about sizes somehow. + if (strstr(size_name, ".seghist_") != NULL) { + default_value *= 2; + } + } else if (strstr(size_class, "tile_size") == size_class) { + max_value = ctx->max_tile_size; + default_value = cfg->default_tile_size; + } else if (strstr(size_class, "reg_tile_size") == size_class) { + max_value = 0; // No limit. + default_value = cfg->default_reg_tile_size; + } else if (strstr(size_class, "threshold") == size_class) { + // Threshold can be as large as it takes. + default_value = cfg->default_threshold; + } else { + // Bespoke sizes have no limit or default. + } + + if (*size_value == 0) { + *size_value = default_value; + } else if (max_value > 0 && *size_value > max_value) { + fprintf(stderr, "Note: Device limits %s to %zu (down from %zu)\n", + size_name, max_value, *size_value); + *size_value = max_value; + } + } +} + +static char* cuda_module_setup(struct futhark_context *ctx, + const char *src_fragments[], + const char *extra_opts[], + const char* cache_fname) { + char *ptx = NULL, *src = NULL; + struct futhark_context_config *cfg = ctx->cfg; + + if (cfg->load_program_from == NULL) { + src = concat_fragments(src_fragments); + } else { + src = slurp_file(cfg->load_program_from, NULL); + } + + if (cfg->load_ptx_from) { + if (cfg->load_program_from != NULL) { + fprintf(stderr, + "WARNING: Using PTX from %s instead of C code from %s\n", + cfg->load_ptx_from, cfg->load_program_from); + } + ptx = slurp_file(cfg->load_ptx_from, NULL); + } + + if (cfg->dump_program_to != NULL) { + dump_file(cfg->dump_program_to, src, strlen(src)); + } + + char **opts; + size_t n_opts; + cuda_nvrtc_mk_build_options(ctx, extra_opts, &opts, &n_opts); + + if (cfg->logging) { + fprintf(stderr, "NVRTC compile options:\n"); + for (size_t j = 0; j < n_opts; j++) { + fprintf(stderr, "\t%s\n", opts[j]); + } + fprintf(stderr, "\n"); + } + + struct cache_hash h; + int loaded_ptx_from_cache = 0; + if (cache_fname != NULL) { + cuda_load_ptx_from_cache(cfg, src, (const char**)opts, n_opts, &h, cache_fname, &ptx); + + if (ptx != NULL) { + if (cfg->logging) { + fprintf(stderr, "Restored PTX from cache; now loading module...\n"); + } + if (cuModuleLoadData(&ctx->module, ptx) == CUDA_SUCCESS) { + if (cfg->logging) { + fprintf(stderr, "Success!\n"); + } + loaded_ptx_from_cache = 1; + } else { + if (cfg->logging) { + fprintf(stderr, "Failed!\n"); + } + free(ptx); + ptx = NULL; + } + } + } + + if (ptx == NULL) { + char* problem = cuda_nvrtc_build(src, (const char**)opts, n_opts, &ptx); + if (problem != NULL) { + free(src); + return problem; + } + } + + if (cfg->dump_ptx_to != NULL) { + dump_file(cfg->dump_ptx_to, ptx, strlen(ptx)); + } + + if (!loaded_ptx_from_cache) { + CUDA_SUCCEED_FATAL(cuModuleLoadData(&ctx->module, ptx)); + } + + if (cache_fname != NULL && !loaded_ptx_from_cache) { + if (cfg->logging) { + fprintf(stderr, "Caching PTX in %s...\n", cache_fname); + } + errno = 0; + if (cache_store(cache_fname, &h, (const unsigned char*)ptx, strlen(ptx)) != 0) { + fprintf(stderr, "Failed to cache PTX: %s\n", strerror(errno)); + } + } + + for (size_t i = 0; i < n_opts; i++) { + free((char *)opts[i]); + } + free(opts); + + free(ptx); + if (src != NULL) { + free(src); + } + + return NULL; +} + +static char* cuda_setup(struct futhark_context *ctx, const char *src_fragments[], + const char *extra_opts[], const char* cache_fname) { + CUDA_SUCCEED_FATAL(cuInit(0)); + + if (cuda_device_setup(ctx) != 0) { + futhark_panic(-1, "No suitable CUDA device found.\n"); + } + CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev)); + + free_list_init(&ctx->cu_free_list); + + ctx->max_shared_memory = device_query(ctx->dev, MAX_SHARED_MEMORY_PER_BLOCK); + ctx->max_block_size = device_query(ctx->dev, MAX_THREADS_PER_BLOCK); + ctx->max_grid_size = device_query(ctx->dev, MAX_GRID_DIM_X); + ctx->max_tile_size = sqrt(ctx->max_block_size); + ctx->max_threshold = 0; + ctx->max_bespoke = 0; + ctx->lockstep_width = device_query(ctx->dev, WARP_SIZE); + + cuda_size_setup(ctx); + return cuda_module_setup(ctx, src_fragments, extra_opts, cache_fname); +} + +// Count up the runtime all the profiling_records that occured during execution. +// Also clears the buffer of profiling_records. +static cudaError_t cuda_tally_profiling_records(struct futhark_context *ctx) { + cudaError_t err; + for (int i = 0; i < ctx->profiling_records_used; i++) { + struct profiling_record record = ctx->profiling_records[i]; + + float ms; + if ((err = cudaEventElapsedTime(&ms, record.events[0], record.events[1])) != cudaSuccess) { + return err; + } + + // CUDA provides milisecond resolution, but we want microseconds. + *record.runs += 1; + *record.runtime += ms*1000; + + if ((err = cudaEventDestroy(record.events[0])) != cudaSuccess) { + return err; + } + if ((err = cudaEventDestroy(record.events[1])) != cudaSuccess) { + return err; + } + + free(record.events); + } + + ctx->profiling_records_used = 0; + + return cudaSuccess; +} + +// Returns pointer to two events. +static cudaEvent_t* cuda_get_events(struct futhark_context *ctx, int *runs, int64_t *runtime) { + if (ctx->profiling_records_used == ctx->profiling_records_capacity) { + ctx->profiling_records_capacity *= 2; + ctx->profiling_records = + realloc(ctx->profiling_records, + ctx->profiling_records_capacity * + sizeof(struct profiling_record)); + } + cudaEvent_t *events = calloc(2, sizeof(cudaEvent_t)); + cudaEventCreate(&events[0]); + cudaEventCreate(&events[1]); + ctx->profiling_records[ctx->profiling_records_used].events = events; + ctx->profiling_records[ctx->profiling_records_used].runs = runs; + ctx->profiling_records[ctx->profiling_records_used].runtime = runtime; + ctx->profiling_records_used++; + return events; +} + +static CUresult cuda_alloc(struct futhark_context *ctx, FILE *log, + size_t min_size, const char *tag, + CUdeviceptr *mem_out, size_t *size_out) { + if (min_size < sizeof(int)) { + min_size = sizeof(int); + } + + if (free_list_find(&ctx->cu_free_list, min_size, tag, size_out, (fl_mem*)mem_out) == 0) { + if (*size_out >= min_size) { + if (ctx->cfg->debugging) { + fprintf(log, "No need to allocate: Found a block in the free list.\n"); + } + return CUDA_SUCCESS; + } else { + if (ctx->cfg->debugging) { + fprintf(log, "Found a free block, but it was too small.\n"); + } + + CUresult res = cuMemFree(*mem_out); + if (res != CUDA_SUCCESS) { + return res; + } + } + } + + *size_out = min_size; + + if (ctx->cfg->debugging) { + fprintf(log, "Actually allocating the desired block.\n"); + } + + CUresult res = cuMemAlloc(mem_out, min_size); + while (res == CUDA_ERROR_OUT_OF_MEMORY) { + CUdeviceptr mem; + if (free_list_first(&ctx->cu_free_list, (fl_mem*)&mem) == 0) { + res = cuMemFree(mem); + if (res != CUDA_SUCCESS) { + return res; + } + } else { + break; + } + res = cuMemAlloc(mem_out, min_size); + } + + return res; +} + +static CUresult cuda_free(struct futhark_context *ctx, + CUdeviceptr mem, size_t size, const char *tag) { + free_list_insert(&ctx->cu_free_list, size, (fl_mem)mem, tag); + return CUDA_SUCCESS; +} + +static CUresult cuda_free_all(struct futhark_context *ctx) { + CUdeviceptr mem; + free_list_pack(&ctx->cu_free_list); + while (free_list_first(&ctx->cu_free_list, (fl_mem*)&mem) == 0) { + CUresult res = cuMemFree(mem); + if (res != CUDA_SUCCESS) { + return res; + } + } + + return CUDA_SUCCESS; +} + +int futhark_context_sync(struct futhark_context* ctx) { + CUDA_SUCCEED_OR_RETURN(cuCtxPushCurrent(ctx->cu_ctx)); + CUDA_SUCCEED_OR_RETURN(cuCtxSynchronize()); + if (ctx->failure_is_an_option) { + // Check for any delayed error. + int32_t failure_idx; + CUDA_SUCCEED_OR_RETURN( + cuMemcpyDtoH(&failure_idx, + ctx->global_failure, + sizeof(int32_t))); + ctx->failure_is_an_option = 0; + + if (failure_idx >= 0) { + // We have to clear global_failure so that the next entry point + // is not considered a failure from the start. + int32_t no_failure = -1; + CUDA_SUCCEED_OR_RETURN( + cuMemcpyHtoD(ctx->global_failure, + &no_failure, + sizeof(int32_t))); + + int64_t args[max_failure_args+1]; + CUDA_SUCCEED_OR_RETURN( + cuMemcpyDtoH(&args, + ctx->global_failure_args, + sizeof(args))); + + ctx->error = get_failure_msg(failure_idx, args); + + return FUTHARK_PROGRAM_ERROR; + } + } + CUDA_SUCCEED_OR_RETURN(cuCtxPopCurrent(&ctx->cu_ctx)); + return 0; +} + +int backend_context_setup(struct futhark_context* ctx) { + ctx->profiling_records_capacity = 200; + ctx->profiling_records_used = 0; + ctx->profiling_records = + malloc(ctx->profiling_records_capacity * + sizeof(struct profiling_record)); + ctx->failure_is_an_option = 0; + ctx->total_runs = 0; + ctx->total_runtime = 0; + ctx->peak_mem_usage_device = 0; + ctx->cur_mem_usage_device = 0; + + ctx->error = cuda_setup(ctx, cuda_program, ctx->cfg->nvrtc_opts, ctx->cfg->cache_fname); + + if (ctx->error != NULL) { + futhark_panic(1, "%s\n", ctx->error); + } + + int32_t no_error = -1; + CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->global_failure, sizeof(no_error))); + CUDA_SUCCEED_FATAL(cuMemcpyHtoD(ctx->global_failure, &no_error, sizeof(no_error))); + // The +1 is to avoid zero-byte allocations. + CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->global_failure_args, sizeof(int64_t)*(max_failure_args+1))); + + set_tuning_params(ctx); + return 0; +} + +void backend_context_teardown(struct futhark_context* ctx) { + cuMemFree(ctx->global_failure); + cuMemFree(ctx->global_failure_args); + CUDA_SUCCEED_FATAL(cuda_free_all(ctx)); + (void)cuda_tally_profiling_records(ctx); + free(ctx->profiling_records); + CUDA_SUCCEED_FATAL(cuModuleUnload(ctx->module)); + CUDA_SUCCEED_FATAL(cuCtxDestroy(ctx->cu_ctx)); +} + +// End of backends/cuda.h. diff --git a/rts/c/backends/multicore.h b/rts/c/backends/multicore.h new file mode 100644 --- /dev/null +++ b/rts/c/backends/multicore.h @@ -0,0 +1,95 @@ +// Start of backends/multicore.h + +struct futhark_context_config { + int in_use; + int debugging; + int profiling; + int logging; + const char *cache_fname; + int num_tuning_params; + int64_t *tuning_params; + const char** tuning_param_names; + const char** tuning_param_vars; + const char** tuning_param_classes; + // Uniform fields above. + + int num_threads; +}; + +static void backend_context_config_setup(struct futhark_context_config* cfg) { + cfg->num_threads = 0; +} + +static void backend_context_config_teardown(struct futhark_context_config* cfg) { + (void)cfg; +} + +void futhark_context_config_set_num_threads(struct futhark_context_config *cfg, int n) { + cfg->num_threads = n; +} + +int futhark_context_config_set_tuning_param(struct futhark_context_config* cfg, const char *param_name, size_t param_value) { + (void)cfg; (void)param_name; (void)param_value; + return 1; +} + +struct futhark_context { + struct futhark_context_config* cfg; + int detail_memory; + int debugging; + int profiling; + int profiling_paused; + int logging; + lock_t lock; + char *error; + lock_t error_lock; + FILE *log; + struct constants *constants; + struct free_list free_list; + int64_t peak_mem_usage_default; + int64_t cur_mem_usage_default; + struct program* program; + // Uniform fields above. + + struct scheduler scheduler; + int total_runs; + long int total_runtime; + int64_t tuning_timing; + int64_t tuning_iter; +}; + +int backend_context_setup(struct futhark_context* ctx) { + // Initialize rand() + fast_srand(time(0)); + + int tune_kappa = 0; + double kappa = 5.1f * 1000; + + if (tune_kappa) { + if (determine_kappa(&kappa) != 0) { + ctx->error = strdup("Failed to determine kappa."); + return 1; + } + } + + if (scheduler_init(&ctx->scheduler, + ctx->cfg->num_threads > 0 ? + ctx->cfg->num_threads : num_processors(), + kappa) != 0) { + ctx->error = strdup("Failed to initialise scheduler."); + return 1; + } + + return 0; +} + +void backend_context_teardown(struct futhark_context* ctx) { + (void)scheduler_destroy(&ctx->scheduler); +} + +int futhark_context_sync(struct futhark_context* ctx) { + (void)ctx; + return 0; +} + +// End of backends/multicore.h diff --git a/rts/c/backends/opencl.h b/rts/c/backends/opencl.h new file mode 100644 --- /dev/null +++ b/rts/c/backends/opencl.h @@ -0,0 +1,1232 @@ +// Start of backends/opencl.h + +// Forward declarations. +struct opencl_device_option; +// Invoked by setup_opencl() after the platform and device has been +// found, but before the program is loaded. Its intended use is to +// tune constants based on the selected platform and device. +static void post_opencl_setup(struct futhark_context*, struct opencl_device_option*); +static void set_tuning_params(struct futhark_context* ctx); +static char* get_failure_msg(int failure_idx, int64_t args[]); + +#define OPENCL_SUCCEED_FATAL(e) opencl_succeed_fatal(e, #e, __FILE__, __LINE__) +#define OPENCL_SUCCEED_NONFATAL(e) opencl_succeed_nonfatal(e, #e, __FILE__, __LINE__) +// Take care not to override an existing error. +#define OPENCL_SUCCEED_OR_RETURN(e) { \ + char *serror = OPENCL_SUCCEED_NONFATAL(e); \ + if (serror) { \ + if (!ctx->error) { \ + ctx->error = serror; \ + return bad; \ + } else { \ + free(serror); \ + } \ + } \ + } + +// OPENCL_SUCCEED_OR_RETURN returns the value of the variable 'bad' in +// scope. By default, it will be this one. Create a local variable +// of some other type if needed. This is a bit of a hack, but it +// saves effort in the code generator. +static const int bad = 1; + +static const char* opencl_error_string(cl_int err) { + switch (err) { + case CL_SUCCESS: return "Success!"; + case CL_DEVICE_NOT_FOUND: return "Device not found."; + case CL_DEVICE_NOT_AVAILABLE: return "Device not available"; + case CL_COMPILER_NOT_AVAILABLE: return "Compiler not available"; + case CL_MEM_OBJECT_ALLOCATION_FAILURE: return "Memory object allocation failure"; + case CL_OUT_OF_RESOURCES: return "Out of resources"; + case CL_OUT_OF_HOST_MEMORY: return "Out of host memory"; + case CL_PROFILING_INFO_NOT_AVAILABLE: return "Profiling information not available"; + case CL_MEM_COPY_OVERLAP: return "Memory copy overlap"; + case CL_IMAGE_FORMAT_MISMATCH: return "Image format mismatch"; + case CL_IMAGE_FORMAT_NOT_SUPPORTED: return "Image format not supported"; + case CL_BUILD_PROGRAM_FAILURE: return "Program build failure"; + case CL_MAP_FAILURE: return "Map failure"; + case CL_INVALID_VALUE: return "Invalid value"; + case CL_INVALID_DEVICE_TYPE: return "Invalid device type"; + case CL_INVALID_PLATFORM: return "Invalid platform"; + case CL_INVALID_DEVICE: return "Invalid device"; + case CL_INVALID_CONTEXT: return "Invalid context"; + case CL_INVALID_QUEUE_PROPERTIES: return "Invalid queue properties"; + case CL_INVALID_COMMAND_QUEUE: return "Invalid command queue"; + case CL_INVALID_HOST_PTR: return "Invalid host pointer"; + case CL_INVALID_MEM_OBJECT: return "Invalid memory object"; + case CL_INVALID_IMAGE_FORMAT_DESCRIPTOR: return "Invalid image format descriptor"; + case CL_INVALID_IMAGE_SIZE: return "Invalid image size"; + case CL_INVALID_SAMPLER: return "Invalid sampler"; + case CL_INVALID_BINARY: return "Invalid binary"; + case CL_INVALID_BUILD_OPTIONS: return "Invalid build options"; + case CL_INVALID_PROGRAM: return "Invalid program"; + case CL_INVALID_PROGRAM_EXECUTABLE: return "Invalid program executable"; + case CL_INVALID_KERNEL_NAME: return "Invalid kernel name"; + case CL_INVALID_KERNEL_DEFINITION: return "Invalid kernel definition"; + case CL_INVALID_KERNEL: return "Invalid kernel"; + case CL_INVALID_ARG_INDEX: return "Invalid argument index"; + case CL_INVALID_ARG_VALUE: return "Invalid argument value"; + case CL_INVALID_ARG_SIZE: return "Invalid argument size"; + case CL_INVALID_KERNEL_ARGS: return "Invalid kernel arguments"; + case CL_INVALID_WORK_DIMENSION: return "Invalid work dimension"; + case CL_INVALID_WORK_GROUP_SIZE: return "Invalid work group size"; + case CL_INVALID_WORK_ITEM_SIZE: return "Invalid work item size"; + case CL_INVALID_GLOBAL_OFFSET: return "Invalid global offset"; + case CL_INVALID_EVENT_WAIT_LIST: return "Invalid event wait list"; + case CL_INVALID_EVENT: return "Invalid event"; + case CL_INVALID_OPERATION: return "Invalid operation"; + case CL_INVALID_GL_OBJECT: return "Invalid OpenGL object"; + case CL_INVALID_BUFFER_SIZE: return "Invalid buffer size"; + case CL_INVALID_MIP_LEVEL: return "Invalid mip-map level"; + default: return "Unknown"; + } +} + +static void opencl_succeed_fatal(cl_int ret, + const char *call, + const char *file, + int line) { + if (ret != CL_SUCCESS) { + futhark_panic(-1, "%s:%d: OpenCL call\n %s\nfailed with error code %d (%s)\n", + file, line, call, ret, opencl_error_string(ret)); + } +} + +static char* opencl_succeed_nonfatal(cl_int ret, + const char *call, + const char *file, + int line) { + if (ret != CL_SUCCESS) { + return msgprintf("%s:%d: OpenCL call\n %s\nfailed with error code %d (%s)\n", + file, line, call, ret, opencl_error_string(ret)); + } else { + return NULL; + } +} + +struct futhark_context_config { + int in_use; + int debugging; + int profiling; + int logging; + const char *cache_fname; + int num_tuning_params; + int64_t *tuning_params; + const char** tuning_param_names; + const char** tuning_param_vars; + const char** tuning_param_classes; + // Uniform fields above. + + int preferred_device_num; + const char *preferred_platform; + const char *preferred_device; + int ignore_blacklist; + + const char* dump_program_to; + const char* load_program_from; + const char* dump_binary_to; + const char* load_binary_from; + + size_t default_group_size; + size_t default_num_groups; + size_t default_tile_size; + size_t default_reg_tile_size; + size_t default_threshold; + + int default_group_size_changed; + int default_tile_size_changed; + int num_build_opts; + const char **build_opts; + + cl_command_queue queue; + int queue_set; +}; + +static void backend_context_config_setup(struct futhark_context_config* cfg) { + cfg->num_build_opts = 0; + cfg->build_opts = (const char**) malloc(sizeof(const char*)); + cfg->build_opts[0] = NULL; + cfg->preferred_device_num = 0; + cfg->preferred_platform = ""; + cfg->preferred_device = ""; + cfg->ignore_blacklist = 0; + cfg->dump_program_to = NULL; + cfg->load_program_from = NULL; + cfg->dump_binary_to = NULL; + cfg->load_binary_from = NULL; + + // The following are dummy sizes that mean the concrete defaults + // will be set during initialisation via hardware-inspection-based + // heuristics. + cfg->default_group_size = 0; + cfg->default_num_groups = 0; + cfg->default_tile_size = 0; + cfg->default_reg_tile_size = 0; + cfg->default_threshold = 0; + + cfg->default_group_size_changed = 0; + cfg->default_tile_size_changed = 0; + + cfg->queue_set = 0; +} + +static void backend_context_config_teardown(struct futhark_context_config* cfg) { + free(cfg->build_opts); +} + +void futhark_context_config_add_build_option(struct futhark_context_config* cfg, const char *opt) { + cfg->build_opts[cfg->num_build_opts] = opt; + cfg->num_build_opts++; + cfg->build_opts = (const char**) realloc(cfg->build_opts, (cfg->num_build_opts+1) * sizeof(const char*)); + cfg->build_opts[cfg->num_build_opts] = NULL; +} + +void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s) { + int x = 0; + if (*s == '#') { + s++; + while (isdigit(*s)) { + x = x * 10 + (*s++)-'0'; + } + // Skip trailing spaces. + while (isspace(*s)) { + s++; + } + } + cfg->preferred_device = s; + cfg->preferred_device_num = x; + cfg->ignore_blacklist = 1; +} + +void futhark_context_config_set_platform(struct futhark_context_config *cfg, const char *s) { + cfg->preferred_platform = s; + cfg->ignore_blacklist = 1; +} + +void futhark_context_config_set_command_queue(struct futhark_context_config *cfg, cl_command_queue q) { + cfg->queue = q; + cfg->queue_set = 1; +} + +struct opencl_device_option { + cl_platform_id platform; + cl_device_id device; + cl_device_type device_type; + char *platform_name; + char *device_name; +}; + +static char* opencl_platform_info(cl_platform_id platform, + cl_platform_info param) { + size_t req_bytes; + char *info; + + OPENCL_SUCCEED_FATAL(clGetPlatformInfo(platform, param, 0, NULL, &req_bytes)); + + info = (char*) malloc(req_bytes); + + OPENCL_SUCCEED_FATAL(clGetPlatformInfo(platform, param, req_bytes, info, NULL)); + + return info; +} + +static char* opencl_device_info(cl_device_id device, + cl_device_info param) { + size_t req_bytes; + char *info; + + OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device, param, 0, NULL, &req_bytes)); + + info = (char*) malloc(req_bytes); + + OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device, param, req_bytes, info, NULL)); + + return info; +} + +static int is_blacklisted(const char *platform_name, const char *device_name, + const struct futhark_context_config *cfg) { + if (strcmp(cfg->preferred_platform, "") != 0 || + strcmp(cfg->preferred_device, "") != 0) { + return 0; + } else if (strstr(platform_name, "Apple") != NULL && + strstr(device_name, "Intel(R) Core(TM)") != NULL) { + return 1; + } else { + return 0; + } +} + +static void opencl_all_device_options(struct opencl_device_option **devices_out, + size_t *num_devices_out) { + size_t num_devices = 0, num_devices_added = 0; + + cl_platform_id *all_platforms; + cl_uint *platform_num_devices; + + cl_uint num_platforms; + + // Find the number of platforms. + OPENCL_SUCCEED_FATAL(clGetPlatformIDs(0, NULL, &num_platforms)); + + // Make room for them. + all_platforms = calloc(num_platforms, sizeof(cl_platform_id)); + platform_num_devices = calloc(num_platforms, sizeof(cl_uint)); + + // Fetch all the platforms. + OPENCL_SUCCEED_FATAL(clGetPlatformIDs(num_platforms, all_platforms, NULL)); + + // Count the number of devices for each platform, as well as the + // total number of devices. + for (cl_uint i = 0; i < num_platforms; i++) { + if (clGetDeviceIDs(all_platforms[i], CL_DEVICE_TYPE_ALL, + 0, NULL, &platform_num_devices[i]) == CL_SUCCESS) { + num_devices += platform_num_devices[i]; + } else { + platform_num_devices[i] = 0; + } + } + + // Make room for all the device options. + struct opencl_device_option *devices = + calloc(num_devices, sizeof(struct opencl_device_option)); + + // Loop through the platforms, getting information about their devices. + for (cl_uint i = 0; i < num_platforms; i++) { + cl_platform_id platform = all_platforms[i]; + cl_uint num_platform_devices = platform_num_devices[i]; + + if (num_platform_devices == 0) { + continue; + } + + char *platform_name = opencl_platform_info(platform, CL_PLATFORM_NAME); + cl_device_id *platform_devices = + calloc(num_platform_devices, sizeof(cl_device_id)); + + // Fetch all the devices. + OPENCL_SUCCEED_FATAL(clGetDeviceIDs(platform, CL_DEVICE_TYPE_ALL, + num_platform_devices, platform_devices, NULL)); + + // Loop through the devices, adding them to the devices array. + for (cl_uint i = 0; i < num_platform_devices; i++) { + char *device_name = opencl_device_info(platform_devices[i], CL_DEVICE_NAME); + devices[num_devices_added].platform = platform; + devices[num_devices_added].device = platform_devices[i]; + OPENCL_SUCCEED_FATAL(clGetDeviceInfo(platform_devices[i], CL_DEVICE_TYPE, + sizeof(cl_device_type), + &devices[num_devices_added].device_type, + NULL)); + // We don't want the structs to share memory, so copy the platform name. + // Each device name is already unique. + devices[num_devices_added].platform_name = strclone(platform_name); + devices[num_devices_added].device_name = device_name; + num_devices_added++; + } + free(platform_devices); + free(platform_name); + } + free(all_platforms); + free(platform_num_devices); + + *devices_out = devices; + *num_devices_out = num_devices; +} + +void futhark_context_config_select_device_interactively(struct futhark_context_config *cfg) { + struct opencl_device_option *devices; + size_t num_devices; + + opencl_all_device_options(&devices, &num_devices); + + printf("Choose OpenCL device:\n"); + const char *cur_platform = ""; + for (size_t i = 0; i < num_devices; i++) { + struct opencl_device_option device = devices[i]; + if (strcmp(cur_platform, device.platform_name) != 0) { + printf("Platform: %s\n", device.platform_name); + cur_platform = device.platform_name; + } + printf("[%d] %s\n", (int)i, device.device_name); + } + + int selection; + printf("Choice: "); + if (scanf("%d", &selection) == 1) { + cfg->preferred_platform = ""; + cfg->preferred_device = ""; + cfg->preferred_device_num = selection; + cfg->ignore_blacklist = 1; + } + + // Free all the platform and device names. + for (size_t j = 0; j < num_devices; j++) { + free(devices[j].platform_name); + free(devices[j].device_name); + } + free(devices); +} + +void futhark_context_config_list_devices(struct futhark_context_config *cfg) { + (void)cfg; + struct opencl_device_option *devices; + size_t num_devices; + + opencl_all_device_options(&devices, &num_devices); + + const char *cur_platform = ""; + for (size_t i = 0; i < num_devices; i++) { + struct opencl_device_option device = devices[i]; + if (strcmp(cur_platform, device.platform_name) != 0) { + printf("Platform: %s\n", device.platform_name); + cur_platform = device.platform_name; + } + printf("[%d]: %s\n", (int)i, device.device_name); + } + + // Free all the platform and device names. + for (size_t j = 0; j < num_devices; j++) { + free(devices[j].platform_name); + free(devices[j].device_name); + } + free(devices); +} + +void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path) { + cfg->dump_program_to = path; +} + +void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path) { + cfg->load_program_from = path; +} + +void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char *path) { + cfg->dump_binary_to = path; +} + +void futhark_context_config_load_binary_from(struct futhark_context_config *cfg, const char *path) { + cfg->load_binary_from = path; +} + +void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size) { + cfg->default_group_size = size; + cfg->default_group_size_changed = 1; +} + +void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int num) { + cfg->default_num_groups = num; +} + +void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size) { + cfg->default_tile_size = size; + cfg->default_tile_size_changed = 1; +} + +void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size) { + cfg->default_reg_tile_size = size; +} + +void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size) { + cfg->default_threshold = size; +} + +int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg, + const char *param_name, + size_t new_value) { + for (int i = 0; i < cfg->num_tuning_params; i++) { + if (strcmp(param_name, cfg->tuning_param_names[i]) == 0) { + cfg->tuning_params[i] = new_value; + return 0; + } + } + if (strcmp(param_name, "default_group_size") == 0) { + cfg->default_group_size = new_value; + return 0; + } + if (strcmp(param_name, "default_num_groups") == 0) { + cfg->default_num_groups = new_value; + return 0; + } + if (strcmp(param_name, "default_threshold") == 0) { + cfg->default_threshold = new_value; + return 0; + } + if (strcmp(param_name, "default_tile_size") == 0) { + cfg->default_tile_size = new_value; + return 0; + } + if (strcmp(param_name, "default_reg_tile_size") == 0) { + cfg->default_reg_tile_size = new_value; + return 0; + } + return 1; +} + +// A record of something that happened. +struct profiling_record { + cl_event *event; + int *runs; + int64_t *runtime; +}; + +struct futhark_context { + struct futhark_context_config* cfg; + int detail_memory; + int debugging; + int profiling; + int profiling_paused; + int logging; + lock_t lock; + char *error; + lock_t error_lock; + FILE *log; + struct constants *constants; + struct free_list free_list; + int64_t peak_mem_usage_default; + int64_t cur_mem_usage_default; + struct program* program; + + // Common fields above. + + cl_mem global_failure; + cl_mem global_failure_args; + struct tuning_params tuning_params; + // True if a potentially failing kernel has been enqueued. + cl_int failure_is_an_option; + int total_runs; + long int total_runtime; + int64_t peak_mem_usage_device; + int64_t cur_mem_usage_device; + + cl_device_id device; + cl_context ctx; + cl_command_queue queue; + cl_program clprogram; + + struct free_list cl_free_list; + + size_t max_group_size; + size_t max_num_groups; + size_t max_tile_size; + size_t max_threshold; + size_t max_local_memory; + + size_t lockstep_width; + + struct profiling_record *profiling_records; + int profiling_records_capacity; + int profiling_records_used; + +}; + +static cl_build_status build_opencl_program(cl_program program, cl_device_id device, const char* options) { + cl_int clBuildProgram_error = clBuildProgram(program, 1, &device, options, NULL, NULL); + + // Avoid termination due to CL_BUILD_PROGRAM_FAILURE + if (clBuildProgram_error != CL_SUCCESS && + clBuildProgram_error != CL_BUILD_PROGRAM_FAILURE) { + OPENCL_SUCCEED_FATAL(clBuildProgram_error); + } + + cl_build_status build_status; + OPENCL_SUCCEED_FATAL(clGetProgramBuildInfo(program, + device, + CL_PROGRAM_BUILD_STATUS, + sizeof(cl_build_status), + &build_status, + NULL)); + + if (build_status != CL_SUCCESS) { + char *build_log; + size_t ret_val_size; + OPENCL_SUCCEED_FATAL(clGetProgramBuildInfo(program, device, CL_PROGRAM_BUILD_LOG, 0, NULL, &ret_val_size)); + + build_log = (char*) malloc(ret_val_size+1); + OPENCL_SUCCEED_FATAL(clGetProgramBuildInfo(program, device, CL_PROGRAM_BUILD_LOG, ret_val_size, build_log, NULL)); + + // The spec technically does not say whether the build log is zero-terminated, so let's be careful. + build_log[ret_val_size] = '\0'; + + fprintf(stderr, "Build log:\n%s\n", build_log); + + free(build_log); + } + + return build_status; +} + +static char* mk_compile_opts(struct futhark_context *ctx, + const char *extra_build_opts[], + struct opencl_device_option device_option) { + int compile_opts_size = 1024; + + for (int i = 0; i < ctx->cfg->num_tuning_params; i++) { + compile_opts_size += strlen(ctx->cfg->tuning_param_names[i]) + 20; + } + + for (int i = 0; extra_build_opts[i] != NULL; i++) { + compile_opts_size += strlen(extra_build_opts[i] + 1); + } + + char *compile_opts = (char*) malloc(compile_opts_size); + + int w = snprintf(compile_opts, compile_opts_size, + "-DLOCKSTEP_WIDTH=%d ", + (int)ctx->lockstep_width); + + w += snprintf(compile_opts+w, compile_opts_size-w, + "-D%s=%d ", + "max_group_size", + (int)ctx->max_group_size); + + for (int i = 0; i < ctx->cfg->num_tuning_params; i++) { + w += snprintf(compile_opts+w, compile_opts_size-w, + "-D%s=%d ", + ctx->cfg->tuning_param_vars[i], + (int)ctx->cfg->tuning_params[i]); + } + + for (int i = 0; extra_build_opts[i] != NULL; i++) { + w += snprintf(compile_opts+w, compile_opts_size-w, + "%s ", extra_build_opts[i]); + } + + // Oclgrind claims to support cl_khr_fp16, but this is not actually + // the case. + if (strcmp(device_option.platform_name, "Oclgrind") == 0) { + w += snprintf(compile_opts+w, compile_opts_size-w, "-DEMULATE_F16 "); + } + + return compile_opts; +} + +// Count up the runtime all the profiling_records that occured during execution. +// Also clears the buffer of profiling_records. +static cl_int opencl_tally_profiling_records(struct futhark_context *ctx) { + cl_int err; + for (int i = 0; i < ctx->profiling_records_used; i++) { + struct profiling_record record = ctx->profiling_records[i]; + + cl_ulong start_t, end_t; + + if ((err = clGetEventProfilingInfo(*record.event, + CL_PROFILING_COMMAND_START, + sizeof(start_t), + &start_t, + NULL)) != CL_SUCCESS) { + return err; + } + + if ((err = clGetEventProfilingInfo(*record.event, + CL_PROFILING_COMMAND_END, + sizeof(end_t), + &end_t, + NULL)) != CL_SUCCESS) { + return err; + } + + // OpenCL provides nanosecond resolution, but we want + // microseconds. + *record.runs += 1; + *record.runtime += (end_t - start_t)/1000; + + if ((err = clReleaseEvent(*record.event)) != CL_SUCCESS) { + return err; + } + free(record.event); + } + + ctx->profiling_records_used = 0; + + return CL_SUCCESS; +} + +// If profiling, produce an event associated with a profiling record. +static cl_event* opencl_get_event(struct futhark_context *ctx, int *runs, int64_t *runtime) { + if (ctx->profiling_records_used == ctx->profiling_records_capacity) { + ctx->profiling_records_capacity *= 2; + ctx->profiling_records = + realloc(ctx->profiling_records, + ctx->profiling_records_capacity * + sizeof(struct profiling_record)); + } + cl_event *event = malloc(sizeof(cl_event)); + ctx->profiling_records[ctx->profiling_records_used].event = event; + ctx->profiling_records[ctx->profiling_records_used].runs = runs; + ctx->profiling_records[ctx->profiling_records_used].runtime = runtime; + ctx->profiling_records_used++; + return event; +} + +// Allocate memory from driver. The problem is that OpenCL may perform +// lazy allocation, so we cannot know whether an allocation succeeded +// until the first time we try to use it. Hence we immediately +// perform a write to see if the allocation succeeded. This is slow, +// but the assumption is that this operation will be rare (most things +// will go through the free list). +static int opencl_alloc_actual(struct futhark_context *ctx, size_t size, cl_mem *mem_out) { + int error; + *mem_out = clCreateBuffer(ctx->ctx, CL_MEM_READ_WRITE, size, NULL, &error); + + if (error != CL_SUCCESS) { + return error; + } + + int x = 2; + error = clEnqueueWriteBuffer(ctx->queue, *mem_out, + CL_TRUE, + 0, sizeof(x), &x, + 0, NULL, NULL); + + // No need to wait for completion here. clWaitForEvents() cannot + // return mem object allocation failures. This implies that the + // buffer is faulted onto the device on enqueue. (Observation by + // Andreas Kloeckner.) + + return error; +} + +static int opencl_alloc(struct futhark_context *ctx, FILE *log, + size_t min_size, const char *tag, + cl_mem *mem_out, size_t *size_out) { + (void)tag; + if (min_size < sizeof(int)) { + min_size = sizeof(int); + } + + cl_mem* memptr; + if (free_list_find(&ctx->cl_free_list, min_size, tag, size_out, (fl_mem*)&memptr) == 0) { + // Successfully found a free block. Is it big enough? + if (*size_out >= min_size) { + if (ctx->cfg->debugging) { + fprintf(log, "No need to allocate: Found a block in the free list.\n"); + } + *mem_out = *memptr; + free(memptr); + return CL_SUCCESS; + } else { + if (ctx->cfg->debugging) { + fprintf(log, "Found a free block, but it was too small.\n"); + } + int error = clReleaseMemObject(*memptr); + free(*memptr); + if (error != CL_SUCCESS) { + return error; + } + } + } + + *size_out = min_size; + + // We have to allocate a new block from the driver. If the + // allocation does not succeed, then we might be in an out-of-memory + // situation. We now start freeing things from the free list until + // we think we have freed enough that the allocation will succeed. + // Since we don't know how far the allocation is from fitting, we + // have to check after every deallocation. This might be pretty + // expensive. Let's hope that this case is hit rarely. + + if (ctx->cfg->debugging) { + fprintf(log, "Actually allocating the desired block.\n"); + } + + int error = opencl_alloc_actual(ctx, min_size, mem_out); + + while (error == CL_MEM_OBJECT_ALLOCATION_FAILURE) { + if (ctx->cfg->debugging) { + fprintf(log, "Out of OpenCL memory: releasing entry from the free list...\n"); + } + cl_mem* memptr; + if (free_list_first(&ctx->cl_free_list, (fl_mem*)&memptr) == 0) { + cl_mem mem = *memptr; + free(memptr); + error = clReleaseMemObject(mem); + if (error != CL_SUCCESS) { + return error; + } + } else { + break; + } + error = opencl_alloc_actual(ctx, min_size, mem_out); + } + + return error; +} + +static int opencl_free(struct futhark_context *ctx, + cl_mem mem, size_t size, const char *tag) { + cl_mem* memptr = malloc(sizeof(cl_mem)); + *memptr = mem; + free_list_insert(&ctx->cl_free_list, size, (fl_mem)memptr, tag); + return CL_SUCCESS; +} + +static int opencl_free_all(struct futhark_context *ctx) { + free_list_pack(&ctx->cl_free_list); + cl_mem* memptr; + while (free_list_first(&ctx->cl_free_list, (fl_mem*)&memptr) == 0) { + cl_mem mem = *memptr; + free(memptr); + int error = clReleaseMemObject(mem); + if (error != CL_SUCCESS) { + return error; + } + } + + return CL_SUCCESS; +} + +int futhark_context_sync(struct futhark_context* ctx) { + // Check for any delayed error. + cl_int failure_idx = -1; + if (ctx->failure_is_an_option) { + OPENCL_SUCCEED_OR_RETURN( + clEnqueueReadBuffer(ctx->queue, + ctx->global_failure, + CL_FALSE, + 0, sizeof(cl_int), &failure_idx, + 0, NULL, NULL)); + ctx->failure_is_an_option = 0; + } + + OPENCL_SUCCEED_OR_RETURN(clFinish(ctx->queue)); + + if (failure_idx >= 0) { + // We have to clear global_failure so that the next entry point + // is not considered a failure from the start. + cl_int no_failure = -1; + OPENCL_SUCCEED_OR_RETURN( + clEnqueueWriteBuffer(ctx->queue, ctx->global_failure, CL_TRUE, + 0, sizeof(cl_int), &no_failure, + 0, NULL, NULL)); + + int64_t args[max_failure_args+1]; + OPENCL_SUCCEED_OR_RETURN( + clEnqueueReadBuffer(ctx->queue, + ctx->global_failure_args, + CL_TRUE, + 0, sizeof(args), &args, + 0, NULL, NULL)); + + ctx->error = get_failure_msg(failure_idx, args); + + return FUTHARK_PROGRAM_ERROR; + } + return 0; +} + + +// We take as input several strings representing the program, because +// C does not guarantee that the compiler supports particularly large +// literals. Notably, Visual C has a limit of 2048 characters. The +// array must be NULL-terminated. +static void setup_opencl_with_command_queue(struct futhark_context *ctx, + cl_command_queue queue, + const char *srcs[], + const char *extra_build_opts[], + const char* cache_fname) { + int error; + + free_list_init(&ctx->cl_free_list); + ctx->queue = queue; + + OPENCL_SUCCEED_FATAL(clGetCommandQueueInfo(ctx->queue, CL_QUEUE_CONTEXT, sizeof(cl_context), &ctx->ctx, NULL)); + + // Fill out the device info. This is redundant work if we are + // called from setup_opencl() (which is the common case), but I + // doubt it matters much. + struct opencl_device_option device_option; + OPENCL_SUCCEED_FATAL(clGetCommandQueueInfo(ctx->queue, CL_QUEUE_DEVICE, + sizeof(cl_device_id), + &device_option.device, + NULL)); + OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_PLATFORM, + sizeof(cl_platform_id), + &device_option.platform, + NULL)); + OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_TYPE, + sizeof(cl_device_type), + &device_option.device_type, + NULL)); + device_option.platform_name = opencl_platform_info(device_option.platform, CL_PLATFORM_NAME); + device_option.device_name = opencl_device_info(device_option.device, CL_DEVICE_NAME); + + ctx->device = device_option.device; + + if (f64_required) { + cl_uint supported; + OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE, + sizeof(cl_uint), &supported, NULL)); + if (!supported) { + futhark_panic(1, "Program uses double-precision floats, but this is not supported on the chosen device: %s\n", + device_option.device_name); + } + } + + size_t max_group_size; + OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_MAX_WORK_GROUP_SIZE, + sizeof(size_t), &max_group_size, NULL)); + + size_t max_tile_size = sqrt(max_group_size); + + cl_ulong max_local_memory; + OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_LOCAL_MEM_SIZE, + sizeof(size_t), &max_local_memory, NULL)); + + // Futhark reserves 4 bytes for bookkeeping information. + max_local_memory -= 4; + + // The OpenCL implementation may reserve some local memory bytes for + // various purposes. In principle, we should use + // clGetKernelWorkGroupInfo() to figure out for each kernel how much + // is actually available, but our current code generator design + // makes this infeasible. Instead, we have this nasty hack where we + // arbitrarily subtract some bytes, based on empirical measurements + // (but which might be arbitrarily wrong). Fortunately, we rarely + // try to really push the local memory usage. + if (strstr(device_option.platform_name, "NVIDIA CUDA") != NULL) { + max_local_memory -= 12; + } else if (strstr(device_option.platform_name, "AMD") != NULL) { + max_local_memory -= 16; + } + + // Make sure this function is defined. + post_opencl_setup(ctx, &device_option); + + if (max_group_size < ctx->cfg->default_group_size) { + if (ctx->cfg->default_group_size_changed) { + fprintf(stderr, "Note: Device limits default group size to %zu (down from %zu).\n", + max_group_size, ctx->cfg->default_group_size); + } + ctx->cfg->default_group_size = max_group_size; + } + + if (max_tile_size < ctx->cfg->default_tile_size) { + if (ctx->cfg->default_tile_size_changed) { + fprintf(stderr, "Note: Device limits default tile size to %zu (down from %zu).\n", + max_tile_size, ctx->cfg->default_tile_size); + } + ctx->cfg->default_tile_size = max_tile_size; + } + + ctx->max_group_size = max_group_size; + ctx->max_tile_size = max_tile_size; // No limit. + ctx->max_threshold = ctx->max_num_groups = 0; // No limit. + ctx->max_local_memory = max_local_memory; + + // Now we go through all the sizes, clamp them to the valid range, + // or set them to the default. + for (int i = 0; i < ctx->cfg->num_tuning_params; i++) { + const char *size_class = ctx->cfg->tuning_param_classes[i]; + int64_t *size_value = &ctx->cfg->tuning_params[i]; + const char* size_name = ctx->cfg->tuning_param_names[i]; + int64_t max_value = 0, default_value = 0; + + if (strstr(size_class, "group_size") == size_class) { + max_value = max_group_size; + default_value = ctx->cfg->default_group_size; + } else if (strstr(size_class, "num_groups") == size_class) { + max_value = max_group_size; // Futhark assumes this constraint. + default_value = ctx->cfg->default_num_groups; + // XXX: as a quick and dirty hack, use twice as many threads for + // histograms by default. We really should just be smarter + // about sizes somehow. + if (strstr(size_name, ".seghist_") != NULL) { + default_value *= 2; + } + } else if (strstr(size_class, "tile_size") == size_class) { + max_value = sqrt(max_group_size); + default_value = ctx->cfg->default_tile_size; + } else if (strstr(size_class, "reg_tile_size") == size_class) { + max_value = 0; // No limit. + default_value = ctx->cfg->default_reg_tile_size; + } else if (strstr(size_class, "threshold") == size_class) { + // Threshold can be as large as it takes. + default_value = ctx->cfg->default_threshold; + } else { + // Bespoke sizes have no limit or default. + } + if (*size_value == 0) { + *size_value = default_value; + } else if (max_value > 0 && *size_value > max_value) { + fprintf(stderr, "Note: Device limits %s to %d (down from %d)\n", + size_name, (int)max_value, (int)*size_value); + *size_value = max_value; + } + } + + if (ctx->lockstep_width == 0) { + ctx->lockstep_width = 1; + } + + if (ctx->cfg->logging) { + fprintf(stderr, "Lockstep width: %d\n", (int)ctx->lockstep_width); + fprintf(stderr, "Default group size: %d\n", (int)ctx->cfg->default_group_size); + fprintf(stderr, "Default number of groups: %d\n", (int)ctx->cfg->default_num_groups); + } + + char *compile_opts = mk_compile_opts(ctx, extra_build_opts, device_option); + + if (ctx->cfg->logging) { + fprintf(stderr, "OpenCL compiler options: %s\n", compile_opts); + } + + char *fut_opencl_src = NULL; + cl_program prog; + error = CL_SUCCESS; + + struct cache_hash h; + + int loaded_from_cache = 0; + if (ctx->cfg->load_binary_from == NULL) { + size_t src_size = 0; + + // Maybe we have to read OpenCL source from somewhere else (used for debugging). + if (ctx->cfg->load_program_from != NULL) { + fut_opencl_src = slurp_file(ctx->cfg->load_program_from, NULL); + assert(fut_opencl_src != NULL); + } else { + // Construct the OpenCL source concatenating all the fragments. + for (const char **src = srcs; src && *src; src++) { + src_size += strlen(*src); + } + + fut_opencl_src = (char*) malloc(src_size + 1); + + size_t n, i; + for (i = 0, n = 0; srcs && srcs[i]; i++) { + strncpy(fut_opencl_src+n, srcs[i], src_size-n); + n += strlen(srcs[i]); + } + fut_opencl_src[src_size] = 0; + } + + if (ctx->cfg->dump_program_to != NULL) { + if (ctx->cfg->logging) { + fprintf(stderr, "Dumping OpenCL source to %s...\n", ctx->cfg->dump_program_to); + } + + dump_file(ctx->cfg->dump_program_to, fut_opencl_src, strlen(fut_opencl_src)); + } + + if (cache_fname != NULL) { + if (ctx->cfg->logging) { + fprintf(stderr, "Restoring cache from from %s...\n", cache_fname); + } + cache_hash_init(&h); + cache_hash(&h, fut_opencl_src, strlen(fut_opencl_src)); + cache_hash(&h, compile_opts, strlen(compile_opts)); + + unsigned char *buf; + size_t bufsize; + errno = 0; + if (cache_restore(cache_fname, &h, &buf, &bufsize) != 0) { + if (ctx->cfg->logging) { + fprintf(stderr, "Failed to restore cache (errno: %s)\n", strerror(errno)); + } + } else { + if (ctx->cfg->logging) { + fprintf(stderr, "Cache restored; loading OpenCL binary...\n"); + } + + cl_int status = 0; + prog = clCreateProgramWithBinary(ctx->ctx, 1, &device_option.device, + &bufsize, (const unsigned char**)&buf, + &status, &error); + if (status == CL_SUCCESS) { + loaded_from_cache = 1; + if (ctx->cfg->logging) { + fprintf(stderr, "Loading succeeded.\n"); + } + } else { + if (ctx->cfg->logging) { + fprintf(stderr, "Loading failed.\n"); + } + } + } + } + + if (!loaded_from_cache) { + if (ctx->cfg->logging) { + fprintf(stderr, "Creating OpenCL program...\n"); + } + + const char* src_ptr[] = {fut_opencl_src}; + prog = clCreateProgramWithSource(ctx->ctx, 1, src_ptr, &src_size, &error); + OPENCL_SUCCEED_FATAL(error); + } + } else { + if (ctx->cfg->logging) { + fprintf(stderr, "Loading OpenCL binary from %s...\n", ctx->cfg->load_binary_from); + } + size_t binary_size; + unsigned char *fut_opencl_bin = + (unsigned char*) slurp_file(ctx->cfg->load_binary_from, &binary_size); + assert(fut_opencl_bin != NULL); + const unsigned char *binaries[1] = { fut_opencl_bin }; + cl_int status = 0; + + prog = clCreateProgramWithBinary(ctx->ctx, 1, &device_option.device, + &binary_size, binaries, + &status, &error); + + OPENCL_SUCCEED_FATAL(status); + OPENCL_SUCCEED_FATAL(error); + } + + if (ctx->cfg->logging) { + fprintf(stderr, "Building OpenCL program...\n"); + } + OPENCL_SUCCEED_FATAL(build_opencl_program(prog, device_option.device, compile_opts)); + + free(compile_opts); + free(fut_opencl_src); + + size_t binary_size = 0; + unsigned char *binary = NULL; + int store_in_cache = cache_fname != NULL && !loaded_from_cache; + if (store_in_cache || ctx->cfg->dump_binary_to != NULL) { + OPENCL_SUCCEED_FATAL(clGetProgramInfo(prog, CL_PROGRAM_BINARY_SIZES, + sizeof(size_t), &binary_size, NULL)); + binary = (unsigned char*) malloc(binary_size); + OPENCL_SUCCEED_FATAL(clGetProgramInfo(prog, CL_PROGRAM_BINARIES, + sizeof(unsigned char*), &binary, NULL)); + } + + if (store_in_cache) { + if (ctx->cfg->logging) { + fprintf(stderr, "Caching OpenCL binary in %s...\n", cache_fname); + } + if (cache_store(cache_fname, &h, binary, binary_size) != 0) { + printf("Failed to cache binary: %s\n", strerror(errno)); + } + } + + if (ctx->cfg->dump_binary_to != NULL) { + if (ctx->cfg->logging) { + fprintf(stderr, "Dumping OpenCL binary to %s...\n", ctx->cfg->dump_binary_to); + } + dump_file(ctx->cfg->dump_binary_to, binary, binary_size); + } + + ctx->clprogram = prog; +} + +static struct opencl_device_option get_preferred_device(const struct futhark_context_config *cfg) { + struct opencl_device_option *devices; + size_t num_devices; + + opencl_all_device_options(&devices, &num_devices); + + int num_device_matches = 0; + + for (size_t i = 0; i < num_devices; i++) { + struct opencl_device_option device = devices[i]; + if (strstr(device.platform_name, cfg->preferred_platform) != NULL && + strstr(device.device_name, cfg->preferred_device) != NULL && + (cfg->ignore_blacklist || + !is_blacklisted(device.platform_name, device.device_name, cfg)) && + num_device_matches++ == cfg->preferred_device_num) { + // Free all the platform and device names, except the ones we have chosen. + for (size_t j = 0; j < num_devices; j++) { + if (j != i) { + free(devices[j].platform_name); + free(devices[j].device_name); + } + } + free(devices); + return device; + } + } + + futhark_panic(1, "Could not find acceptable OpenCL device.\n"); + exit(1); // Never reached +} + +static void setup_opencl(struct futhark_context *ctx, + const char *srcs[], + const char *extra_build_opts[], + const char* cache_fname) { + struct opencl_device_option device_option = get_preferred_device(ctx->cfg); + + if (ctx->cfg->logging) { + fprintf(stderr, "Using platform: %s\n", device_option.platform_name); + fprintf(stderr, "Using device: %s\n", device_option.device_name); + } + + // Note that NVIDIA's OpenCL requires the platform property + cl_context_properties properties[] = { + CL_CONTEXT_PLATFORM, + (cl_context_properties)device_option.platform, + 0 + }; + + cl_int clCreateContext_error; + ctx->ctx = clCreateContext(properties, 1, &device_option.device, NULL, NULL, &clCreateContext_error); + OPENCL_SUCCEED_FATAL(clCreateContext_error); + + cl_int clCreateCommandQueue_error; + cl_command_queue queue = + clCreateCommandQueue(ctx->ctx, + device_option.device, + ctx->cfg->profiling ? CL_QUEUE_PROFILING_ENABLE : 0, + &clCreateCommandQueue_error); + OPENCL_SUCCEED_FATAL(clCreateCommandQueue_error); + + setup_opencl_with_command_queue(ctx, queue, srcs, extra_build_opts, cache_fname); +} + +int backend_context_setup(struct futhark_context* ctx) { + ctx->lockstep_width = 0; // Real value set later. + ctx->profiling_records_capacity = 200; + ctx->profiling_records_used = 0; + ctx->profiling_records = + malloc(ctx->profiling_records_capacity * + sizeof(struct profiling_record)); + ctx->failure_is_an_option = 0; + ctx->total_runs = 0; + ctx->total_runtime = 0; + ctx->peak_mem_usage_device = 0; + ctx->cur_mem_usage_device = 0; + + if (ctx->cfg->queue_set) { + setup_opencl_with_command_queue(ctx, ctx->cfg->queue, opencl_program, ctx->cfg->build_opts, ctx->cfg->cache_fname); + } else { + setup_opencl(ctx, opencl_program, ctx->cfg->build_opts, ctx->cfg->cache_fname); + } + + cl_int error; + cl_int no_error = -1; + ctx->global_failure = + clCreateBuffer(ctx->ctx, + CL_MEM_READ_WRITE | CL_MEM_COPY_HOST_PTR, + sizeof(cl_int), &no_error, &error); + OPENCL_SUCCEED_OR_RETURN(error); + + // The +1 is to avoid zero-byte allocations. + ctx->global_failure_args = + clCreateBuffer(ctx->ctx, + CL_MEM_READ_WRITE, + sizeof(int64_t)*(max_failure_args+1), NULL, &error); + OPENCL_SUCCEED_OR_RETURN(error); + + set_tuning_params(ctx); + return 0; +} + +void backend_context_teardown(struct futhark_context* ctx) { + OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->global_failure)); + OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->global_failure_args)); + (void)opencl_tally_profiling_records(ctx); + free(ctx->profiling_records); + (void)opencl_free_all(ctx); + (void)clReleaseProgram(ctx->clprogram); + (void)clReleaseCommandQueue(ctx->queue); + (void)clReleaseContext(ctx->ctx); +} + +cl_command_queue futhark_context_get_command_queue(struct futhark_context* ctx) { + return ctx->queue; +} + +// End of backends/opencl.h diff --git a/rts/c/context.h b/rts/c/context.h --- a/rts/c/context.h +++ b/rts/c/context.h @@ -72,18 +72,75 @@ } } -static void context_setup(struct futhark_context *ctx) { +struct futhark_context_config* futhark_context_config_new(void) { + struct futhark_context_config* cfg = malloc(sizeof(struct futhark_context_config)); + if (cfg == NULL) { + return NULL; + } + cfg->in_use = 0; + cfg->debugging = 0; + cfg->profiling = 0; + cfg->logging = 0; + cfg->cache_fname = NULL; + cfg->num_tuning_params = num_tuning_params; + cfg->tuning_params = malloc(cfg->num_tuning_params * sizeof(int64_t)); + memcpy(cfg->tuning_params, tuning_param_defaults, + cfg->num_tuning_params * sizeof(int64_t)); + cfg->tuning_param_names = tuning_param_names; + cfg->tuning_param_vars = tuning_param_vars; + cfg->tuning_param_classes = tuning_param_classes; + backend_context_config_setup(cfg); + return cfg; +} + +void futhark_context_config_free(struct futhark_context_config* cfg) { + assert(!cfg->in_use); + backend_context_config_teardown(cfg); + free(cfg->tuning_params); + free(cfg); +} + +struct futhark_context* futhark_context_new(struct futhark_context_config* cfg) { + struct futhark_context* ctx = malloc(sizeof(struct futhark_context)); + if (ctx == NULL) { + return NULL; + } + assert(!cfg->in_use); + ctx->cfg = cfg; + ctx->cfg->in_use = 1; create_lock(&ctx->error_lock); create_lock(&ctx->lock); free_list_init(&ctx->free_list); + ctx->peak_mem_usage_default = 0; + ctx->cur_mem_usage_default = 0; + ctx->constants = malloc(sizeof(struct constants)); + ctx->detail_memory = cfg->debugging; + ctx->debugging = cfg->debugging; + ctx->logging = cfg->logging; + ctx->profiling = cfg->profiling; + ctx->profiling_paused = 0; + ctx->error = NULL; + ctx->log = stderr; + if (backend_context_setup(ctx) == 0) { + setup_program(ctx); + init_constants(ctx); + (void)futhark_context_clear_caches(ctx); + (void)futhark_context_sync(ctx); + } + return ctx; } -static void context_teardown(struct futhark_context *ctx) { +void futhark_context_free(struct futhark_context* ctx) { free_constants(ctx); + teardown_program(ctx); + backend_context_teardown(ctx); free_all_in_free_list(ctx); free_list_destroy(&ctx->free_list); + free(ctx->constants); free_lock(&ctx->lock); free_lock(&ctx->error_lock); + ctx->cfg->in_use = 0; + free(ctx); } // End of context.h diff --git a/rts/c/context_prototypes.h b/rts/c/context_prototypes.h --- a/rts/c/context_prototypes.h +++ b/rts/c/context_prototypes.h @@ -1,20 +1,29 @@ // Start of context_prototypes.h // -// Prototypes for the functions in context.h that need to be -// available very early. +// Prototypes for the functions in context.h, or that will be called +// from those functions, that need to be available very early. struct futhark_context_config; struct futhark_context; static void set_error(struct futhark_context* ctx, char *error); -// These are called in context new/free functions and contain shared setup. -static void context_setup(struct futhark_context *ctx); -static void context_teardown(struct futhark_context *ctx); +// These are called in context/config new/free functions and contain +// shared setup. They are generated by the compiler itself. +static int init_constants(struct futhark_context*); +static int free_constants(struct futhark_context*); +static void setup_program(struct futhark_context* ctx); +static void teardown_program(struct futhark_context *ctx); // Allocate host memory. Must be freed with host_free(). static void host_alloc(struct futhark_context* ctx, size_t size, const char* tag, size_t* size_out, void** mem_out); // Allocate memory allocated with host_alloc(). static void host_free(struct futhark_context* ctx, size_t size, const char* tag, void* mem); + +// Functions that must be defined by the backend. +static void backend_context_config_setup(struct futhark_context_config* cfg); +static void backend_context_config_teardown(struct futhark_context_config* cfg); +static int backend_context_setup(struct futhark_context *ctx); +static void backend_context_teardown(struct futhark_context *ctx); // End of of context_prototypes.h diff --git a/rts/c/cuda.h b/rts/c/cuda.h deleted file mode 100644 --- a/rts/c/cuda.h +++ /dev/null @@ -1,766 +0,0 @@ -// Start of cuda.h. - -#define CUDA_SUCCEED_FATAL(x) cuda_api_succeed_fatal(x, #x, __FILE__, __LINE__) -#define CUDA_SUCCEED_NONFATAL(x) cuda_api_succeed_nonfatal(x, #x, __FILE__, __LINE__) -#define NVRTC_SUCCEED_FATAL(x) nvrtc_api_succeed_fatal(x, #x, __FILE__, __LINE__) -#define NVRTC_SUCCEED_NONFATAL(x) nvrtc_api_succeed_nonfatal(x, #x, __FILE__, __LINE__) -// Take care not to override an existing error. -#define CUDA_SUCCEED_OR_RETURN(e) { \ - char *serror = CUDA_SUCCEED_NONFATAL(e); \ - if (serror) { \ - if (!ctx->error) { \ - ctx->error = serror; \ - return bad; \ - } else { \ - free(serror); \ - } \ - } \ - } - -// CUDA_SUCCEED_OR_RETURN returns the value of the variable 'bad' in -// scope. By default, it will be this one. Create a local variable -// of some other type if needed. This is a bit of a hack, but it -// saves effort in the code generator. -static const int bad = 1; - -static inline void cuda_api_succeed_fatal(CUresult res, const char *call, - const char *file, int line) { - if (res != CUDA_SUCCESS) { - const char *err_str; - cuGetErrorString(res, &err_str); - if (err_str == NULL) { err_str = "Unknown"; } - futhark_panic(-1, "%s:%d: CUDA call\n %s\nfailed with error code %d (%s)\n", - file, line, call, res, err_str); - } -} - -static char* cuda_api_succeed_nonfatal(CUresult res, const char *call, - const char *file, int line) { - if (res != CUDA_SUCCESS) { - const char *err_str; - cuGetErrorString(res, &err_str); - if (err_str == NULL) { err_str = "Unknown"; } - return msgprintf("%s:%d: CUDA call\n %s\nfailed with error code %d (%s)\n", - file, line, call, res, err_str); - } else { - return NULL; - } -} - -static inline void nvrtc_api_succeed_fatal(nvrtcResult res, const char *call, - const char *file, int line) { - if (res != NVRTC_SUCCESS) { - const char *err_str = nvrtcGetErrorString(res); - futhark_panic(-1, "%s:%d: NVRTC call\n %s\nfailed with error code %d (%s)\n", - file, line, call, res, err_str); - } -} - -static char* nvrtc_api_succeed_nonfatal(nvrtcResult res, const char *call, - const char *file, int line) { - if (res != NVRTC_SUCCESS) { - const char *err_str = nvrtcGetErrorString(res); - return msgprintf("%s:%d: NVRTC call\n %s\nfailed with error code %d (%s)\n", - file, line, call, res, err_str); - } else { - return NULL; - } -} - -struct cuda_config { - int debugging; - int logging; - const char *preferred_device; - int preferred_device_num; - - const char *dump_program_to; - const char *load_program_from; - - const char *dump_ptx_to; - const char *load_ptx_from; - - size_t default_block_size; - size_t default_grid_size; - size_t default_tile_size; - size_t default_reg_tile_size; - size_t default_threshold; - - int default_block_size_changed; - int default_grid_size_changed; - int default_tile_size_changed; - - int num_sizes; - const char **size_names; - const char **size_vars; - int64_t *size_values; - const char **size_classes; -}; - -static void cuda_config_init(struct cuda_config *cfg, - int num_sizes, - const char *size_names[], - const char *size_vars[], - int64_t *size_values, - const char *size_classes[]) { - cfg->debugging = 0; - cfg->logging = 0; - cfg->preferred_device_num = 0; - cfg->preferred_device = ""; - cfg->dump_program_to = NULL; - cfg->load_program_from = NULL; - - cfg->dump_ptx_to = NULL; - cfg->load_ptx_from = NULL; - - cfg->default_block_size = 256; - cfg->default_grid_size = 0; // Set properly later. - cfg->default_tile_size = 32; - cfg->default_reg_tile_size = 2; - cfg->default_threshold = 32*1024; - - cfg->default_block_size_changed = 0; - cfg->default_grid_size_changed = 0; - cfg->default_tile_size_changed = 0; - - cfg->num_sizes = num_sizes; - cfg->size_names = size_names; - cfg->size_vars = size_vars; - cfg->size_values = size_values; - cfg->size_classes = size_classes; -} - -// A record of something that happened. -struct profiling_record { - cudaEvent_t *events; // Points to two events. - int *runs; - int64_t *runtime; -}; - -struct cuda_context { - CUdevice dev; - CUcontext cu_ctx; - CUmodule module; - - struct cuda_config cfg; - - struct free_list free_list; - - size_t max_block_size; - size_t max_grid_size; - size_t max_tile_size; - size_t max_threshold; - size_t max_shared_memory; - size_t max_bespoke; - - size_t lockstep_width; - - struct profiling_record *profiling_records; - int profiling_records_capacity; - int profiling_records_used; -}; - -#define CU_DEV_ATTR(x) (CU_DEVICE_ATTRIBUTE_##x) -#define device_query(dev,attrib) _device_query(dev, CU_DEV_ATTR(attrib)) -static int _device_query(CUdevice dev, CUdevice_attribute attrib) { - int val; - CUDA_SUCCEED_FATAL(cuDeviceGetAttribute(&val, attrib, dev)); - return val; -} - -#define CU_FUN_ATTR(x) (CU_FUNC_ATTRIBUTE_##x) -#define function_query(fn,attrib) _function_query(dev, CU_FUN_ATTR(attrib)) -static int _function_query(CUfunction dev, CUfunction_attribute attrib) { - int val; - CUDA_SUCCEED_FATAL(cuFuncGetAttribute(&val, attrib, dev)); - return val; -} - -static void set_preferred_device(struct cuda_config *cfg, const char *s) { - int x = 0; - if (*s == '#') { - s++; - while (isdigit(*s)) { - x = x * 10 + (*s++)-'0'; - } - // Skip trailing spaces. - while (isspace(*s)) { - s++; - } - } - cfg->preferred_device = s; - cfg->preferred_device_num = x; -} - -static int cuda_device_setup(struct cuda_context *ctx) { - char name[256]; - int count, chosen = -1, best_cc = -1; - int cc_major_best, cc_minor_best; - int cc_major, cc_minor; - CUdevice dev; - - CUDA_SUCCEED_FATAL(cuDeviceGetCount(&count)); - if (count == 0) { return 1; } - - int num_device_matches = 0; - - // XXX: Current device selection policy is to choose the device with the - // highest compute capability (if no preferred device is set). - // This should maybe be changed, since greater compute capability is not - // necessarily an indicator of better performance. - for (int i = 0; i < count; i++) { - CUDA_SUCCEED_FATAL(cuDeviceGet(&dev, i)); - - cc_major = device_query(dev, COMPUTE_CAPABILITY_MAJOR); - cc_minor = device_query(dev, COMPUTE_CAPABILITY_MINOR); - - CUDA_SUCCEED_FATAL(cuDeviceGetName(name, sizeof(name) - 1, dev)); - name[sizeof(name) - 1] = 0; - - if (ctx->cfg.logging) { - fprintf(stderr, "Device #%d: name=\"%s\", compute capability=%d.%d\n", - i, name, cc_major, cc_minor); - } - - if (device_query(dev, COMPUTE_MODE) == CU_COMPUTEMODE_PROHIBITED) { - if (ctx->cfg.logging) { - fprintf(stderr, "Device #%d is compute-prohibited, ignoring\n", i); - } - continue; - } - - if (best_cc == -1 || cc_major > cc_major_best || - (cc_major == cc_major_best && cc_minor > cc_minor_best)) { - best_cc = i; - cc_major_best = cc_major; - cc_minor_best = cc_minor; - } - - if (strstr(name, ctx->cfg.preferred_device) != NULL && - num_device_matches++ == ctx->cfg.preferred_device_num) { - chosen = i; - break; - } - } - - if (chosen == -1) { chosen = best_cc; } - if (chosen == -1) { return 1; } - - if (ctx->cfg.logging) { - fprintf(stderr, "Using device #%d\n", chosen); - } - - CUDA_SUCCEED_FATAL(cuDeviceGet(&ctx->dev, chosen)); - return 0; -} - -static char *concat_fragments(const char *src_fragments[]) { - size_t src_len = 0; - const char **p; - - for (p = src_fragments; *p; p++) { - src_len += strlen(*p); - } - - char *src = (char*) malloc(src_len + 1); - size_t n = 0; - for (p = src_fragments; *p; p++) { - strcpy(src + n, *p); - n += strlen(*p); - } - - return src; -} - -static const char *cuda_nvrtc_get_arch(CUdevice dev) { - struct { - int major; - int minor; - const char *arch_str; - } static const x[] = { - { 3, 0, "compute_30" }, - { 3, 2, "compute_32" }, - { 3, 5, "compute_35" }, - { 3, 7, "compute_37" }, - { 5, 0, "compute_50" }, - { 5, 2, "compute_52" }, - { 5, 3, "compute_53" }, - { 6, 0, "compute_60" }, - { 6, 1, "compute_61" }, - { 6, 2, "compute_62" }, - { 7, 0, "compute_70" }, - { 7, 2, "compute_72" }, - { 7, 5, "compute_75" }, - { 8, 0, "compute_80" }, - { 8, 6, "compute_80" }, - { 8, 7, "compute_80" } - }; - - int major = device_query(dev, COMPUTE_CAPABILITY_MAJOR); - int minor = device_query(dev, COMPUTE_CAPABILITY_MINOR); - - int chosen = -1; - for (int i = 0; i < sizeof(x)/sizeof(x[0]); i++) { - if (x[i].major < major || (x[i].major == major && x[i].minor <= minor)) { - chosen = i; - } else { - break; - } - } - - if (chosen == -1) { - futhark_panic(-1, "Unsupported compute capability %d.%d\n", major, minor); - } - - if (x[chosen].major != major || x[chosen].minor != minor) { - fprintf(stderr, - "Warning: device compute capability is %d.%d, but newest supported by Futhark is %d.%d.\n", - major, minor, x[chosen].major, x[chosen].minor); - } - - return x[chosen].arch_str; -} - -static void cuda_nvrtc_mk_build_options(struct cuda_context *ctx, const char *extra_opts[], - char*** opts_out, size_t *n_opts) { - int arch_set = 0, num_extra_opts; - - // nvrtc cannot handle multiple -arch options. Hence, if one of the - // extra_opts is -arch, we have to be careful not to do our usual - // automatic generation. - for (num_extra_opts = 0; extra_opts[num_extra_opts] != NULL; num_extra_opts++) { - if (strstr(extra_opts[num_extra_opts], "-arch") - == extra_opts[num_extra_opts] || - strstr(extra_opts[num_extra_opts], "--gpu-architecture") - == extra_opts[num_extra_opts]) { - arch_set = 1; - } - } - - size_t i = 0, n_opts_alloc = 20 + num_extra_opts + ctx->cfg.num_sizes; - char **opts = (char**) malloc(n_opts_alloc * sizeof(char *)); - if (!arch_set) { - opts[i++] = strdup("-arch"); - opts[i++] = strdup(cuda_nvrtc_get_arch(ctx->dev)); - } - opts[i++] = strdup("-default-device"); - if (ctx->cfg.debugging) { - opts[i++] = strdup("-G"); - opts[i++] = strdup("-lineinfo"); - } else { - opts[i++] = strdup("--disable-warnings"); - } - opts[i++] = msgprintf("-D%s=%d", - "max_group_size", - (int)ctx->max_block_size); - for (size_t j = 0; j < ctx->cfg.num_sizes; j++) { - opts[i++] = msgprintf("-D%s=%zu", ctx->cfg.size_vars[j], - ctx->cfg.size_values[j]); - } - opts[i++] = msgprintf("-DLOCKSTEP_WIDTH=%zu", ctx->lockstep_width); - opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_block_size); - - // Time for the best lines of the code in the entire compiler. - if (getenv("CUDA_HOME") != NULL) { - opts[i++] = msgprintf("-I%s/include", getenv("CUDA_HOME")); - } - if (getenv("CUDA_ROOT") != NULL) { - opts[i++] = msgprintf("-I%s/include", getenv("CUDA_ROOT")); - } - if (getenv("CUDA_PATH") != NULL) { - opts[i++] = msgprintf("-I%s/include", getenv("CUDA_PATH")); - } - opts[i++] = msgprintf("-I/usr/local/cuda/include"); - opts[i++] = msgprintf("-I/usr/include"); - - for (int j = 0; extra_opts[j] != NULL; j++) { - opts[i++] = strdup(extra_opts[j]); - } - - *n_opts = i; - *opts_out = opts; -} - -static char* cuda_nvrtc_build(struct cuda_context *ctx, const char *src, - const char *opts[], size_t n_opts, - char **ptx) { - nvrtcProgram prog; - char *problem = NULL; - - problem = NVRTC_SUCCEED_NONFATAL(nvrtcCreateProgram(&prog, src, "futhark-cuda", 0, NULL, NULL)); - - if (problem) { - return problem; - } - - nvrtcResult res = nvrtcCompileProgram(prog, n_opts, opts); - if (res != NVRTC_SUCCESS) { - size_t log_size; - if (nvrtcGetProgramLogSize(prog, &log_size) == NVRTC_SUCCESS) { - char *log = (char*) malloc(log_size); - if (nvrtcGetProgramLog(prog, log) == NVRTC_SUCCESS) { - problem = msgprintf("NVRTC compilation failed.\n\n%s\n", log); - } else { - problem = msgprintf("Could not retrieve compilation log\n"); - } - free(log); - } - return problem; - } - - size_t ptx_size; - NVRTC_SUCCEED_FATAL(nvrtcGetPTXSize(prog, &ptx_size)); - *ptx = (char*) malloc(ptx_size); - NVRTC_SUCCEED_FATAL(nvrtcGetPTX(prog, *ptx)); - - NVRTC_SUCCEED_FATAL(nvrtcDestroyProgram(&prog)); - - return NULL; -} - -static void cuda_load_ptx_from_cache(struct cuda_context *ctx, const char *src, - const char *opts[], size_t n_opts, - struct cache_hash *h, const char *cache_fname, - char **ptx) { - if (ctx->cfg.logging) { - fprintf(stderr, "Restoring cache from from %s...\n", cache_fname); - } - cache_hash_init(h); - for (size_t i = 0; i < n_opts; i++) { - cache_hash(h, opts[i], strlen(opts[i])); - } - cache_hash(h, src, strlen(src)); - size_t ptxsize; - errno = 0; - if (cache_restore(cache_fname, h, (unsigned char**)ptx, &ptxsize) != 0) { - if (ctx->cfg.logging) { - fprintf(stderr, "Failed to restore cache (errno: %s)\n", strerror(errno)); - } - } -} - -static void cuda_size_setup(struct cuda_context *ctx) -{ - if (ctx->cfg.default_block_size > ctx->max_block_size) { - if (ctx->cfg.default_block_size_changed) { - fprintf(stderr, - "Note: Device limits default block size to %zu (down from %zu).\n", - ctx->max_block_size, ctx->cfg.default_block_size); - } - ctx->cfg.default_block_size = ctx->max_block_size; - } - if (ctx->cfg.default_grid_size > ctx->max_grid_size) { - if (ctx->cfg.default_grid_size_changed) { - fprintf(stderr, - "Note: Device limits default grid size to %zu (down from %zu).\n", - ctx->max_grid_size, ctx->cfg.default_grid_size); - } - ctx->cfg.default_grid_size = ctx->max_grid_size; - } - if (ctx->cfg.default_tile_size > ctx->max_tile_size) { - if (ctx->cfg.default_tile_size_changed) { - fprintf(stderr, - "Note: Device limits default tile size to %zu (down from %zu).\n", - ctx->max_tile_size, ctx->cfg.default_tile_size); - } - ctx->cfg.default_tile_size = ctx->max_tile_size; - } - - if (!ctx->cfg.default_grid_size_changed) { - ctx->cfg.default_grid_size = - (device_query(ctx->dev, MULTIPROCESSOR_COUNT) * - device_query(ctx->dev, MAX_THREADS_PER_MULTIPROCESSOR)) - / ctx->cfg.default_block_size; - } - - for (int i = 0; i < ctx->cfg.num_sizes; i++) { - const char *size_class = ctx->cfg.size_classes[i]; - int64_t *size_value = &ctx->cfg.size_values[i]; - const char* size_name = ctx->cfg.size_names[i]; - int64_t max_value = 0, default_value = 0; - - if (strstr(size_class, "group_size") == size_class) { - max_value = ctx->max_block_size; - default_value = ctx->cfg.default_block_size; - } else if (strstr(size_class, "num_groups") == size_class) { - max_value = ctx->max_grid_size; - default_value = ctx->cfg.default_grid_size; - // XXX: as a quick and dirty hack, use twice as many threads for - // histograms by default. We really should just be smarter - // about sizes somehow. - if (strstr(size_name, ".seghist_") != NULL) { - default_value *= 2; - } - } else if (strstr(size_class, "tile_size") == size_class) { - max_value = ctx->max_tile_size; - default_value = ctx->cfg.default_tile_size; - } else if (strstr(size_class, "reg_tile_size") == size_class) { - max_value = 0; // No limit. - default_value = ctx->cfg.default_reg_tile_size; - } else if (strstr(size_class, "threshold") == size_class) { - // Threshold can be as large as it takes. - default_value = ctx->cfg.default_threshold; - } else { - // Bespoke sizes have no limit or default. - } - - if (*size_value == 0) { - *size_value = default_value; - } else if (max_value > 0 && *size_value > max_value) { - fprintf(stderr, "Note: Device limits %s to %zu (down from %zu)\n", - size_name, max_value, *size_value); - *size_value = max_value; - } - } -} - -static char* cuda_module_setup(struct cuda_context *ctx, - const char *src_fragments[], - const char *extra_opts[], - const char* cache_fname) { - char *ptx = NULL, *src = NULL; - - if (ctx->cfg.load_program_from == NULL) { - src = concat_fragments(src_fragments); - } else { - src = slurp_file(ctx->cfg.load_program_from, NULL); - } - - if (ctx->cfg.load_ptx_from) { - if (ctx->cfg.load_program_from != NULL) { - fprintf(stderr, - "WARNING: Using PTX from %s instead of C code from %s\n", - ctx->cfg.load_ptx_from, ctx->cfg.load_program_from); - } - ptx = slurp_file(ctx->cfg.load_ptx_from, NULL); - } - - if (ctx->cfg.dump_program_to != NULL) { - dump_file(ctx->cfg.dump_program_to, src, strlen(src)); - } - - char **opts; - size_t n_opts; - cuda_nvrtc_mk_build_options(ctx, extra_opts, &opts, &n_opts); - - if (ctx->cfg.logging) { - fprintf(stderr, "NVRTC compile options:\n"); - for (size_t j = 0; j < n_opts; j++) { - fprintf(stderr, "\t%s\n", opts[j]); - } - fprintf(stderr, "\n"); - } - - struct cache_hash h; - int loaded_ptx_from_cache = 0; - if (cache_fname != NULL) { - cuda_load_ptx_from_cache(ctx, src, (const char**)opts, n_opts, &h, cache_fname, &ptx); - - if (ptx != NULL) { - if (ctx->cfg.logging) { - fprintf(stderr, "Restored PTX from cache; now loading module...\n"); - } - if (cuModuleLoadData(&ctx->module, ptx) == CUDA_SUCCESS) { - if (ctx->cfg.logging) { - fprintf(stderr, "Success!\n"); - } - loaded_ptx_from_cache = 1; - } else { - if (ctx->cfg.logging) { - fprintf(stderr, "Failed!\n"); - } - free(ptx); - ptx = NULL; - } - } - } - - if (ptx == NULL) { - char* problem = cuda_nvrtc_build(ctx, src, (const char**)opts, n_opts, &ptx); - if (problem != NULL) { - free(src); - return problem; - } - } - - if (ctx->cfg.dump_ptx_to != NULL) { - dump_file(ctx->cfg.dump_ptx_to, ptx, strlen(ptx)); - } - - if (!loaded_ptx_from_cache) { - CUDA_SUCCEED_FATAL(cuModuleLoadData(&ctx->module, ptx)); - } - - if (cache_fname != NULL && !loaded_ptx_from_cache) { - if (ctx->cfg.logging) { - fprintf(stderr, "Caching PTX in %s...\n", cache_fname); - } - errno = 0; - if (cache_store(cache_fname, &h, (const unsigned char*)ptx, strlen(ptx)) != 0) { - fprintf(stderr, "Failed to cache PTX: %s\n", strerror(errno)); - } - } - - for (size_t i = 0; i < n_opts; i++) { - free((char *)opts[i]); - } - free(opts); - - free(ptx); - if (src != NULL) { - free(src); - } - - return NULL; -} - -static char* cuda_setup(struct cuda_context *ctx, const char *src_fragments[], - const char *extra_opts[], const char* cache_fname) { - CUDA_SUCCEED_FATAL(cuInit(0)); - - if (cuda_device_setup(ctx) != 0) { - futhark_panic(-1, "No suitable CUDA device found.\n"); - } - CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev)); - - free_list_init(&ctx->free_list); - - ctx->max_shared_memory = device_query(ctx->dev, MAX_SHARED_MEMORY_PER_BLOCK); - ctx->max_block_size = device_query(ctx->dev, MAX_THREADS_PER_BLOCK); - ctx->max_grid_size = device_query(ctx->dev, MAX_GRID_DIM_X); - ctx->max_tile_size = sqrt(ctx->max_block_size); - ctx->max_threshold = 0; - ctx->max_bespoke = 0; - ctx->lockstep_width = device_query(ctx->dev, WARP_SIZE); - - cuda_size_setup(ctx); - return cuda_module_setup(ctx, src_fragments, extra_opts, cache_fname); -} - -// Count up the runtime all the profiling_records that occured during execution. -// Also clears the buffer of profiling_records. -static cudaError_t cuda_tally_profiling_records(struct cuda_context *ctx) { - cudaError_t err; - for (int i = 0; i < ctx->profiling_records_used; i++) { - struct profiling_record record = ctx->profiling_records[i]; - - float ms; - if ((err = cudaEventElapsedTime(&ms, record.events[0], record.events[1])) != cudaSuccess) { - return err; - } - - // CUDA provides milisecond resolution, but we want microseconds. - *record.runs += 1; - *record.runtime += ms*1000; - - if ((err = cudaEventDestroy(record.events[0])) != cudaSuccess) { - return err; - } - if ((err = cudaEventDestroy(record.events[1])) != cudaSuccess) { - return err; - } - - free(record.events); - } - - ctx->profiling_records_used = 0; - - return cudaSuccess; -} - -// Returns pointer to two events. -static cudaEvent_t* cuda_get_events(struct cuda_context *ctx, int *runs, int64_t *runtime) { - if (ctx->profiling_records_used == ctx->profiling_records_capacity) { - ctx->profiling_records_capacity *= 2; - ctx->profiling_records = - realloc(ctx->profiling_records, - ctx->profiling_records_capacity * - sizeof(struct profiling_record)); - } - cudaEvent_t *events = calloc(2, sizeof(cudaEvent_t)); - cudaEventCreate(&events[0]); - cudaEventCreate(&events[1]); - ctx->profiling_records[ctx->profiling_records_used].events = events; - ctx->profiling_records[ctx->profiling_records_used].runs = runs; - ctx->profiling_records[ctx->profiling_records_used].runtime = runtime; - ctx->profiling_records_used++; - return events; -} - -static CUresult cuda_free_all(struct cuda_context *ctx); - -static void cuda_cleanup(struct cuda_context *ctx) { - CUDA_SUCCEED_FATAL(cuda_free_all(ctx)); - (void)cuda_tally_profiling_records(ctx); - free(ctx->profiling_records); - CUDA_SUCCEED_FATAL(cuModuleUnload(ctx->module)); - CUDA_SUCCEED_FATAL(cuCtxDestroy(ctx->cu_ctx)); -} - -static CUresult cuda_alloc(struct cuda_context *ctx, FILE *log, - size_t min_size, const char *tag, - CUdeviceptr *mem_out, size_t *size_out) { - if (min_size < sizeof(int)) { - min_size = sizeof(int); - } - - if (free_list_find(&ctx->free_list, min_size, tag, size_out, (fl_mem*)mem_out) == 0) { - if (*size_out >= min_size) { - if (ctx->cfg.debugging) { - fprintf(log, "No need to allocate: Found a block in the free list.\n"); - } - return CUDA_SUCCESS; - } else { - if (ctx->cfg.debugging) { - fprintf(log, "Found a free block, but it was too small.\n"); - } - - CUresult res = cuMemFree(*mem_out); - if (res != CUDA_SUCCESS) { - return res; - } - } - } - - *size_out = min_size; - - if (ctx->cfg.debugging) { - fprintf(log, "Actually allocating the desired block.\n"); - } - - CUresult res = cuMemAlloc(mem_out, min_size); - while (res == CUDA_ERROR_OUT_OF_MEMORY) { - CUdeviceptr mem; - if (free_list_first(&ctx->free_list, (fl_mem*)&mem) == 0) { - res = cuMemFree(mem); - if (res != CUDA_SUCCESS) { - return res; - } - } else { - break; - } - res = cuMemAlloc(mem_out, min_size); - } - - return res; -} - -static CUresult cuda_free(struct cuda_context *ctx, - CUdeviceptr mem, size_t size, const char *tag) { - free_list_insert(&ctx->free_list, size, (fl_mem)mem, tag); - return CUDA_SUCCESS; -} - -static CUresult cuda_free_all(struct cuda_context *ctx) { - CUdeviceptr mem; - free_list_pack(&ctx->free_list); - while (free_list_first(&ctx->free_list, (fl_mem*)&mem) == 0) { - CUresult res = cuMemFree(mem); - if (res != CUDA_SUCCESS) { - return res; - } - } - - return CUDA_SUCCESS; -} - -// End of cuda.h. diff --git a/rts/c/opencl.h b/rts/c/opencl.h deleted file mode 100644 --- a/rts/c/opencl.h +++ /dev/null @@ -1,1066 +0,0 @@ -// Start of opencl.h. - -#define OPENCL_SUCCEED_FATAL(e) opencl_succeed_fatal(e, #e, __FILE__, __LINE__) -#define OPENCL_SUCCEED_NONFATAL(e) opencl_succeed_nonfatal(e, #e, __FILE__, __LINE__) -// Take care not to override an existing error. -#define OPENCL_SUCCEED_OR_RETURN(e) { \ - char *serror = OPENCL_SUCCEED_NONFATAL(e); \ - if (serror) { \ - if (!ctx->error) { \ - ctx->error = serror; \ - return bad; \ - } else { \ - free(serror); \ - } \ - } \ - } - -// OPENCL_SUCCEED_OR_RETURN returns the value of the variable 'bad' in -// scope. By default, it will be this one. Create a local variable -// of some other type if needed. This is a bit of a hack, but it -// saves effort in the code generator. -static const int bad = 1; - -struct opencl_config { - int debugging; - int profiling; - int logging; - int preferred_device_num; - const char *preferred_platform; - const char *preferred_device; - int ignore_blacklist; - - const char* dump_program_to; - const char* load_program_from; - const char* dump_binary_to; - const char* load_binary_from; - - size_t default_group_size; - size_t default_num_groups; - size_t default_tile_size; - size_t default_reg_tile_size; - size_t default_threshold; - - int default_group_size_changed; - int default_tile_size_changed; - - int num_sizes; - const char **size_names; - const char **size_vars; - int64_t *size_values; - const char **size_classes; -}; - -static void opencl_config_init(struct opencl_config *cfg, - int num_sizes, - const char *size_names[], - const char *size_vars[], - int64_t *size_values, - const char *size_classes[]) { - cfg->debugging = 0; - cfg->logging = 0; - cfg->profiling = 0; - cfg->preferred_device_num = 0; - cfg->preferred_platform = ""; - cfg->preferred_device = ""; - cfg->ignore_blacklist = 0; - cfg->dump_program_to = NULL; - cfg->load_program_from = NULL; - cfg->dump_binary_to = NULL; - cfg->load_binary_from = NULL; - - // The following are dummy sizes that mean the concrete defaults - // will be set during initialisation via hardware-inspection-based - // heuristics. - cfg->default_group_size = 0; - cfg->default_num_groups = 0; - cfg->default_tile_size = 0; - cfg->default_reg_tile_size = 0; - cfg->default_threshold = 0; - - cfg->default_group_size_changed = 0; - cfg->default_tile_size_changed = 0; - - cfg->num_sizes = num_sizes; - cfg->size_names = size_names; - cfg->size_vars = size_vars; - cfg->size_values = size_values; - cfg->size_classes = size_classes; -} - -// A record of something that happened. -struct profiling_record { - cl_event *event; - int *runs; - int64_t *runtime; -}; - -struct opencl_context { - cl_device_id device; - cl_context ctx; - cl_command_queue queue; - - struct opencl_config cfg; - - struct free_list free_list; - - size_t max_group_size; - size_t max_num_groups; - size_t max_tile_size; - size_t max_threshold; - size_t max_local_memory; - - size_t lockstep_width; - - struct profiling_record *profiling_records; - int profiling_records_capacity; - int profiling_records_used; -}; - -struct opencl_device_option { - cl_platform_id platform; - cl_device_id device; - cl_device_type device_type; - char *platform_name; - char *device_name; -}; - -// This function must be defined by the user. It is invoked by -// setup_opencl() after the platform and device has been found, but -// before the program is loaded. Its intended use is to tune -// constants based on the selected platform and device. -static void post_opencl_setup(struct opencl_context*, struct opencl_device_option*); - -static char *strclone(const char *str) { - size_t size = strlen(str) + 1; - char *copy = (char*) malloc(size); - if (copy == NULL) { - return NULL; - } - - memcpy(copy, str, size); - return copy; -} - -static const char* opencl_error_string(cl_int err) -{ - switch (err) { - case CL_SUCCESS: return "Success!"; - case CL_DEVICE_NOT_FOUND: return "Device not found."; - case CL_DEVICE_NOT_AVAILABLE: return "Device not available"; - case CL_COMPILER_NOT_AVAILABLE: return "Compiler not available"; - case CL_MEM_OBJECT_ALLOCATION_FAILURE: return "Memory object allocation failure"; - case CL_OUT_OF_RESOURCES: return "Out of resources"; - case CL_OUT_OF_HOST_MEMORY: return "Out of host memory"; - case CL_PROFILING_INFO_NOT_AVAILABLE: return "Profiling information not available"; - case CL_MEM_COPY_OVERLAP: return "Memory copy overlap"; - case CL_IMAGE_FORMAT_MISMATCH: return "Image format mismatch"; - case CL_IMAGE_FORMAT_NOT_SUPPORTED: return "Image format not supported"; - case CL_BUILD_PROGRAM_FAILURE: return "Program build failure"; - case CL_MAP_FAILURE: return "Map failure"; - case CL_INVALID_VALUE: return "Invalid value"; - case CL_INVALID_DEVICE_TYPE: return "Invalid device type"; - case CL_INVALID_PLATFORM: return "Invalid platform"; - case CL_INVALID_DEVICE: return "Invalid device"; - case CL_INVALID_CONTEXT: return "Invalid context"; - case CL_INVALID_QUEUE_PROPERTIES: return "Invalid queue properties"; - case CL_INVALID_COMMAND_QUEUE: return "Invalid command queue"; - case CL_INVALID_HOST_PTR: return "Invalid host pointer"; - case CL_INVALID_MEM_OBJECT: return "Invalid memory object"; - case CL_INVALID_IMAGE_FORMAT_DESCRIPTOR: return "Invalid image format descriptor"; - case CL_INVALID_IMAGE_SIZE: return "Invalid image size"; - case CL_INVALID_SAMPLER: return "Invalid sampler"; - case CL_INVALID_BINARY: return "Invalid binary"; - case CL_INVALID_BUILD_OPTIONS: return "Invalid build options"; - case CL_INVALID_PROGRAM: return "Invalid program"; - case CL_INVALID_PROGRAM_EXECUTABLE: return "Invalid program executable"; - case CL_INVALID_KERNEL_NAME: return "Invalid kernel name"; - case CL_INVALID_KERNEL_DEFINITION: return "Invalid kernel definition"; - case CL_INVALID_KERNEL: return "Invalid kernel"; - case CL_INVALID_ARG_INDEX: return "Invalid argument index"; - case CL_INVALID_ARG_VALUE: return "Invalid argument value"; - case CL_INVALID_ARG_SIZE: return "Invalid argument size"; - case CL_INVALID_KERNEL_ARGS: return "Invalid kernel arguments"; - case CL_INVALID_WORK_DIMENSION: return "Invalid work dimension"; - case CL_INVALID_WORK_GROUP_SIZE: return "Invalid work group size"; - case CL_INVALID_WORK_ITEM_SIZE: return "Invalid work item size"; - case CL_INVALID_GLOBAL_OFFSET: return "Invalid global offset"; - case CL_INVALID_EVENT_WAIT_LIST: return "Invalid event wait list"; - case CL_INVALID_EVENT: return "Invalid event"; - case CL_INVALID_OPERATION: return "Invalid operation"; - case CL_INVALID_GL_OBJECT: return "Invalid OpenGL object"; - case CL_INVALID_BUFFER_SIZE: return "Invalid buffer size"; - case CL_INVALID_MIP_LEVEL: return "Invalid mip-map level"; - default: return "Unknown"; - } -} - -static void opencl_succeed_fatal(cl_int ret, - const char *call, - const char *file, - int line) { - if (ret != CL_SUCCESS) { - futhark_panic(-1, "%s:%d: OpenCL call\n %s\nfailed with error code %d (%s)\n", - file, line, call, ret, opencl_error_string(ret)); - } -} - -static char* opencl_succeed_nonfatal(cl_int ret, - const char *call, - const char *file, - int line) { - if (ret != CL_SUCCESS) { - return msgprintf("%s:%d: OpenCL call\n %s\nfailed with error code %d (%s)\n", - file, line, call, ret, opencl_error_string(ret)); - } else { - return NULL; - } -} - -static void set_preferred_platform(struct opencl_config *cfg, const char *s) { - cfg->preferred_platform = s; - cfg->ignore_blacklist = 1; -} - -static void set_preferred_device(struct opencl_config *cfg, const char *s) { - int x = 0; - if (*s == '#') { - s++; - while (isdigit(*s)) { - x = x * 10 + (*s++)-'0'; - } - // Skip trailing spaces. - while (isspace(*s)) { - s++; - } - } - cfg->preferred_device = s; - cfg->preferred_device_num = x; - cfg->ignore_blacklist = 1; -} - -static char* opencl_platform_info(cl_platform_id platform, - cl_platform_info param) { - size_t req_bytes; - char *info; - - OPENCL_SUCCEED_FATAL(clGetPlatformInfo(platform, param, 0, NULL, &req_bytes)); - - info = (char*) malloc(req_bytes); - - OPENCL_SUCCEED_FATAL(clGetPlatformInfo(platform, param, req_bytes, info, NULL)); - - return info; -} - -static char* opencl_device_info(cl_device_id device, - cl_device_info param) { - size_t req_bytes; - char *info; - - OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device, param, 0, NULL, &req_bytes)); - - info = (char*) malloc(req_bytes); - - OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device, param, req_bytes, info, NULL)); - - return info; -} - -static void opencl_all_device_options(struct opencl_device_option **devices_out, - size_t *num_devices_out) { - size_t num_devices = 0, num_devices_added = 0; - - cl_platform_id *all_platforms; - cl_uint *platform_num_devices; - - cl_uint num_platforms; - - // Find the number of platforms. - OPENCL_SUCCEED_FATAL(clGetPlatformIDs(0, NULL, &num_platforms)); - - // Make room for them. - all_platforms = calloc(num_platforms, sizeof(cl_platform_id)); - platform_num_devices = calloc(num_platforms, sizeof(cl_uint)); - - // Fetch all the platforms. - OPENCL_SUCCEED_FATAL(clGetPlatformIDs(num_platforms, all_platforms, NULL)); - - // Count the number of devices for each platform, as well as the - // total number of devices. - for (cl_uint i = 0; i < num_platforms; i++) { - if (clGetDeviceIDs(all_platforms[i], CL_DEVICE_TYPE_ALL, - 0, NULL, &platform_num_devices[i]) == CL_SUCCESS) { - num_devices += platform_num_devices[i]; - } else { - platform_num_devices[i] = 0; - } - } - - // Make room for all the device options. - struct opencl_device_option *devices = - calloc(num_devices, sizeof(struct opencl_device_option)); - - // Loop through the platforms, getting information about their devices. - for (cl_uint i = 0; i < num_platforms; i++) { - cl_platform_id platform = all_platforms[i]; - cl_uint num_platform_devices = platform_num_devices[i]; - - if (num_platform_devices == 0) { - continue; - } - - char *platform_name = opencl_platform_info(platform, CL_PLATFORM_NAME); - cl_device_id *platform_devices = - calloc(num_platform_devices, sizeof(cl_device_id)); - - // Fetch all the devices. - OPENCL_SUCCEED_FATAL(clGetDeviceIDs(platform, CL_DEVICE_TYPE_ALL, - num_platform_devices, platform_devices, NULL)); - - // Loop through the devices, adding them to the devices array. - for (cl_uint i = 0; i < num_platform_devices; i++) { - char *device_name = opencl_device_info(platform_devices[i], CL_DEVICE_NAME); - devices[num_devices_added].platform = platform; - devices[num_devices_added].device = platform_devices[i]; - OPENCL_SUCCEED_FATAL(clGetDeviceInfo(platform_devices[i], CL_DEVICE_TYPE, - sizeof(cl_device_type), - &devices[num_devices_added].device_type, - NULL)); - // We don't want the structs to share memory, so copy the platform name. - // Each device name is already unique. - devices[num_devices_added].platform_name = strclone(platform_name); - devices[num_devices_added].device_name = device_name; - num_devices_added++; - } - free(platform_devices); - free(platform_name); - } - free(all_platforms); - free(platform_num_devices); - - *devices_out = devices; - *num_devices_out = num_devices; -} - -// Returns 0 on success. -static int list_devices(void) { - struct opencl_device_option *devices; - size_t num_devices; - - opencl_all_device_options(&devices, &num_devices); - - const char *cur_platform = ""; - for (size_t i = 0; i < num_devices; i++) { - struct opencl_device_option device = devices[i]; - if (strcmp(cur_platform, device.platform_name) != 0) { - printf("Platform: %s\n", device.platform_name); - cur_platform = device.platform_name; - } - printf("[%d]: %s\n", (int)i, device.device_name); - } - - // Free all the platform and device names. - for (size_t j = 0; j < num_devices; j++) { - free(devices[j].platform_name); - free(devices[j].device_name); - } - free(devices); - - return 0; -} - -// Returns 0 on success. -static int select_device_interactively(struct opencl_config *cfg) { - struct opencl_device_option *devices; - size_t num_devices; - int ret = 1; - - opencl_all_device_options(&devices, &num_devices); - - printf("Choose OpenCL device:\n"); - const char *cur_platform = ""; - for (size_t i = 0; i < num_devices; i++) { - struct opencl_device_option device = devices[i]; - if (strcmp(cur_platform, device.platform_name) != 0) { - printf("Platform: %s\n", device.platform_name); - cur_platform = device.platform_name; - } - printf("[%d] %s\n", (int)i, device.device_name); - } - - int selection; - printf("Choice: "); - if (scanf("%d", &selection) == 1) { - ret = 0; - cfg->preferred_platform = ""; - cfg->preferred_device = ""; - cfg->preferred_device_num = selection; - cfg->ignore_blacklist = 1; - } - - // Free all the platform and device names. - for (size_t j = 0; j < num_devices; j++) { - free(devices[j].platform_name); - free(devices[j].device_name); - } - free(devices); - - return ret; -} - -static int is_blacklisted(const char *platform_name, const char *device_name, - const struct opencl_config *cfg) { - if (strcmp(cfg->preferred_platform, "") != 0 || - strcmp(cfg->preferred_device, "") != 0) { - return 0; - } else if (strstr(platform_name, "Apple") != NULL && - strstr(device_name, "Intel(R) Core(TM)") != NULL) { - return 1; - } else { - return 0; - } -} - -static struct opencl_device_option get_preferred_device(const struct opencl_config *cfg) { - struct opencl_device_option *devices; - size_t num_devices; - - opencl_all_device_options(&devices, &num_devices); - - int num_device_matches = 0; - - for (size_t i = 0; i < num_devices; i++) { - struct opencl_device_option device = devices[i]; - if (strstr(device.platform_name, cfg->preferred_platform) != NULL && - strstr(device.device_name, cfg->preferred_device) != NULL && - (cfg->ignore_blacklist || - !is_blacklisted(device.platform_name, device.device_name, cfg)) && - num_device_matches++ == cfg->preferred_device_num) { - // Free all the platform and device names, except the ones we have chosen. - for (size_t j = 0; j < num_devices; j++) { - if (j != i) { - free(devices[j].platform_name); - free(devices[j].device_name); - } - } - free(devices); - return device; - } - } - - futhark_panic(1, "Could not find acceptable OpenCL device.\n"); - exit(1); // Never reached -} - -static void describe_device_option(struct opencl_device_option device) { - fprintf(stderr, "Using platform: %s\n", device.platform_name); - fprintf(stderr, "Using device: %s\n", device.device_name); -} - -static cl_build_status build_opencl_program(cl_program program, cl_device_id device, const char* options) { - cl_int clBuildProgram_error = clBuildProgram(program, 1, &device, options, NULL, NULL); - - // Avoid termination due to CL_BUILD_PROGRAM_FAILURE - if (clBuildProgram_error != CL_SUCCESS && - clBuildProgram_error != CL_BUILD_PROGRAM_FAILURE) { - OPENCL_SUCCEED_FATAL(clBuildProgram_error); - } - - cl_build_status build_status; - OPENCL_SUCCEED_FATAL(clGetProgramBuildInfo(program, - device, - CL_PROGRAM_BUILD_STATUS, - sizeof(cl_build_status), - &build_status, - NULL)); - - if (build_status != CL_SUCCESS) { - char *build_log; - size_t ret_val_size; - OPENCL_SUCCEED_FATAL(clGetProgramBuildInfo(program, device, CL_PROGRAM_BUILD_LOG, 0, NULL, &ret_val_size)); - - build_log = (char*) malloc(ret_val_size+1); - OPENCL_SUCCEED_FATAL(clGetProgramBuildInfo(program, device, CL_PROGRAM_BUILD_LOG, ret_val_size, build_log, NULL)); - - // The spec technically does not say whether the build log is zero-terminated, so let's be careful. - build_log[ret_val_size] = '\0'; - - fprintf(stderr, "Build log:\n%s\n", build_log); - - free(build_log); - } - - return build_status; -} - -// Fields in a bitmask indicating which types we must be sure are -// available. -enum opencl_required_type { OPENCL_F64 = 1 }; - -static char* mk_compile_opts(struct opencl_context *ctx, - const char *extra_build_opts[], - struct opencl_device_option device_option) { - int compile_opts_size = 1024; - - for (int i = 0; i < ctx->cfg.num_sizes; i++) { - compile_opts_size += strlen(ctx->cfg.size_names[i]) + 20; - } - - for (int i = 0; extra_build_opts[i] != NULL; i++) { - compile_opts_size += strlen(extra_build_opts[i] + 1); - } - - char *compile_opts = (char*) malloc(compile_opts_size); - - int w = snprintf(compile_opts, compile_opts_size, - "-DLOCKSTEP_WIDTH=%d ", - (int)ctx->lockstep_width); - - w += snprintf(compile_opts+w, compile_opts_size-w, - "-D%s=%d ", - "max_group_size", - (int)ctx->max_group_size); - - for (int i = 0; i < ctx->cfg.num_sizes; i++) { - w += snprintf(compile_opts+w, compile_opts_size-w, - "-D%s=%d ", - ctx->cfg.size_vars[i], - (int)ctx->cfg.size_values[i]); - } - - for (int i = 0; extra_build_opts[i] != NULL; i++) { - w += snprintf(compile_opts+w, compile_opts_size-w, - "%s ", extra_build_opts[i]); - } - - // Oclgrind claims to support cl_khr_fp16, but this is not actually - // the case. - if (strcmp(device_option.platform_name, "Oclgrind") == 0) { - w += snprintf(compile_opts+w, compile_opts_size-w, "-DEMULATE_F16 "); - } - - return compile_opts; -} - -// We take as input several strings representing the program, because -// C does not guarantee that the compiler supports particularly large -// literals. Notably, Visual C has a limit of 2048 characters. The -// array must be NULL-terminated. -static cl_program setup_opencl_with_command_queue(struct opencl_context *ctx, - cl_command_queue queue, - const char *srcs[], - int required_types, - const char *extra_build_opts[], - const char* cache_fname) { - int error; - - free_list_init(&ctx->free_list); - ctx->queue = queue; - - OPENCL_SUCCEED_FATAL(clGetCommandQueueInfo(ctx->queue, CL_QUEUE_CONTEXT, sizeof(cl_context), &ctx->ctx, NULL)); - - // Fill out the device info. This is redundant work if we are - // called from setup_opencl() (which is the common case), but I - // doubt it matters much. - struct opencl_device_option device_option; - OPENCL_SUCCEED_FATAL(clGetCommandQueueInfo(ctx->queue, CL_QUEUE_DEVICE, - sizeof(cl_device_id), - &device_option.device, - NULL)); - OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_PLATFORM, - sizeof(cl_platform_id), - &device_option.platform, - NULL)); - OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_TYPE, - sizeof(cl_device_type), - &device_option.device_type, - NULL)); - device_option.platform_name = opencl_platform_info(device_option.platform, CL_PLATFORM_NAME); - device_option.device_name = opencl_device_info(device_option.device, CL_DEVICE_NAME); - - ctx->device = device_option.device; - - if (required_types & OPENCL_F64) { - cl_uint supported; - OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE, - sizeof(cl_uint), &supported, NULL)); - if (!supported) { - futhark_panic(1, "Program uses double-precision floats, but this is not supported on the chosen device: %s\n", - device_option.device_name); - } - } - - size_t max_group_size; - OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_MAX_WORK_GROUP_SIZE, - sizeof(size_t), &max_group_size, NULL)); - - size_t max_tile_size = sqrt(max_group_size); - - cl_ulong max_local_memory; - OPENCL_SUCCEED_FATAL(clGetDeviceInfo(device_option.device, CL_DEVICE_LOCAL_MEM_SIZE, - sizeof(size_t), &max_local_memory, NULL)); - - // Futhark reserves 4 bytes for bookkeeping information. - max_local_memory -= 4; - - // The OpenCL implementation may reserve some local memory bytes for - // various purposes. In principle, we should use - // clGetKernelWorkGroupInfo() to figure out for each kernel how much - // is actually available, but our current code generator design - // makes this infeasible. Instead, we have this nasty hack where we - // arbitrarily subtract some bytes, based on empirical measurements - // (but which might be arbitrarily wrong). Fortunately, we rarely - // try to really push the local memory usage. - if (strstr(device_option.platform_name, "NVIDIA CUDA") != NULL) { - max_local_memory -= 12; - } else if (strstr(device_option.platform_name, "AMD") != NULL) { - max_local_memory -= 16; - } - - // Make sure this function is defined. - post_opencl_setup(ctx, &device_option); - - if (max_group_size < ctx->cfg.default_group_size) { - if (ctx->cfg.default_group_size_changed) { - fprintf(stderr, "Note: Device limits default group size to %zu (down from %zu).\n", - max_group_size, ctx->cfg.default_group_size); - } - ctx->cfg.default_group_size = max_group_size; - } - - if (max_tile_size < ctx->cfg.default_tile_size) { - if (ctx->cfg.default_tile_size_changed) { - fprintf(stderr, "Note: Device limits default tile size to %zu (down from %zu).\n", - max_tile_size, ctx->cfg.default_tile_size); - } - ctx->cfg.default_tile_size = max_tile_size; - } - - ctx->max_group_size = max_group_size; - ctx->max_tile_size = max_tile_size; // No limit. - ctx->max_threshold = ctx->max_num_groups = 0; // No limit. - ctx->max_local_memory = max_local_memory; - - // Now we go through all the sizes, clamp them to the valid range, - // or set them to the default. - for (int i = 0; i < ctx->cfg.num_sizes; i++) { - const char *size_class = ctx->cfg.size_classes[i]; - int64_t *size_value = &ctx->cfg.size_values[i]; - const char* size_name = ctx->cfg.size_names[i]; - int64_t max_value = 0, default_value = 0; - - if (strstr(size_class, "group_size") == size_class) { - max_value = max_group_size; - default_value = ctx->cfg.default_group_size; - } else if (strstr(size_class, "num_groups") == size_class) { - max_value = max_group_size; // Futhark assumes this constraint. - default_value = ctx->cfg.default_num_groups; - // XXX: as a quick and dirty hack, use twice as many threads for - // histograms by default. We really should just be smarter - // about sizes somehow. - if (strstr(size_name, ".seghist_") != NULL) { - default_value *= 2; - } - } else if (strstr(size_class, "tile_size") == size_class) { - max_value = sqrt(max_group_size); - default_value = ctx->cfg.default_tile_size; - } else if (strstr(size_class, "reg_tile_size") == size_class) { - max_value = 0; // No limit. - default_value = ctx->cfg.default_reg_tile_size; - } else if (strstr(size_class, "threshold") == size_class) { - // Threshold can be as large as it takes. - default_value = ctx->cfg.default_threshold; - } else { - // Bespoke sizes have no limit or default. - } - if (*size_value == 0) { - *size_value = default_value; - } else if (max_value > 0 && *size_value > max_value) { - fprintf(stderr, "Note: Device limits %s to %d (down from %d)\n", - size_name, (int)max_value, (int)*size_value); - *size_value = max_value; - } - } - - if (ctx->lockstep_width == 0) { - ctx->lockstep_width = 1; - } - - if (ctx->cfg.logging) { - fprintf(stderr, "Lockstep width: %d\n", (int)ctx->lockstep_width); - fprintf(stderr, "Default group size: %d\n", (int)ctx->cfg.default_group_size); - fprintf(stderr, "Default number of groups: %d\n", (int)ctx->cfg.default_num_groups); - } - - char *compile_opts = mk_compile_opts(ctx, extra_build_opts, device_option); - - if (ctx->cfg.logging) { - fprintf(stderr, "OpenCL compiler options: %s\n", compile_opts); - } - - char *fut_opencl_src = NULL; - cl_program prog; - error = CL_SUCCESS; - - struct cache_hash h; - - int loaded_from_cache = 0; - if (ctx->cfg.load_binary_from == NULL) { - size_t src_size = 0; - - // Maybe we have to read OpenCL source from somewhere else (used for debugging). - if (ctx->cfg.load_program_from != NULL) { - fut_opencl_src = slurp_file(ctx->cfg.load_program_from, NULL); - assert(fut_opencl_src != NULL); - } else { - // Construct the OpenCL source concatenating all the fragments. - for (const char **src = srcs; src && *src; src++) { - src_size += strlen(*src); - } - - fut_opencl_src = (char*) malloc(src_size + 1); - - size_t n, i; - for (i = 0, n = 0; srcs && srcs[i]; i++) { - strncpy(fut_opencl_src+n, srcs[i], src_size-n); - n += strlen(srcs[i]); - } - fut_opencl_src[src_size] = 0; - } - - if (ctx->cfg.dump_program_to != NULL) { - if (ctx->cfg.logging) { - fprintf(stderr, "Dumping OpenCL source to %s...\n", ctx->cfg.dump_program_to); - } - - dump_file(ctx->cfg.dump_program_to, fut_opencl_src, strlen(fut_opencl_src)); - } - - if (cache_fname != NULL) { - if (ctx->cfg.logging) { - fprintf(stderr, "Restoring cache from from %s...\n", cache_fname); - } - cache_hash_init(&h); - cache_hash(&h, fut_opencl_src, strlen(fut_opencl_src)); - cache_hash(&h, compile_opts, strlen(compile_opts)); - - unsigned char *buf; - size_t bufsize; - errno = 0; - if (cache_restore(cache_fname, &h, &buf, &bufsize) != 0) { - if (ctx->cfg.logging) { - fprintf(stderr, "Failed to restore cache (errno: %s)\n", strerror(errno)); - } - } else { - if (ctx->cfg.logging) { - fprintf(stderr, "Cache restored; loading OpenCL binary...\n"); - } - - cl_int status = 0; - prog = clCreateProgramWithBinary(ctx->ctx, 1, &device_option.device, - &bufsize, (const unsigned char**)&buf, - &status, &error); - if (status == CL_SUCCESS) { - loaded_from_cache = 1; - if (ctx->cfg.logging) { - fprintf(stderr, "Loading succeeded.\n"); - } - } else { - if (ctx->cfg.logging) { - fprintf(stderr, "Loading failed.\n"); - } - } - } - } - - if (!loaded_from_cache) { - if (ctx->cfg.logging) { - fprintf(stderr, "Creating OpenCL program...\n"); - } - - const char* src_ptr[] = {fut_opencl_src}; - prog = clCreateProgramWithSource(ctx->ctx, 1, src_ptr, &src_size, &error); - OPENCL_SUCCEED_FATAL(error); - } - } else { - if (ctx->cfg.logging) { - fprintf(stderr, "Loading OpenCL binary from %s...\n", ctx->cfg.load_binary_from); - } - size_t binary_size; - unsigned char *fut_opencl_bin = - (unsigned char*) slurp_file(ctx->cfg.load_binary_from, &binary_size); - assert(fut_opencl_bin != NULL); - const unsigned char *binaries[1] = { fut_opencl_bin }; - cl_int status = 0; - - prog = clCreateProgramWithBinary(ctx->ctx, 1, &device_option.device, - &binary_size, binaries, - &status, &error); - - OPENCL_SUCCEED_FATAL(status); - OPENCL_SUCCEED_FATAL(error); - } - - if (ctx->cfg.logging) { - fprintf(stderr, "Building OpenCL program...\n"); - } - OPENCL_SUCCEED_FATAL(build_opencl_program(prog, device_option.device, compile_opts)); - - free(compile_opts); - free(fut_opencl_src); - - size_t binary_size = 0; - unsigned char *binary = NULL; - int store_in_cache = cache_fname != NULL && !loaded_from_cache; - if (store_in_cache || ctx->cfg.dump_binary_to != NULL) { - OPENCL_SUCCEED_FATAL(clGetProgramInfo(prog, CL_PROGRAM_BINARY_SIZES, - sizeof(size_t), &binary_size, NULL)); - binary = (unsigned char*) malloc(binary_size); - OPENCL_SUCCEED_FATAL(clGetProgramInfo(prog, CL_PROGRAM_BINARIES, - sizeof(unsigned char*), &binary, NULL)); - } - - if (store_in_cache) { - if (ctx->cfg.logging) { - fprintf(stderr, "Caching OpenCL binary in %s...\n", cache_fname); - } - if (cache_store(cache_fname, &h, binary, binary_size) != 0) { - printf("Failed to cache binary: %s\n", strerror(errno)); - } - } - - if (ctx->cfg.dump_binary_to != NULL) { - if (ctx->cfg.logging) { - fprintf(stderr, "Dumping OpenCL binary to %s...\n", ctx->cfg.dump_binary_to); - } - dump_file(ctx->cfg.dump_binary_to, binary, binary_size); - } - - return prog; -} - -static cl_program setup_opencl(struct opencl_context *ctx, - const char *srcs[], - int required_types, - const char *extra_build_opts[], - const char* cache_fname) { - - ctx->lockstep_width = 0; // Real value set later. - - struct opencl_device_option device_option = get_preferred_device(&ctx->cfg); - - if (ctx->cfg.logging) { - describe_device_option(device_option); - } - - // Note that NVIDIA's OpenCL requires the platform property - cl_context_properties properties[] = { - CL_CONTEXT_PLATFORM, - (cl_context_properties)device_option.platform, - 0 - }; - - cl_int clCreateContext_error; - ctx->ctx = clCreateContext(properties, 1, &device_option.device, NULL, NULL, &clCreateContext_error); - OPENCL_SUCCEED_FATAL(clCreateContext_error); - - cl_int clCreateCommandQueue_error; - cl_command_queue queue = - clCreateCommandQueue(ctx->ctx, - device_option.device, - ctx->cfg.profiling ? CL_QUEUE_PROFILING_ENABLE : 0, - &clCreateCommandQueue_error); - OPENCL_SUCCEED_FATAL(clCreateCommandQueue_error); - - return setup_opencl_with_command_queue(ctx, queue, srcs, required_types, extra_build_opts, - cache_fname); -} - -// Count up the runtime all the profiling_records that occured during execution. -// Also clears the buffer of profiling_records. -static cl_int opencl_tally_profiling_records(struct opencl_context *ctx) { - cl_int err; - for (int i = 0; i < ctx->profiling_records_used; i++) { - struct profiling_record record = ctx->profiling_records[i]; - - cl_ulong start_t, end_t; - - if ((err = clGetEventProfilingInfo(*record.event, - CL_PROFILING_COMMAND_START, - sizeof(start_t), - &start_t, - NULL)) != CL_SUCCESS) { - return err; - } - - if ((err = clGetEventProfilingInfo(*record.event, - CL_PROFILING_COMMAND_END, - sizeof(end_t), - &end_t, - NULL)) != CL_SUCCESS) { - return err; - } - - // OpenCL provides nanosecond resolution, but we want - // microseconds. - *record.runs += 1; - *record.runtime += (end_t - start_t)/1000; - - if ((err = clReleaseEvent(*record.event)) != CL_SUCCESS) { - return err; - } - free(record.event); - } - - ctx->profiling_records_used = 0; - - return CL_SUCCESS; -} - -// If profiling, produce an event associated with a profiling record. -static cl_event* opencl_get_event(struct opencl_context *ctx, int *runs, int64_t *runtime) { - if (ctx->profiling_records_used == ctx->profiling_records_capacity) { - ctx->profiling_records_capacity *= 2; - ctx->profiling_records = - realloc(ctx->profiling_records, - ctx->profiling_records_capacity * - sizeof(struct profiling_record)); - } - cl_event *event = malloc(sizeof(cl_event)); - ctx->profiling_records[ctx->profiling_records_used].event = event; - ctx->profiling_records[ctx->profiling_records_used].runs = runs; - ctx->profiling_records[ctx->profiling_records_used].runtime = runtime; - ctx->profiling_records_used++; - return event; -} - -// Allocate memory from driver. The problem is that OpenCL may perform -// lazy allocation, so we cannot know whether an allocation succeeded -// until the first time we try to use it. Hence we immediately -// perform a write to see if the allocation succeeded. This is slow, -// but the assumption is that this operation will be rare (most things -// will go through the free list). -static int opencl_alloc_actual(struct opencl_context *ctx, size_t size, cl_mem *mem_out) { - int error; - *mem_out = clCreateBuffer(ctx->ctx, CL_MEM_READ_WRITE, size, NULL, &error); - - if (error != CL_SUCCESS) { - return error; - } - - int x = 2; - error = clEnqueueWriteBuffer(ctx->queue, *mem_out, - CL_TRUE, - 0, sizeof(x), &x, - 0, NULL, NULL); - - // No need to wait for completion here. clWaitForEvents() cannot - // return mem object allocation failures. This implies that the - // buffer is faulted onto the device on enqueue. (Observation by - // Andreas Kloeckner.) - - return error; -} - -static int opencl_alloc(struct opencl_context *ctx, FILE *log, - size_t min_size, const char *tag, - cl_mem *mem_out, size_t *size_out) { - (void)tag; - if (min_size < sizeof(int)) { - min_size = sizeof(int); - } - - cl_mem* memptr; - if (free_list_find(&ctx->free_list, min_size, tag, size_out, (fl_mem*)&memptr) == 0) { - // Successfully found a free block. Is it big enough? - if (*size_out >= min_size) { - if (ctx->cfg.debugging) { - fprintf(log, "No need to allocate: Found a block in the free list.\n"); - } - *mem_out = *memptr; - free(memptr); - return CL_SUCCESS; - } else { - if (ctx->cfg.debugging) { - fprintf(log, "Found a free block, but it was too small.\n"); - } - int error = clReleaseMemObject(*memptr); - free(*memptr); - if (error != CL_SUCCESS) { - return error; - } - } - } - - *size_out = min_size; - - // We have to allocate a new block from the driver. If the - // allocation does not succeed, then we might be in an out-of-memory - // situation. We now start freeing things from the free list until - // we think we have freed enough that the allocation will succeed. - // Since we don't know how far the allocation is from fitting, we - // have to check after every deallocation. This might be pretty - // expensive. Let's hope that this case is hit rarely. - - if (ctx->cfg.debugging) { - fprintf(log, "Actually allocating the desired block.\n"); - } - - int error = opencl_alloc_actual(ctx, min_size, mem_out); - - while (error == CL_MEM_OBJECT_ALLOCATION_FAILURE) { - if (ctx->cfg.debugging) { - fprintf(log, "Out of OpenCL memory: releasing entry from the free list...\n"); - } - cl_mem* memptr; - if (free_list_first(&ctx->free_list, (fl_mem*)&memptr) == 0) { - cl_mem mem = *memptr; - free(memptr); - error = clReleaseMemObject(mem); - if (error != CL_SUCCESS) { - return error; - } - } else { - break; - } - error = opencl_alloc_actual(ctx, min_size, mem_out); - } - - return error; -} - -static int opencl_free(struct opencl_context *ctx, - cl_mem mem, size_t size, const char *tag) { - cl_mem* memptr = malloc(sizeof(cl_mem)); - *memptr = mem; - free_list_insert(&ctx->free_list, size, (fl_mem)memptr, tag); - return CL_SUCCESS; -} - -static int opencl_free_all(struct opencl_context *ctx) { - free_list_pack(&ctx->free_list); - cl_mem* memptr; - while (free_list_first(&ctx->free_list, (fl_mem*)&memptr) == 0) { - cl_mem mem = *memptr; - free(memptr); - int error = clReleaseMemObject(mem); - if (error != CL_SUCCESS) { - return error; - } - } - - return CL_SUCCESS; -} - -// Free everything that belongs to 'ctx', but do not free 'ctx' -// itself. -static void teardown_opencl(struct opencl_context *ctx) { - (void)opencl_tally_profiling_records(ctx); - free(ctx->profiling_records); - (void)opencl_free_all(ctx); - (void)clReleaseCommandQueue(ctx->queue); - (void)clReleaseContext(ctx->ctx); -} - -// End of opencl.h. diff --git a/rts/c/scalar.h b/rts/c/scalar.h --- a/rts/c/scalar.h +++ b/rts/c/scalar.h @@ -1774,6 +1774,10 @@ return log10(x); } +static inline float futrts_log1p_32(float x) { + return log1p(x); +} + static inline float futrts_sqrt32(float x) { return sqrt(x); } @@ -1904,6 +1908,13 @@ return futrts_log32(x) / log(10.0f); } +static inline float futrts_log1p_32(float x) { + if(x == -1.0f || (futrts_isinf32(x) && x > 0.0f)) return x / 0.0f; + float y = 1.0f + x; + float z = y - 1.0f; + return log(y) - (z-x)/y; +} + static inline float futrts_sqrt32(float x) { return sqrt(x); } @@ -2106,6 +2117,10 @@ return log10f(x); } +static inline float futrts_log1p_32(float x) { + return log1pf(x); +} + static inline float futrts_sqrt32(float x) { return sqrtf(x); } @@ -2357,6 +2372,13 @@ return futrts_log64(x)/log(10.0d); } +static inline double futrts_log1p_64(double x) { + if(x == -1.0d || (futrts_isinf64(x) && x > 0.0d)) return x / 0.0d; + double y = 1.0d + x; + double z = y - 1.0d; + return log(y) - (z-x)/y; +} + static inline double futrts_sqrt64(double x) { return sqrt(x); } @@ -2722,6 +2744,10 @@ static inline double futrts_log10_64(double x) { return log10(x); +} + +static inline double futrts_log1p_64(double x) { + return log1p(x); } static inline double futrts_sqrt64(double x) { 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 @@ -217,6 +217,10 @@ return log10(x); } +static inline f16 futrts_log1p_16(f16 x) { + return log1p(x); +} + static inline f16 futrts_sqrt16(f16 x) { return sqrt(x); } @@ -346,6 +350,13 @@ return futrts_log16(x) / log(10.0f16); } +static inline f16 futrts_log1p_16(f16 x) { + if(x == -1.0f16 || (futrts_isinf16(x) && x > 0.0f16)) return x / 0.0f16; + f16 y = 1.0f16 + x; + f16 z = y - 1.0f16; + return log(y) - (z-x)/y; +} + static inline f16 futrts_sqrt16(f16 x) { return (float16)sqrt((float)x); } @@ -497,6 +508,10 @@ return hlog10(x); } +static inline f16 futrts_log1p_16(f16 x) { + return (f16)log1pf((float)x); +} + static inline f16 futrts_sqrt16(f16 x) { return hsqrt(x); } @@ -693,6 +708,10 @@ static inline f16 futrts_log10_16(f16 x) { return futrts_log10_32(x); +} + +static inline f16 futrts_log1p_16(f16 x) { + return futrts_log1p_32(x); } static inline f16 futrts_sqrt16(f16 x) { diff --git a/rts/c/server.h b/rts/c/server.h --- a/rts/c/server.h +++ b/rts/c/server.h @@ -373,43 +373,49 @@ if (f == NULL) { failure(); printf("Failed to open %s: %s\n", fname, strerror(errno)); - } else { - int values = 0; - for (int i = 1; arg_exists(args, i); i+=2, values++) { - const char *vname = get_arg(args, i); - const char *type = get_arg(args, i+1); + return; + } - const struct type *t = get_type(s, type); - struct variable *v = create_variable(s, vname, t); + int bad = 0; + int values = 0; + for (int i = 1; arg_exists(args, i); i+=2, values++) { + const char *vname = get_arg(args, i); + const char *type = get_arg(args, i+1); - if (v == NULL) { - failure(); - printf("Variable already exists: %s\n", vname); - return; - } + const struct type *t = get_type(s, type); + struct variable *v = create_variable(s, vname, t); - errno = 0; - if (t->restore(t->aux, f, s->ctx, value_ptr(&v->value)) != 0) { - failure(); - printf("Failed to restore variable %s.\n" - "Possibly malformed data in %s (errno: %s)\n", - vname, fname, strerror(errno)); - drop_variable(v); - break; - } + if (v == NULL) { + bad = 1; + failure(); + printf("Variable already exists: %s\n", vname); + break; } - if (end_of_input(f) != 0) { + errno = 0; + if (t->restore(t->aux, f, s->ctx, value_ptr(&v->value)) != 0) { + bad = 1; failure(); - printf("Expected EOF after reading %d values from %s\n", - values, fname); + printf("Failed to restore variable %s.\n" + "Possibly malformed data in %s (errno: %s)\n", + vname, fname, strerror(errno)); + drop_variable(v); + break; } + } - fclose(f); + if (!bad && end_of_input(f) != 0) { + failure(); + printf("Expected EOF after reading %d values from %s\n", + values, fname); } - int err = futhark_context_sync(s->ctx); - error_check(s, err); + fclose(f); + + if (!bad) { + int err = futhark_context_sync(s->ctx); + error_check(s, err); + } } void cmd_store(struct server_state *s, const char *args[]) { diff --git a/rts/c/uniform.h b/rts/c/uniform.h --- a/rts/c/uniform.h +++ b/rts/c/uniform.h @@ -931,6 +931,13 @@ return futrts_log32(x) / log(10.0f); } +static inline uniform float futrts_log1p_32(uniform float x) { + if(x == -1.0f || (futrts_isinf32(x) && x > 0.0f)) return x / 0.0f; + uniform float y = 1.0f + x; + uniform float z = y - 1.0f; + return log(y) - (z-x)/y; +} + static inline uniform float futrts_sqrt32(uniform float x) { return sqrt(x); } @@ -1189,6 +1196,13 @@ return futrts_log64(x)/log(10.0d); } +static inline uniform double futrts_log1p_64(uniform double x) { + if(x == -1.0d || (futrts_isinf64(x) && x > 0.0d)) return x / 0.0d; + uniform double y = 1.0d + x; + uniform double z = y - 1.0d; + return log(y) - (z-x)/y; +} + static inline uniform double futrts_sqrt64(uniform double x) { return sqrt(x); } @@ -1559,6 +1573,13 @@ static inline uniform f16 futrts_log10_16(uniform f16 x) { return futrts_log16(x) / log(10.0f16); +} + +static inline uniform f16 futrts_log1p_16(uniform f16 x) { + if(x == -1.0f16 || (futrts_isinf16(x) && x > 0.0f16)) return x / 0.0f16; + uniform f16 y = 1.0f16 + x; + uniform f16 z = y - 1.0f16; + return log(y) - (z-x)/y; } static inline uniform f16 futrts_sqrt16(uniform f16 x) { diff --git a/rts/c/util.h b/rts/c/util.h --- a/rts/c/util.h +++ b/rts/c/util.h @@ -14,6 +14,7 @@ struct str_builder; static void str_builder_init(struct str_builder *b); static void str_builder(struct str_builder *b, const char *s, ...); +static char *strclone(const char *str); static void futhark_panic(int eval, const char *fmt, ...) { va_list ap; @@ -133,6 +134,18 @@ va_start(vl, s); // Must re-init. vsnprintf(b->str+b->used, b->capacity-b->used, s, vl); b->used += needed; +} + + +static char *strclone(const char *str) { + size_t size = strlen(str) + 1; + char *copy = (char*) malloc(size); + if (copy == NULL) { + return NULL; + } + + memcpy(copy, str, size); + return copy; } // End of util.h. diff --git a/rts/javascript/server.js b/rts/javascript/server.js --- a/rts/javascript/server.js +++ b/rts/javascript/server.js @@ -59,7 +59,7 @@ _cmd_inputs(args) { var entry = this._get_arg(args, 0); - var inputs = this._get_entry_point(entry)[0]; + var inputs = this._get_entry_point(entry)[1]; for (var i = 0; i < inputs.length; i++) { console.log(inputs[i]); } @@ -67,7 +67,7 @@ _cmd_outputs(args) { var entry = this._get_arg(args, 0); - var outputs = this._get_entry_point(entry)[1]; + var outputs = this._get_entry_point(entry)[2]; for (var i = 0; i < outputs.length; i++) { console.log(outputs[i]); } @@ -99,8 +99,8 @@ _cmd_call(args) { var entry = this._get_entry_point(this._get_arg(args, 0)); - var num_ins = entry[0].length; - var num_outs = entry[1].length; + var num_ins = entry[1].length; + var num_outs = entry[2].length; var expected_len = 1 + num_outs + num_ins if (args.length != expected_len) { @@ -121,13 +121,13 @@ } // Call entry point function from string name var bef = performance.now()*1000; - var vals = this.ctx[args[0]].apply(this.ctx, ins); + var vals = this.ctx[entry[0]].apply(this.ctx, ins); var aft = performance.now()*1000; if (num_outs == 1) { - this._set_var(out_vnames[0], vals, entry[1][0]); + this._set_var(out_vnames[0], vals, entry[2][0]); } else { for (var i = 0; i < out_vnames.length; i++) { - this._set_var(out_vnames[i], vals[i], entry[1][i]); + this._set_var(out_vnames[i], vals[i], entry[2][i]); } } console.log("runtime: " + Math.round(aft-bef)); diff --git a/rts/python/scalar.py b/rts/python/scalar.py --- a/rts/python/scalar.py +++ b/rts/python/scalar.py @@ -436,6 +436,9 @@ def futhark_log10_64(x): return np.float64(np.log10(x)) +def futhark_log1p_64(x): + return np.float64(np.log1p(x)) + def futhark_sqrt64(x): return np.sqrt(x) @@ -534,6 +537,9 @@ def futhark_log10_32(x): return np.float32(np.log10(x)) +def futhark_log1p_32(x): + return np.float32(np.log1p(x)) + def futhark_sqrt32(x): return np.float32(np.sqrt(x)) @@ -631,6 +637,9 @@ def futhark_log10_16(x): return np.float16(np.log10(x)) + +def futhark_log1p_16(x): + return np.float16(np.log1p(x)) def futhark_sqrt16(x): return np.float16(np.sqrt(x)) diff --git a/rts/python/server.py b/rts/python/server.py --- a/rts/python/server.py +++ b/rts/python/server.py @@ -39,12 +39,12 @@ def _cmd_inputs(self, args): entry = self._get_arg(args, 0) - for t in self._get_entry_point(entry)[0]: + for t in self._get_entry_point(entry)[1]: print(t) def _cmd_outputs(self, args): entry = self._get_arg(args, 0) - for t in self._get_entry_point(entry)[1]: + for t in self._get_entry_point(entry)[2]: print(t) def _cmd_dummy(self, args): @@ -65,8 +65,9 @@ def _cmd_call(self, args): entry = self._get_entry_point(self._get_arg(args, 0)) - num_ins = len(entry[0]) - num_outs = len(entry[1]) + entry_fname = entry[0] + num_ins = len(entry[1]) + num_outs = len(entry[2]) exp_len = 1 + num_outs + num_ins if len(args) != exp_len: @@ -81,7 +82,7 @@ ins = [ self._get_var(in_vname) for in_vname in in_vnames ] try: - (runtime, vals) = getattr(self._ctx, args[0])(*ins) + (runtime, vals) = getattr(self._ctx, entry_fname)(*ins) except Exception as e: raise self.Failure(str(e)) @@ -175,7 +176,11 @@ } def _process_line(self, line): - words = shlex.split(line) + lex = shlex.shlex(line) + lex.quotes = '"' + lex.whitespace_split = True + lex.commenters = '' + words = list(lex) if words == []: raise self.Failure('Empty line') else: 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 @@ -183,6 +183,12 @@ Just [untyped $ 1 / (isF32 x * log 2)] pdBuiltin "log2_64" [x] = Just [untyped $ 1 / (isF64 x * log 2)] +pdBuiltin "log1p_16" [x] = + Just [untyped $ 1 / (isF16 x + 1)] +pdBuiltin "log1p_32" [x] = + Just [untyped $ 1 / (isF32 x + 1)] +pdBuiltin "log1p_64" [x] = + Just [untyped $ 1 / (isF64 x + 1)] pdBuiltin "exp16" [x] = Just [untyped $ exp (isF16 x)] pdBuiltin "exp32" [x] = 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} module Futhark.AD.Fwd (fwdJVP) where @@ -7,7 +6,6 @@ import Control.Monad.RWS.Strict import Control.Monad.State.Strict import Data.Bifunctor (second) -import Data.Kind qualified import Data.List (transpose) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map qualified as M @@ -90,15 +88,11 @@ modify $ \env -> env {stateTans = M.insert v v' (stateTans env)} class TanBuilder a where - type Bundled a :: Data.Kind.Type - type Bundled a = [a] newTan :: a -> ADM a - bundleNew :: a -> ADM (Bundled a) + bundleNew :: a -> ADM [a] -instance (Monoid (Bundled a), TanBuilder a) => TanBuilder [a] where - type Bundled [a] = Bundled a - newTan = mapM newTan - bundleNew = fmap mconcat . mapM bundleNew +bundleNewList :: TanBuilder a => [a] -> ADM [a] +bundleNewList = fmap mconcat . mapM bundleNew instance TanBuilder (PatElem (TypeBase s u)) where newTan (PatElem p t) @@ -117,11 +111,12 @@ then pure [pe'] else pure [pe, pe'] -instance TanBuilder (Pat (TypeBase s u)) where - type Bundled (Pat (TypeBase s u)) = Pat (TypeBase s u) - newTan (Pat pes) = Pat <$> newTan pes - bundleNew (Pat pes) = Pat <$> bundleNew pes +newTanPat :: TanBuilder (PatElem t) => Pat t -> ADM (Pat t) +newTanPat (Pat pes) = Pat <$> mapM newTan pes +bundleNewPat :: TanBuilder (PatElem t) => Pat t -> ADM (Pat t) +bundleNewPat (Pat pes) = Pat <$> bundleNewList pes + instance TanBuilder (Param (TypeBase s u)) where newTan (Param _ p t) = do PatElem p' t' <- newTan $ PatElem p t @@ -142,10 +137,8 @@ pure $ zip b [x, x_tan] class Tangent a where - type BundledTan a :: Data.Kind.Type - type BundledTan a = [a] tangent :: a -> ADM a - bundleTan :: a -> ADM (BundledTan a) + bundleTan :: a -> ADM [a] instance Tangent (TypeBase s u) where tangent = tanType @@ -157,10 +150,8 @@ t' <- tangent t pure [t, t'] -instance (Monoid (BundledTan a), Tangent a) => Tangent [a] where - type BundledTan [a] = BundledTan a - tangent = mapM tangent - bundleTan = (mconcat <$>) . mapM bundleTan +bundleTangents :: Tangent a => [a] -> ADM [a] +bundleTangents = (mconcat <$>) . mapM bundleTan instance Tangent VName where tangent v = do @@ -192,7 +183,7 @@ basicFwd :: Pat Type -> StmAux () -> BasicOp -> ADM () basicFwd pat aux op = do - pat_tan <- newTan pat + pat_tan <- newTanPat pat case op of SubExp se -> do se_tan <- tangent se @@ -201,7 +192,7 @@ se_tan <- tangent se addStm $ Let pat_tan aux $ BasicOp $ Opaque opaqueop se_tan ArrayLit ses t -> do - ses_tan <- tangent ses + ses_tan <- mapM tangent ses addStm $ Let pat_tan aux $ BasicOp $ ArrayLit ses_tan t UnOp unop x -> do let t = unOpType unop @@ -233,7 +224,7 @@ addStm $ Let pat_tan aux $ BasicOp $ Update safety arr_tan slice se_tan Concat d (arr :| arrs) w -> do arr_tan <- tangent arr - arrs_tans <- tangent arrs + arrs_tans <- mapM tangent arrs addStm $ Let pat_tan aux $ BasicOp $ Concat d (arr_tan :| arrs_tans) w Copy arr -> do arr_tan <- tangent arr @@ -261,11 +252,11 @@ fwdLambda :: Lambda SOACS -> ADM (Lambda SOACS) fwdLambda l@(Lambda params body ret) = - Lambda <$> bundleNew params <*> inScopeOf l (fwdBody body) <*> bundleTan ret + Lambda <$> bundleNewList params <*> inScopeOf l (fwdBody body) <*> bundleTangents ret fwdStreamLambda :: Lambda SOACS -> ADM (Lambda SOACS) fwdStreamLambda l@(Lambda params body ret) = - Lambda <$> ((take 1 params ++) <$> bundleNew (drop 1 params)) <*> inScopeOf l (fwdBody body) <*> bundleTan ret + Lambda <$> ((take 1 params ++) <$> bundleNewList (drop 1 params)) <*> inScopeOf l (fwdBody body) <*> bundleTangents ret interleave :: [a] -> [a] -> [a] interleave xs ys = concat $ transpose [xs, ys] @@ -280,8 +271,8 @@ fwdSOAC :: Pat Type -> StmAux () -> SOAC SOACS -> ADM () fwdSOAC pat aux (Screma size xs (ScremaForm scs reds f)) = do - pat' <- bundleNew pat - xs' <- bundleTan xs + pat' <- bundleNewPat pat + xs' <- bundleTangents xs scs' <- mapM fwdScan scs reds' <- mapM fwdRed reds f' <- fwdLambda f @@ -307,34 +298,34 @@ redNeutral = redNeutral red `interleave` map Var neutral_tans } fwdSOAC pat aux (Stream size xs nes lam) = do - pat' <- bundleNew pat + pat' <- bundleNewPat pat lam' <- fwdStreamLambda lam - xs' <- bundleTan xs + xs' <- bundleTangents xs nes_tan <- mapM (fmap Var . zeroFromSubExp) nes let nes' = interleave nes nes_tan addStm $ Let pat' aux $ Op $ Stream size xs' nes' lam' fwdSOAC pat aux (Hist w arrs ops bucket_fun) = do - pat' <- bundleNew pat + pat' <- bundleNewPat pat ops' <- mapM fwdHist ops bucket_fun' <- fwdHistBucket bucket_fun - arrs' <- bundleTan arrs + arrs' <- bundleTangents arrs addStm $ Let pat' aux $ Op $ Hist w arrs' ops' bucket_fun' where n_indices = sum $ map (shapeRank . histShape) ops fwdBodyHist (Body _ stms res) = buildBody_ $ do mapM_ fwdStm stms let (res_is, res_vs) = splitAt n_indices res - (res_is ++) <$> bundleTan res_vs + (res_is ++) <$> bundleTangents res_vs fwdHistBucket l@(Lambda params body ret) = let (r_is, r_vs) = splitAt n_indices ret in Lambda - <$> bundleNew params + <$> bundleNewList params <*> inScopeOf l (fwdBodyHist body) - <*> ((r_is ++) <$> bundleTan r_vs) + <*> ((r_is ++) <$> bundleTangents r_vs) fwdHist :: HistOp SOACS -> ADM (HistOp SOACS) fwdHist (HistOp shape rf dest nes op) = do - dest' <- bundleTan dest + dest' <- bundleTangents dest nes_tan <- mapM (fmap Var . zeroFromSubExp) nes op' <- fwdLambda op pure $ @@ -347,8 +338,8 @@ } fwdSOAC (Pat pes) aux (Scatter w ivs lam as) = do as_tan <- mapM (\(s, n, a) -> do a_tan <- tangent a; pure (s, n, a_tan)) as - pes_tan <- newTan pes - ivs' <- bundleTan ivs + pes_tan <- mapM newTan pes + ivs' <- bundleTangents ivs let (as_ws, as_ns, _as_vs) = unzip3 as n_indices = sum $ zipWith (*) as_ns $ map length as_ws lam' <- fwdScatterLambda n_indices lam @@ -357,8 +348,8 @@ where fwdScatterLambda :: Int -> Lambda SOACS -> ADM (Lambda SOACS) fwdScatterLambda n_indices (Lambda params body ret) = do - params' <- bundleNew params - ret_tan <- tangent $ drop n_indices ret + params' <- bundleNewList params + ret_tan <- mapM tangent $ drop n_indices ret body' <- fwdBodyScatter n_indices body let indices = concat $ replicate 2 $ take n_indices ret ret' = indices ++ drop n_indices ret ++ ret_tan @@ -367,7 +358,7 @@ fwdBodyScatter n_indices (Body _ stms res) = do (res_tan, stms') <- collectStms $ do mapM_ fwdStm stms - tangent $ drop n_indices res + mapM tangent $ drop n_indices res let indices = concat $ replicate 2 $ take n_indices res res' = indices ++ drop n_indices res ++ res_tan pure $ mkBody stms' res' @@ -378,8 +369,8 @@ fwdStm :: Stm SOACS -> ADM () fwdStm (Let pat aux (BasicOp (UpdateAcc acc i x))) = do - pat' <- bundleNew pat - x' <- bundleTan x + pat' <- bundleNewPat pat + x' <- bundleTangents x acc_tan <- tangent acc addStm $ Let pat' aux $ BasicOp $ UpdateAcc acc_tan i x' fwdStm stm@(Let pat aux (BasicOp e)) = do @@ -392,7 +383,7 @@ addStm stm arg_tans <- zipWith primExpFromSubExp argts <$> mapM (tangent . fst) args - pat_tan <- newTan pat + pat_tan <- newTanPat pat let arg_pes = zipWith primExpFromSubExp argts (map fst args) case pdBuiltin f arg_pes of Nothing -> @@ -414,27 +405,27 @@ fwdStm (Let pat aux (Match ses cases defbody (MatchDec ret ifsort))) = do cases' <- slocal' $ mapM (traverse fwdBody) cases defbody' <- slocal' $ fwdBody defbody - pat' <- bundleNew pat - ret' <- bundleTan ret + pat' <- bundleNewPat pat + ret' <- bundleTangents ret addStm $ Let pat' aux $ Match ses cases' defbody' $ MatchDec ret' ifsort fwdStm (Let pat aux (DoLoop val_pats loop@(WhileLoop v) body)) = do - val_pats' <- bundleNew val_pats - pat' <- bundleNew pat + val_pats' <- bundleNewList val_pats + pat' <- bundleNewPat pat body' <- localScope (scopeOfFParams (map fst val_pats) <> scopeOf loop) . slocal' $ fwdBody body addStm $ Let pat' aux $ DoLoop val_pats' (WhileLoop v) body' fwdStm (Let pat aux (DoLoop val_pats loop@(ForLoop i it bound loop_vars) body)) = do - pat' <- bundleNew pat - val_pats' <- bundleNew val_pats - loop_vars' <- bundleNew loop_vars + pat' <- bundleNewPat pat + val_pats' <- bundleNewList val_pats + loop_vars' <- bundleNewList loop_vars body' <- localScope (scopeOfFParams (map fst val_pats) <> scopeOf loop) . slocal' $ fwdBody body addStm $ Let pat' aux $ DoLoop val_pats' (ForLoop i it bound loop_vars') body' fwdStm (Let pat aux (WithAcc inputs lam)) = do inputs' <- forM inputs $ \(shape, arrs, op) -> do - arrs_tan <- tangent arrs + arrs_tan <- mapM tangent arrs op' <- case op of Nothing -> pure Nothing Just (op_lam, nes) -> do @@ -445,7 +436,7 @@ let op_lam'' = Lambda (removeIndexTans (shapeRank shape) ps) body ret pure $ Just (op_lam'', interleave nes nes_tan) pure (shape, arrs <> arrs_tan, op') - pat' <- bundleNew pat + pat' <- bundleNewPat pat lam' <- fwdLambda lam addStm $ Let pat' aux $ WithAcc inputs' lam' where @@ -459,17 +450,17 @@ fwdBody :: Body SOACS -> ADM (Body SOACS) fwdBody (Body _ stms res) = buildBody_ $ do mapM_ fwdStm stms - bundleTan res + bundleTangents res fwdBodyTansLast :: Body SOACS -> ADM (Body SOACS) fwdBodyTansLast (Body _ stms res) = buildBody_ $ do mapM_ fwdStm stms - (res <>) <$> tangent res + (res <>) <$> mapM tangent res fwdJVP :: MonadFreshNames m => Scope SOACS -> Lambda SOACS -> m (Lambda SOACS) fwdJVP scope l@(Lambda params body ret) = runADM . localScope scope . inScopeOf l $ do - params_tan <- newTan params + params_tan <- mapM newTan params body_tan <- fwdBodyTansLast body - ret_tan <- tangent ret + ret_tan <- mapM tangent ret pure $ Lambda (params ++ params_tan) body_tan (ret <> ret_tan) diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -4,7 +4,6 @@ ( printAction, printAliasesAction, printLastUseGPU, - printLastUseGPUSS, printFusionGraph, printInterferenceGPU, printMemAliasGPU, @@ -55,10 +54,8 @@ import Futhark.IR import Futhark.IR.GPUMem (GPUMem) import Futhark.IR.MCMem (MCMem) -import Futhark.IR.Prop.Aliases import Futhark.IR.SOACS (SOACS) import Futhark.IR.SeqMem (SeqMem) -import Futhark.Optimise.ArrayShortCircuiting.LastUse qualified as LastUseSS import Futhark.Optimise.Fusion.GraphRep qualified import Futhark.Util (runProgramWithExitCode, unixEnvironment) import Futhark.Version (versionString) @@ -77,7 +74,7 @@ } -- | Print the result to stdout, alias annotations. -printAliasesAction :: (ASTRep rep, CanBeAliased (Op rep)) => Action rep +printAliasesAction :: AliasableRep rep => Action rep printAliasesAction = Action { actionName = "Prettyprint", @@ -91,21 +88,12 @@ Action { actionName = "print last use gpu", actionDescription = "Print last use information on gpu.", - actionProcedure = liftIO . putStrLn . prettyString . M.toList . LastUse.analyseGPUMem - } - --- | Print last use information to stdout. -printLastUseGPUSS :: Action GPUMem -printLastUseGPUSS = - Action - { actionName = "print last use ss gpu", - actionDescription = "Print last use ss information on gpu.", actionProcedure = liftIO . putStrLn . prettyString . bimap M.toList (M.toList . fmap M.toList) - . LastUseSS.lastUseGPUMem + . LastUse.lastUseGPUMem . aliasAnalysis } 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 @@ -10,10 +10,12 @@ -- the building blocks do). module Futhark.Analysis.Alias ( aliasAnalysis, + AliasableRep, -- * Ad-hoc utilities analyseFun, analyseStms, + analyseStm, analyseExp, analyseBody, analyseLambda, @@ -26,7 +28,7 @@ -- | Perform alias analysis on a Futhark program. aliasAnalysis :: - (ASTRep rep, CanBeAliased (Op rep)) => + AliasableRep rep => Prog rep -> Prog (Aliases rep) aliasAnalysis prog = @@ -37,7 +39,7 @@ -- | Perform alias analysis on function. analyseFun :: - (ASTRep rep, CanBeAliased (Op rep)) => + AliasableRep rep => FunDef rep -> FunDef (Aliases rep) analyseFun (FunDef entry attrs fname restype params body) = @@ -47,9 +49,7 @@ -- | Perform alias analysis on Body. analyseBody :: - ( ASTRep rep, - CanBeAliased (Op rep) - ) => + AliasableRep rep => AliasTable -> Body rep -> Body (Aliases rep) @@ -59,20 +59,26 @@ -- | Perform alias analysis on statements. analyseStms :: - (ASTRep rep, CanBeAliased (Op rep)) => + AliasableRep rep => AliasTable -> Stms rep -> (Stms (Aliases rep), AliasesAndConsumed) analyseStms orig_aliases = - foldl' f (mempty, (orig_aliases, mempty)) . stmsToList + withoutBound . foldl' f (mempty, (orig_aliases, mempty)) . stmsToList where + withoutBound (stms, (aliases, consumed)) = + let bound = foldMap (namesFromList . patNames . stmPat) stms + consumed' = consumed `namesSubtract` bound + in (stms, (aliases, consumed')) + f (stms, aliases) stm = let stm' = analyseStm (fst aliases) stm atable' = trackAliases aliases stm' in (stms <> oneStm stm', atable') +-- | Perform alias analysis on statement. analyseStm :: - (ASTRep rep, CanBeAliased (Op rep)) => + AliasableRep rep => AliasTable -> Stm rep -> Stm (Aliases rep) @@ -84,7 +90,7 @@ -- | Perform alias analysis on expression. analyseExp :: - (ASTRep rep, CanBeAliased (Op rep)) => + AliasableRep rep => AliasTable -> Exp rep -> Exp (Aliases rep) @@ -124,7 +130,7 @@ -- | Perform alias analysis on lambda. analyseLambda :: - (ASTRep rep, CanBeAliased (Op rep)) => + AliasableRep rep => AliasTable -> Lambda rep -> Lambda (Aliases rep) 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 @@ -66,6 +66,7 @@ ViewL (..), ArrayTransform (..), transformFromExp, + transformToExp, soacToStream, ) where @@ -233,6 +234,22 @@ Just (v, Replicate cs shape) transformFromExp _ _ = Nothing +-- | Turn an array transform on an array back into an expression. +transformToExp :: (Monad m, HasScope rep m) => ArrayTransform -> VName -> m (Certs, Exp rep) +transformToExp (Replicate cs n) ia = + pure (cs, BasicOp $ Futhark.Replicate n (Var ia)) +transformToExp (Rearrange cs perm) ia = do + r <- arrayRank <$> lookupType ia + pure (cs, BasicOp $ Futhark.Rearrange (perm ++ [length perm .. r - 1]) ia) +transformToExp (Reshape cs k shape) ia = do + pure (cs, BasicOp $ Futhark.Reshape k shape ia) +transformToExp (ReshapeOuter cs k shape) ia = do + shape' <- reshapeOuter shape 1 . arrayShape <$> lookupType ia + pure (cs, BasicOp $ Futhark.Reshape k shape' ia) +transformToExp (ReshapeInner cs k shape) ia = do + shape' <- reshapeInner shape 1 . arrayShape <$> lookupType ia + pure (cs, BasicOp $ Futhark.Reshape k shape' ia) + -- | One array input to a SOAC - a SOAC may have multiple inputs, but -- all are of this form. Only the array inputs are expressed with -- this type; other arguments, such as initial accumulator values, are @@ -285,24 +302,16 @@ 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 (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 k shape) ia = - certifying cs . letExp "reshape" . BasicOp $ - Futhark.Reshape k shape ia -applyTransform (ReshapeOuter cs k shape) ia = do - shape' <- reshapeOuter shape 1 . arrayShape <$> lookupType ia - certifying cs . letExp "reshape_outer" . BasicOp $ - Futhark.Reshape k shape' ia -applyTransform (ReshapeInner cs k shape) ia = do - shape' <- reshapeInner shape 1 . arrayShape <$> lookupType ia - certifying cs . letExp "reshape_inner" . BasicOp $ - Futhark.Reshape k shape' ia +applyTransform tr ia = do + (cs, e) <- transformToExp tr ia + certifying cs $ letExp s e + where + s = case tr of + Replicate {} -> "replicate" + Rearrange {} -> "rearrange" + Reshape {} -> "reshape" + ReshapeOuter {} -> "reshape_outer" + ReshapeInner {} -> "reshape_inner" applyTransforms :: MonadBuilder m => ArrayTransforms -> VName -> m VName applyTransforms (ArrayTransforms ts) a = foldlM (flip applyTransform) a ts 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 @@ -12,7 +12,8 @@ import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Set (Set) import Data.Set qualified as S -import Futhark.Analysis.LastUse (LastUseMap) +import Futhark.Analysis.Alias qualified as AnlAls +import Futhark.Analysis.LastUse (LUTabFun) import Futhark.Analysis.LastUse qualified as LastUse import Futhark.Analysis.MemAlias qualified as MemAlias import Futhark.IR.GPUMem @@ -39,7 +40,7 @@ analyseStm :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> Stm GPUMem -> m (InUse, LastUsed, Graph VName) @@ -103,7 +104,7 @@ analyseExp :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> Exp GPUMem -> m (InUse, LastUsed, Graph VName) @@ -122,7 +123,7 @@ analyseKernelBody :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> KernelBody GPUMem -> m (InUse, LastUsed, Graph VName) @@ -130,7 +131,7 @@ analyseBody :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> Body GPUMem -> m (InUse, LastUsed, Graph VName) @@ -138,7 +139,7 @@ analyseStms :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> Stms GPUMem -> m (InUse, LastUsed, Graph VName) @@ -151,7 +152,7 @@ analyseSegOp :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> SegOp lvl GPUMem -> m (InUse, LastUsed, Graph VName) @@ -168,7 +169,7 @@ segWithBinOps :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> [SegBinOp GPUMem] -> KernelBody GPUMem -> @@ -184,7 +185,7 @@ analyseSegBinOp :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> SegBinOp GPUMem -> m (InUse, LastUsed, Graph VName) @@ -193,7 +194,7 @@ analyseHistOp :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> HistOp GPUMem -> m (InUse, LastUsed, Graph VName) @@ -202,7 +203,7 @@ analyseLambda :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> InUse -> Lambda GPUMem -> m (InUse, LastUsed, Graph VName) @@ -213,14 +214,14 @@ analyseProgGPU prog = onConsts (progConsts prog) <> foldMap onFun (progFuns prog) where (consts_aliases, funs_aliases) = MemAlias.analyzeGPUMem prog - lumap = LastUse.analyseGPUMem prog + (lumap_consts, lumap) = LastUse.lastUseGPUMem $ AnlAls.aliasAnalysis prog onFun f = applyAliases (fromMaybe mempty $ M.lookup (funDefName f) funs_aliases) $ - runReader (analyseGPU lumap $ bodyStms $ funDefBody f) $ + runReader (analyseGPU (lumap M.! funDefName f) $ bodyStms $ funDefBody f) $ scopeOf f onConsts stms = applyAliases consts_aliases $ - runReader (analyseGPU lumap stms) (mempty :: Scope GPUMem) + runReader (analyseGPU lumap_consts stms) (mempty :: Scope GPUMem) applyAliases :: MemAlias.MemAliases -> Graph VName -> Graph VName applyAliases aliases = @@ -237,7 +238,7 @@ -- within, and the resulting graph. analyseGPU :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> Stms GPUMem -> m (Graph VName) analyseGPU lumap stms = do @@ -304,7 +305,7 @@ analyseGPU' :: LocalScope GPUMem m => - LastUseMap -> + LUTabFun -> Stms GPUMem -> m (InUse, LastUsed, Graph VName) analyseGPU' lumap stms = 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 @@ -1,240 +1,445 @@ {-# LANGUAGE TypeFamilies #-} --- | Provides last-use analysis for Futhark programs. +-- | Last use analysis for array short circuiting +-- +-- Last-Use analysis of a Futhark program in aliased explicit-memory lore form. +-- Takes as input such a program or a function and produces a 'M.Map VName +-- Names', in which the key identified the let stmt, and the list argument +-- identifies the variables that were lastly used in that stmt. Note that the +-- results of a body do not have a last use, and neither do a function +-- parameters if it happens to not be used inside function's body. Such cases +-- are supposed to be treated separately. module Futhark.Analysis.LastUse - ( LastUseMap, - LastUse, - Used, - analyseGPUMem, - analyseSeqMem, + ( lastUseSeqMem, + lastUseGPUMem, + lastUseMCMem, + LUTabFun, + LUTabProg, ) where import Control.Monad.Reader -import Data.Bifunctor (bimap, first) +import Control.Monad.State.Strict +import Data.Bifunctor (bimap) import Data.Function ((&)) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Tuple -import Futhark.Analysis.Alias (aliasAnalysis) +import Data.Map.Strict qualified as M +import Data.Maybe +import Data.Sequence (Seq (..)) import Futhark.IR.Aliases import Futhark.IR.GPUMem +import Futhark.IR.GPUMem qualified as GPU +import Futhark.IR.MCMem +import Futhark.IR.MCMem qualified as MC import Futhark.IR.SeqMem +import Futhark.Optimise.ArrayShortCircuiting.DataStructs +import Futhark.Util --- | '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 +-- | Maps a name indentifying a Stm to the last uses in that Stm. +type LUTabFun = M.Map VName Names --- | '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 +-- | LU-table for the constants, and for each function. +type LUTabProg = (LUTabFun, M.Map Name LUTabFun) --- | 'Used' is the set of 'VName' that were used somewhere in a --- statement, body or otherwise. -type Used = Names +type LastUseOp rep = Op (Aliases rep) -> Names -> LastUseM rep (LUTabFun, Names, Names) -type LastUseOp rep = - VName -> (LastUse, Used) -> Op (Aliases rep) -> LastUseM rep +-- | 'LastUseReader' allows us to abstract over representations by supplying the +-- 'onOp' function. +data LastUseReader rep = LastUseReader + { onOp :: LastUseOp rep, + scope :: Scope (Aliases rep) + } -newtype Env rep = Env {envLastUseOp :: LastUseOp rep} +-- | Maps a variable or memory block to its aliases. +type AliasTab = M.Map VName Names -type LastUseM rep = Reader (Env rep) (LastUse, Used) +newtype LastUseM rep a = LastUseM (StateT AliasTab (Reader (LastUseReader rep)) a) + deriving + ( Monad, + Functor, + Applicative, + MonadReader (LastUseReader rep), + MonadState AliasTab + ) -analyseGPUMem :: Prog GPUMem -> LastUseMap -analyseGPUMem = analyseProg analyseGPUOp +instance RepTypes (Aliases rep) => HasScope (Aliases rep) (LastUseM rep) where + askScope = asks scope -analyseSeqMem :: Prog SeqMem -> LastUseMap -analyseSeqMem = analyseProg analyseSeqOp +instance RepTypes (Aliases rep) => LocalScope (Aliases rep) (LastUseM rep) where + localScope sc (LastUseM m) = LastUseM $ do + local (\rd -> rd {scope = scope rd <> sc}) m -analyseGPUOp :: LastUseOp GPUMem -analyseGPUOp pat_name (lumap, used) (Alloc se sp) = do - let nms = (freeIn se <> freeIn sp) `namesSubtract` used - pure (insertNames pat_name nms lumap, used <> nms) -analyseGPUOp pat_name (lumap, used) (Inner (SizeOp sop)) = do - let nms = freeIn sop `namesSubtract` used - pure (insertNames pat_name nms lumap, used <> nms) -analyseGPUOp _ (lumap, used) (Inner (OtherOp ())) = - pure (lumap, used) -analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegMap lvl _ tps body))) = do - (lumap', used') <- analyseKernelBody (lumap, used) body - let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used' - pure (insertNames pat_name nms lumap', used' <> nms) -analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegRed lvl _ binops tps body))) = - segOpHelper pat_name lumap used lvl binops tps body -analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegScan lvl _ binops tps body))) = - segOpHelper pat_name lumap used lvl binops tps body -analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegHist lvl _ binops tps body))) = do - (lumap', used') <- foldM analyseHistOp (lumap, used) $ reverse binops - (lumap'', used'') <- analyseKernelBody (lumap', used') body - let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used'' - pure (insertNames pat_name nms lumap'', used'' <> nms) -analyseGPUOp pat_name (lumap, used) (Inner (GPUBody ts body)) = do - (lumap', used') <- analyseBody lumap used body - let nms = freeIn ts - pure (insertNames pat_name nms lumap', used' <> nms) +type Constraints rep = + ( LocalScope (Aliases rep) (LastUseM rep), + HasMemBlock (Aliases rep), + AliasableRep rep + ) -segOpHelper :: - (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => - VName -> - LastUse -> - Used -> - SegLevel -> - [SegBinOp (Aliases rep)] -> - [Type] -> +runLastUseM :: LastUseOp rep -> LastUseM rep a -> a +runLastUseM onOp (LastUseM m) = + runReader (evalStateT m mempty) (LastUseReader onOp mempty) + +aliasLookup :: VName -> LastUseM rep Names +aliasLookup vname = + gets $ fromMaybe mempty . M.lookup vname + +lastUseProg :: + Constraints rep => + Prog (Aliases rep) -> + LastUseM rep LUTabProg +lastUseProg prog = + let bound_in_consts = + progConsts prog + & concatMap (patNames . stmPat) + & namesFromList + consts = progConsts prog + funs = progFuns prog + in inScopeOf consts $ do + (consts_lu, _) <- lastUseStms consts mempty mempty + lus <- mapM (lastUseFun bound_in_consts) funs + pure (consts_lu, M.fromList $ zip (map funDefName funs) lus) + +lastUseFun :: + Constraints rep => + Names -> + FunDef (Aliases rep) -> + LastUseM rep LUTabFun +lastUseFun bound_in_consts f = + inScopeOf f $ fst <$> lastUseBody (funDefBody f) (mempty, bound_in_consts) + +-- | Perform last-use analysis on a 'Prog' in 'SeqMem' +lastUseSeqMem :: Prog (Aliases SeqMem) -> LUTabProg +lastUseSeqMem = runLastUseM lastUseSeqOp . lastUseProg + +-- | Perform last-use analysis on a 'Prog' in 'GPUMem' +lastUseGPUMem :: Prog (Aliases GPUMem) -> LUTabProg +lastUseGPUMem = runLastUseM (lastUseMemOp lastUseGPUOp) . lastUseProg + +-- | Perform last-use analysis on a 'Prog' in 'MCMem' +lastUseMCMem :: Prog (Aliases MCMem) -> LUTabProg +lastUseMCMem = runLastUseM (lastUseMemOp lastUseMCOp) . lastUseProg + +-- | Performing the last-use analysis on a body. +-- +-- The implementation consists of a bottom-up traversal of the body's statements +-- in which the the variables lastly used in a statement are computed as the +-- difference between the free-variables in that stmt and the set of variables +-- known to be used after that statement. +lastUseBody :: + Constraints rep => + -- | The body of statements + Body (Aliases rep) -> + -- | The current last-use table, tupled with the known set of already used names + (LUTabFun, Names) -> + -- | The result is: + -- (i) an updated last-use table, + -- (ii) an updated set of used names (including the binding). + LastUseM rep (LUTabFun, Names) +lastUseBody bdy@(Body _ stms result) (lutab, used_nms) = + -- perform analysis bottom-up in bindings: results are known to be used, + -- hence they are added to the used_nms set. + inScopeOf stms $ do + (lutab', _) <- + lastUseStms stms (lutab, used_nms) $ + namesToList $ + freeIn $ + map resSubExp result + -- Clean up the used names by recomputing the aliasing transitive-closure + -- of the free names in body based on the current alias table @alstab@. + used_in_body <- aliasTransitiveClosure $ freeIn bdy + pure (lutab', used_nms <> used_in_body) + +-- | Performing the last-use analysis on a body. +-- +-- The implementation consists of a bottom-up traversal of the body's statements +-- in which the the variables lastly used in a statement are computed as the +-- difference between the free-variables in that stmt and the set of variables +-- known to be used after that statement. +lastUseKernelBody :: + Constraints rep => + -- | The body of statements KernelBody (Aliases rep) -> - LastUseM rep -segOpHelper pat_name lumap used lvl binops tps body = do - (lumap', used') <- foldM analyseSegBinOp (lumap, used) $ reverse binops - (lumap'', used'') <- analyseKernelBody (lumap', used') body - let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used'' - pure (insertNames pat_name nms lumap'', used'' <> nms) + -- | The current last-use table, tupled with the known set of already used names + (LUTabFun, Names) -> + -- | The result is: + -- (i) an updated last-use table, + -- (ii) an updated set of used names (including the binding). + LastUseM rep (LUTabFun, Names) +lastUseKernelBody bdy@(KernelBody _ stms result) (lutab, used_nms) = + inScopeOf stms $ do + -- perform analysis bottom-up in bindings: results are known to be used, + -- hence they are added to the used_nms set. + (lutab', _) <- + lastUseStms stms (lutab, used_nms) $ namesToList $ freeIn result + -- Clean up the used names by recomputing the aliasing transitive-closure + -- of the free names in body based on the current alias table @alstab@. + used_in_body <- aliasTransitiveClosure $ freeIn bdy + pure (lutab', used_nms <> used_in_body) -analyseSeqOp :: LastUseOp SeqMem -analyseSeqOp pat_name (lumap, used) (Alloc se sp) = do - let nms = (freeIn se <> freeIn sp) `namesSubtract` used - pure (insertNames pat_name nms lumap, used <> nms) -analyseSeqOp _ (lumap, used) (Inner ()) = - pure (lumap, used) +lastUseStms :: + Constraints rep => + Stms (Aliases rep) -> + (LUTabFun, Names) -> + [VName] -> + LastUseM rep (LUTabFun, Names) +lastUseStms Empty (lutab, nms) res_nms = do + aliases <- concatMapM aliasLookup res_nms + pure (lutab, nms <> aliases <> namesFromList res_nms) +lastUseStms (stm@(Let pat _ e) :<| stms) (lutab, nms) res_nms = + inScopeOf stm $ do + let extra_alias = case e of + BasicOp (Update _ old _ _) -> oneName old + BasicOp (FlatUpdate old _ _) -> oneName old + _ -> mempty + -- We build up aliases top-down + updateAliasing extra_alias pat + -- But compute last use bottom-up + (lutab', nms') <- lastUseStms stms (lutab, nms) res_nms + (lutab'', nms'') <- lastUseStm stm (lutab', nms') + pure (lutab'', nms'') --- | Analyses a program to return a last-use map, mapping each simple statement --- in the program to the values that were last used within that statement, and --- the set of all `VName` that were used inside. -analyseProg :: (CanBeAliased (Op rep), Mem rep inner) => LastUseOp rep -> Prog rep -> LastUseMap -analyseProg onOp prog = - runReader helper (Env onOp) - where - helper = do - let bound_in_consts = - progConsts prog - & concatMap (patNames . stmPat) - & namesFromList - prog_alias = aliasAnalysis prog - consts = progConsts prog_alias - funs = progFuns prog_alias - (consts_lu, _) <- analyseStms mempty mempty consts - (lus, _) <- mconcat <$> mapM (analyseFun mempty bound_in_consts) funs - pure $ flipMap $ consts_lu <> lus +lastUseStm :: + Constraints rep => + Stm (Aliases rep) -> + (LUTabFun, Names) -> + LastUseM rep (LUTabFun, Names) +lastUseStm (Let pat _ e) (lutab, used_nms) = do + -- analyse the expression and get the + -- (i) a new last-use table (in case the @e@ contains bodies of stmts) + -- (ii) the set of variables lastly used in the current binding. + -- (iii) aliased transitive-closure of used names, and + (lutab', last_uses, used_nms') <- lastUseExp e used_nms + sc <- asks scope + let lu_mems = + namesToList last_uses + & mapMaybe (`getScopeMemInfo` sc) + & map memName + & namesFromList + & flip namesSubtract used_nms -analyseFun :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> FunDef (Aliases rep) -> LastUseM rep -analyseFun lumap used fun = do - (lumap', used') <- analyseBody lumap used $ funDefBody fun - pure (lumap', used' <> freeIn (funDefParams fun)) + -- filter-out the binded names from the set of used variables, + -- since they go out of scope, and update the last-use table. + let patnms = patNames pat + used_nms'' = used_nms' `namesSubtract` namesFromList patnms + lutab'' = + M.union lutab' $ M.insert (head patnms) (last_uses <> lu_mems) lutab + pure (lutab'', used_nms'') -analyseStms :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> Stms (Aliases rep) -> LastUseM rep -analyseStms lumap used stms = foldM analyseStm (lumap, used) $ reverse $ stmsToList stms +-------------------------------- -analyseStm :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => (LastUse, Used) -> Stm (Aliases rep) -> LastUseM rep -analyseStm (lumap0, used0) (Let pat _ e) = do - let (lumap', used') = patElems pat & foldl helper (lumap0, used0) - analyseExp (lumap', used') e +-- | Last-Use Analysis for an expression. +lastUseExp :: + Constraints rep => + -- | The expression to analyse + Exp (Aliases rep) -> + -- | The set of used names "after" this expression + Names -> + -- | Result: + -- 1. an extra LUTab recording the last use for expression's inner bodies, + -- 2. the set of last-used vars in the expression at this level, + -- 3. the updated used names, now including expression's free vars. + LastUseM rep (LUTabFun, Names, Names) +lastUseExp (Match _ cases body _) used_nms = do + -- For an if-then-else, we duplicate the last use at each body level, meaning + -- we record the last use of the outer statement, and also the last use in the + -- statement in the inner bodies. We can safely ignore the if-condition as it is + -- a boolean scalar. + (lutab_cases, used_cases) <- + bimap mconcat mconcat . unzip + <$> mapM (flip lastUseBody (M.empty, used_nms) . caseBody) cases + (lutab', body_used_nms) <- lastUseBody body (M.empty, used_nms) + let free_in_body = freeIn body + let free_in_cases = freeIn cases + let used_nms' = used_cases <> body_used_nms + (_, last_used_arrs) <- lastUsedInNames used_nms $ free_in_body <> free_in_cases + pure (lutab_cases <> lutab', last_used_arrs, used_nms') +lastUseExp (DoLoop var_ses lf body) used_nms0 = inScopeOf lf $ do + free_in_body <- aliasTransitiveClosure $ freeIn body + -- compute the aliasing transitive closure of initializers that are not last-uses + var_inis <- catMaybes <$> mapM (initHelper (free_in_body <> used_nms0)) var_ses + let -- To record last-uses inside the loop body, we call 'lastUseBody' with used-names + -- being: (free_in_body - loop-variants-a) + used_nms0. As such we disable cases b) + -- and c) to produce loop-variant last uses inside the loop, and also we prevent + -- the free-loop-variables to having last uses inside the loop. + free_in_body' = free_in_body `namesSubtract` namesFromList (map fst var_inis) + used_nms = used_nms0 <> free_in_body' <> freeIn (bodyResult body) + (body_lutab, _) <- lastUseBody body (mempty, used_nms) + + -- add var_inis_a to the body_lutab, i.e., record the last-use of + -- initializer in the corresponding loop variant. + let lutab_res = body_lutab <> M.fromList var_inis + + -- the result used names are: + fpar_nms = namesFromList $ map (identName . paramIdent . fst) var_ses + used_nms' = (free_in_body <> freeIn (map snd var_ses)) `namesSubtract` fpar_nms + used_nms_res = used_nms0 <> used_nms' <> freeIn (bodyResult body) + + -- the last-uses at loop-statement level are the loop free variables that + -- do not belong to @used_nms0@; this includes the initializers of b), @lu_ini_b@ + lu_arrs = used_nms' `namesSubtract` used_nms0 + pure (lutab_res, lu_arrs, used_nms_res) where - helper (lumap_acc, used_acc) (PatElem name (aliases, _)) = - -- Any aliases of `name` should have the same last-use as `name` - ( case M.lookup name lumap_acc of - Just name' -> - insertNames name' (unAliases aliases) lumap_acc - Nothing -> lumap_acc, - used_acc <> unAliases aliases - ) + initHelper free_and_used (fp, se) = do + names <- aliasTransitiveClosure $ maybe mempty oneName $ subExpVar se + if names `namesIntersect` free_and_used + then pure Nothing + else pure $ Just (identName $ paramIdent fp, names) +lastUseExp (Op op) used_nms = do + on_op <- reader onOp + on_op op used_nms +lastUseExp e used_nms = do + let free_in_e = freeIn e + (used_nms', lu_vars) <- lastUsedInNames used_nms free_in_e + pure (M.empty, lu_vars, used_nms') - addAliasesFromBodyRes (lumap_acc, used_acc) (PatElem {}, Constant _) = (lumap_acc, used_acc) - addAliasesFromBodyRes (lumap_acc, used_acc) (PatElem name _, Var body_res) = - -- Any aliases of `name` should have the same last-use as `name` - ( case M.lookup name lumap_acc of - Just name' -> - insertNames name' (oneName body_res) lumap_acc - Nothing -> lumap_acc, - used_acc <> oneName body_res - ) +lastUseMemOp :: + (inner (Aliases rep) -> Names -> LastUseM rep (LUTabFun, Names, Names)) -> + MemOp inner (Aliases rep) -> + Names -> + LastUseM rep (LUTabFun, Names, Names) +lastUseMemOp _ (Alloc se sp) used_nms = do + let free_in_e = freeIn se <> freeIn sp + (used_nms', lu_vars) <- lastUsedInNames used_nms free_in_e + pure (M.empty, lu_vars, used_nms') +lastUseMemOp onInner (Inner op) used_nms = onInner op used_nms - pat_name = patElemName $ head $ patElems pat +lastUseSegOp :: + Constraints rep => + SegOp lvl (Aliases rep) -> + Names -> + LastUseM rep (LUTabFun, Names, Names) +lastUseSegOp (SegMap _ _ tps kbody) used_nms = do + (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn tps + (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') + pure (body_lutab, lu_vars, used_nms' <> used_nms'') +lastUseSegOp (SegRed _ _ sbos tps kbody) used_nms = do + (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseSegBinOp sbos used_nms + (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps + (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') + pure (M.union lutab_sbo body_lutab, lu_vars <> lu_vars_sbo, used_nms_sbo <> used_nms' <> used_nms'') +lastUseSegOp (SegScan _ _ sbos tps kbody) used_nms = do + (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseSegBinOp sbos used_nms + (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps + (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') + pure (M.union lutab_sbo body_lutab, lu_vars <> lu_vars_sbo, used_nms_sbo <> used_nms' <> used_nms'') +lastUseSegOp (SegHist _ _ hos tps kbody) used_nms = do + (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseHistOp hos used_nms + (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps + (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') + pure (M.union lutab_sbo body_lutab, lu_vars <> lu_vars_sbo, used_nms_sbo <> used_nms' <> used_nms'') - analyseExp (lumap, used) (BasicOp _) = do - let nms = freeIn e `namesSubtract` used - pure (insertNames pat_name nms lumap, used <> nms) - analyseExp (lumap, used) (Apply _ args _ _) = do - let nms = freeIn $ map fst args - pure (insertNames pat_name nms lumap, used <> nms) - analyseExp (lumap, used) (Match ses cases defbody dec) = do - (lumap_cases, used_cases) <- - bimap mconcat mconcat . unzip - <$> mapM (analyseBody lumap used . caseBody) cases - (lumap_defbody, used_defbody) <- analyseBody lumap used defbody - let (lumap', used') = - (lumap_defbody <> lumap_cases, used_cases <> used_defbody) - & flip (foldl addAliasesFromBodyRes) (zip (patElems pat) (map resSubExp $ bodyResult defbody)) - nms = (freeIn ses <> freeIn dec) `namesSubtract` used' - pure - ( insertNames pat_name nms lumap', - used' <> nms - ) - analyseExp (lumap, used) (DoLoop merge form body) = do - let (lumap', used') = - zip (patElems pat) (map resSubExp $ bodyResult body) - & foldl addAliasesFromBodyRes (lumap, used) - (lumap'', used'') <- analyseBody lumap' used' body - let nms = (freeIn merge <> freeIn form) `namesSubtract` used'' - pure (insertNames pat_name nms lumap'', used'' <> nms) - analyseExp (lumap, used) (Op op) = do - onOp <- asks envLastUseOp - onOp pat_name (lumap, used) op - analyseExp (lumap, used) (WithAcc _ l) = - analyseLambda (lumap, used) l +lastUseGPUOp :: HostOp NoOp (Aliases GPUMem) -> Names -> LastUseM GPUMem (LUTabFun, Names, Names) +lastUseGPUOp (GPU.OtherOp NoOp) used_nms = + pure (mempty, mempty, used_nms) +lastUseGPUOp (SizeOp sop) used_nms = do + (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn sop + pure (mempty, lu_vars, used_nms') +lastUseGPUOp (GPUBody tps body) used_nms = do + (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn tps + (body_lutab, used_nms'') <- lastUseBody body (mempty, used_nms') + pure (body_lutab, lu_vars, used_nms' <> used_nms'') +lastUseGPUOp (SegOp op) used_nms = + lastUseSegOp op used_nms -analyseBody :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> Body (Aliases rep) -> LastUseM rep -analyseBody lumap used (Body _ stms result) = do - let used' = used <> freeIn result - analyseStms lumap used' stms +lastUseMCOp :: MCOp NoOp (Aliases MCMem) -> Names -> LastUseM MCMem (LUTabFun, Names, Names) +lastUseMCOp (MC.OtherOp NoOp) used_nms = + pure (mempty, mempty, used_nms) +lastUseMCOp (MC.ParOp par_op op) used_nms = do + (lutab_par_op, lu_vars_par_op, used_names_par_op) <- + maybe (pure mempty) (`lastUseSegOp` used_nms) par_op + (lutab_op, lu_vars_op, used_names_op) <- + lastUseSegOp op used_nms + pure + ( lutab_par_op <> lutab_op, + lu_vars_par_op <> lu_vars_op, + used_names_par_op <> used_names_op + ) -analyseKernelBody :: - (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => - (LastUse, Used) -> - KernelBody (Aliases rep) -> - LastUseM rep -analyseKernelBody (lumap, used) (KernelBody _ stms result) = - let used' = used <> freeIn result - in analyseStms lumap used' stms +lastUseSegBinOp :: + Constraints rep => + [SegBinOp (Aliases rep)] -> + Names -> + LastUseM rep (LUTabFun, Names, Names) +lastUseSegBinOp sbos used_nms = do + (lutab, lu_vars, used_nms') <- unzip3 <$> mapM helper sbos + pure (mconcat lutab, mconcat lu_vars, mconcat used_nms') + where + helper (SegBinOp _ l@(Lambda _ body _) neutral shp) = inScopeOf l $ do + (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn neutral <> freeIn shp + (body_lutab, used_nms'') <- lastUseBody body (mempty, used_nms') + pure (body_lutab, lu_vars, used_nms'') -analyseSegBinOp :: - (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => - (LastUse, Used) -> - SegBinOp (Aliases rep) -> - LastUseM rep -analyseSegBinOp (lumap, used) (SegBinOp _ lambda neutral shp) = do - (lumap', used') <- analyseLambda (lumap, used) lambda - let nms = (freeIn neutral <> freeIn shp) `namesSubtract` used' - pure (lumap', used' <> nms) +lastUseHistOp :: + Constraints rep => + [HistOp (Aliases rep)] -> + Names -> + LastUseM rep (LUTabFun, Names, Names) +lastUseHistOp hos used_nms = do + (lutab, lu_vars, used_nms') <- unzip3 <$> mapM helper hos + pure (mconcat lutab, mconcat lu_vars, mconcat used_nms') + where + helper (HistOp shp rf dest neutral shp' l@(Lambda _ body _)) = inScopeOf l $ do + (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn shp <> freeIn rf <> freeIn dest <> freeIn neutral <> freeIn shp' + (body_lutab, used_nms'') <- lastUseBody body (mempty, used_nms') + pure (body_lutab, lu_vars, used_nms'') -analyseHistOp :: - (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => - (LastUse, Used) -> - HistOp (Aliases rep) -> - LastUseM rep -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 shp - ) - `namesSubtract` used' - pure (lumap', used' <> nms) +lastUseSeqOp :: Op (Aliases SeqMem) -> Names -> LastUseM SeqMem (LUTabFun, Names, Names) +lastUseSeqOp (Alloc se sp) used_nms = do + let free_in_e = freeIn se <> freeIn sp + (used_nms', lu_vars) <- lastUsedInNames used_nms free_in_e + pure (mempty, lu_vars, used_nms') +lastUseSeqOp (Inner NoOp) used_nms = do + pure (mempty, mempty, used_nms) -analyseLambda :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => (LastUse, Used) -> Lambda (Aliases rep) -> LastUseM rep -analyseLambda (lumap, used) (Lambda params body ret) = do - (lumap', used') <- analyseBody lumap used body - let used'' = used' <> freeIn params <> freeIn ret - pure (lumap', used'') +------------------------------------------------------ -flipMap :: Map VName VName -> Map VName Names -flipMap m = - M.toList m - & fmap (swap . first oneName) - & foldr (uncurry $ M.insertWith (<>)) mempty +-- | Given already used names and newly encountered 'Names', return an updated +-- set used names and the set of names that were last used here. +-- +-- For a given name @x@ in the new uses, if neither @x@ nor any of its aliases +-- are present in the set of used names, this is a last use of @x@. +lastUsedInNames :: + -- | Used names + Names -> + -- | New uses + Names -> + LastUseM rep (Names, Names) +lastUsedInNames used_nms new_uses = do + -- a use of an argument x is also a use of any variable in x alias set + -- so we update the alias-based transitive-closure of used names. + new_uses_with_aliases <- aliasTransitiveClosure new_uses + -- if neither a variable x, nor any of its alias set have been used before (in + -- the backward traversal), then it is a last use of both that variable and + -- all other variables in its alias set + last_uses <- filterM isLastUse $ namesToList new_uses + last_uses' <- aliasTransitiveClosure $ namesFromList last_uses + pure (used_nms <> new_uses_with_aliases, last_uses') + where + isLastUse x = do + with_aliases <- aliasTransitiveClosure $ oneName x + pure $ not $ with_aliases `namesIntersect` used_nms -insertNames :: VName -> Names -> LastUse -> LastUse -insertNames name names lumap = - foldr (flip (M.insertWith $ \_ x -> x) name) lumap $ namesToList names +-- | Compute the transitive closure of the aliases of a set of 'Names'. +aliasTransitiveClosure :: Names -> LastUseM rep Names +aliasTransitiveClosure args = do + res <- foldl (<>) args <$> mapM aliasLookup (namesToList args) + if res == args + then pure res + else aliasTransitiveClosure res + +-- | For each 'PatElem' in the 'Pat', add its aliases to the 'AliasTab' in +-- 'LastUseM'. Additionally, 'Names' are added as aliases of all the 'PatElemT'. +updateAliasing :: + AliasesOf dec => + -- | Extra names that all 'PatElem' should alias. + Names -> + -- | Pattern to process + Pat dec -> + LastUseM rep () +updateAliasing extra_aliases = + mapM_ update . patElems + where + update :: AliasesOf dec => PatElem dec -> LastUseM rep () + update (PatElem name dec) = do + let aliases = aliasesOf dec + aliases' <- aliasTransitiveClosure $ extra_aliases <> aliases + modify $ M.insert name aliases' diff --git a/src/Futhark/Analysis/MemAlias.hs b/src/Futhark/Analysis/MemAlias.hs --- a/src/Futhark/Analysis/MemAlias.hs +++ b/src/Futhark/Analysis/MemAlias.hs @@ -64,7 +64,7 @@ type MemAliasesM inner a = Reader (Env inner) a -analyzeHostOp :: MemAliases -> HostOp GPUMem () -> MemAliasesM (HostOp GPUMem ()) MemAliases +analyzeHostOp :: MemAliases -> HostOp NoOp GPUMem -> MemAliasesM (HostOp NoOp GPUMem) MemAliases analyzeHostOp m (SegOp (SegMap _ _ _ kbody)) = analyzeStms (kernelBodyStms kbody) m analyzeHostOp m (SegOp (SegRed _ _ _ _ kbody)) = @@ -75,9 +75,13 @@ analyzeStms (kernelBodyStms kbody) m analyzeHostOp m SizeOp {} = pure m analyzeHostOp m GPUBody {} = pure m -analyzeHostOp m (OtherOp ()) = pure m +analyzeHostOp m (OtherOp NoOp) = pure m -analyzeStm :: (Mem rep inner, LetDec rep ~ LetDecMem) => MemAliases -> Stm rep -> MemAliasesM inner MemAliases +analyzeStm :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + MemAliases -> + Stm rep -> + MemAliasesM (inner rep) MemAliases analyzeStm m (Let (Pat [PatElem vname _]) _ (Op (Alloc _ _))) = pure $ m <> singleton vname mempty analyzeStm m (Let _ _ (Op (Inner inner))) = do @@ -110,11 +114,18 @@ filterFun m' (v, Var v') | v' `isIn` m' = Just (v, v') filterFun _ _ = Nothing -analyzeStms :: (Mem rep inner, LetDec rep ~ LetDecMem) => Stms rep -> MemAliases -> MemAliasesM inner MemAliases +analyzeStms :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + Stms rep -> + MemAliases -> + MemAliasesM (inner rep) MemAliases analyzeStms = flip $ foldM analyzeStm -analyzeFun :: (Mem rep inner, LetDec rep ~ LetDecMem) => FunDef rep -> MemAliasesM inner (Name, MemAliases) +analyzeFun :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + FunDef rep -> + MemAliasesM (inner rep) (Name, MemAliases) analyzeFun f = funDefParams f & mapMaybe justMem @@ -144,7 +155,10 @@ analyzeGPUMem :: Prog GPUMem -> (MemAliases, M.Map Name MemAliases) analyzeGPUMem prog = completeBijection $ runReader (analyze prog) $ Env analyzeHostOp -analyze :: (Mem rep inner, LetDec rep ~ LetDecMem) => Prog rep -> MemAliasesM inner (MemAliases, M.Map Name MemAliases) +analyze :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + Prog rep -> + MemAliasesM (inner rep) (MemAliases, M.Map Name MemAliases) analyze prog = (,) <$> (progConsts prog & flip analyzeStms mempty <&> fixPoint transitiveClosure) diff --git a/src/Futhark/Analysis/Metrics.hs b/src/Futhark/Analysis/Metrics.hs --- a/src/Futhark/Analysis/Metrics.hs +++ b/src/Futhark/Analysis/Metrics.hs @@ -32,8 +32,8 @@ opMetrics Nothing = pure () opMetrics (Just x) = opMetrics x -instance OpMetrics () where - opMetrics () = pure () +instance OpMetrics (NoOp rep) where + opMetrics NoOp = pure () newtype CountMetrics = CountMetrics [([Text], Text)] diff --git a/src/Futhark/Analysis/Rephrase.hs b/src/Futhark/Analysis/Rephrase.hs deleted file mode 100644 --- a/src/Futhark/Analysis/Rephrase.hs +++ /dev/null @@ -1,103 +0,0 @@ --- | Facilities for changing the rep of some fragment, with no --- context. We call this "rephrasing", for no deep reason. -module Futhark.Analysis.Rephrase - ( rephraseProg, - rephraseFunDef, - rephraseExp, - rephraseBody, - rephraseStm, - rephraseLambda, - rephrasePat, - rephrasePatElem, - Rephraser (..), - ) -where - -import Futhark.IR - --- | A collection of functions that together allow us to rephrase some --- IR fragment, in some monad @m@. If we let @m@ be the 'Maybe' --- monad, we can conveniently do rephrasing that might fail. This is --- useful if you want to see if some IR in e.g. the @Kernels@ rep --- actually uses any @Kernels@-specific operations. -data Rephraser m from to = Rephraser - { rephraseExpDec :: ExpDec from -> m (ExpDec to), - rephraseLetBoundDec :: LetDec from -> m (LetDec to), - rephraseFParamDec :: FParamInfo from -> m (FParamInfo to), - rephraseLParamDec :: LParamInfo from -> m (LParamInfo to), - rephraseBodyDec :: BodyDec from -> m (BodyDec to), - rephraseRetType :: RetType from -> m (RetType to), - rephraseBranchType :: BranchType from -> m (BranchType to), - rephraseOp :: Op from -> m (Op to) - } - --- | Rephrase an entire program. -rephraseProg :: Monad m => Rephraser m from to -> Prog from -> m (Prog to) -rephraseProg rephraser prog = do - consts <- mapM (rephraseStm rephraser) (progConsts prog) - funs <- mapM (rephraseFunDef rephraser) (progFuns prog) - pure $ prog {progConsts = consts, progFuns = funs} - --- | Rephrase a function definition. -rephraseFunDef :: Monad m => Rephraser m from to -> FunDef from -> m (FunDef to) -rephraseFunDef rephraser fundec = do - body' <- rephraseBody rephraser $ funDefBody fundec - params' <- mapM (rephraseParam $ rephraseFParamDec rephraser) $ funDefParams fundec - rettype' <- mapM (rephraseRetType rephraser) $ funDefRetType fundec - pure fundec {funDefBody = body', funDefParams = params', funDefRetType = rettype'} - --- | Rephrase an expression. -rephraseExp :: Monad m => Rephraser m from to -> Exp from -> m (Exp to) -rephraseExp = mapExpM . mapper - --- | Rephrase a statement. -rephraseStm :: Monad m => Rephraser m from to -> Stm from -> m (Stm to) -rephraseStm rephraser (Let pat (StmAux cs attrs dec) e) = - Let - <$> rephrasePat (rephraseLetBoundDec rephraser) pat - <*> (StmAux cs attrs <$> rephraseExpDec rephraser dec) - <*> rephraseExp rephraser e - --- | Rephrase a pattern. -rephrasePat :: - Monad m => - (from -> m to) -> - Pat from -> - m (Pat to) -rephrasePat = traverse - --- | Rephrase a pattern element. -rephrasePatElem :: Monad m => (from -> m to) -> PatElem from -> m (PatElem to) -rephrasePatElem rephraser (PatElem ident from) = - PatElem ident <$> rephraser from - --- | Rephrase a parameter. -rephraseParam :: Monad m => (from -> m to) -> Param from -> m (Param to) -rephraseParam rephraser (Param attrs name from) = - Param attrs name <$> rephraser from - --- | Rephrase a body. -rephraseBody :: Monad m => Rephraser m from to -> Body from -> m (Body to) -rephraseBody rephraser (Body rep stms res) = - Body - <$> rephraseBodyDec rephraser rep - <*> (stmsFromList <$> mapM (rephraseStm rephraser) (stmsToList stms)) - <*> pure res - --- | Rephrase a lambda. -rephraseLambda :: Monad m => Rephraser m from to -> Lambda from -> m (Lambda to) -rephraseLambda rephraser lam = do - body' <- rephraseBody rephraser $ lambdaBody lam - params' <- mapM (rephraseParam $ rephraseLParamDec rephraser) $ lambdaParams lam - pure lam {lambdaBody = body', lambdaParams = params'} - -mapper :: Monad m => Rephraser m from to -> Mapper from to m -mapper rephraser = - identityMapper - { mapOnBody = const $ rephraseBody rephraser, - mapOnRetType = rephraseRetType rephraser, - mapOnBranchType = rephraseBranchType rephraser, - mapOnFParam = rephraseParam (rephraseFParamDec rephraser), - mapOnLParam = rephraseParam (rephraseLParamDec rephraser), - mapOnOp = rephraseOp rephraser - } 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 @@ -30,6 +30,7 @@ lookupLoopParam, aliases, available, + subExpAvailable, consume, index, index', @@ -281,6 +282,11 @@ available :: VName -> SymbolTable rep -> Bool available name = maybe False (not . entryConsumed) . M.lookup name . bindings +-- | Constant or 'available' +subExpAvailable :: SubExp -> SymbolTable rep -> Bool +subExpAvailable (Var name) = available name +subExpAvailable Constant {} = const True + index :: ASTRep rep => VName -> @@ -323,7 +329,7 @@ Maybe Indexed indexOp _ _ _ _ = Nothing -instance IndexOp () +instance IndexOp (NoOp rep) indexExp :: (IndexOp (Op rep), ASTRep rep) => @@ -390,7 +396,7 @@ } bindingEntries :: - (ASTRep rep, Aliases.Aliased rep, IndexOp (Op rep)) => + (Aliases.Aliased rep, IndexOp (Op rep)) => Stm rep -> SymbolTable rep -> [LetBoundEntry rep] @@ -436,7 +442,7 @@ add vtable' (name, entry) = insertEntry name entry vtable' insertStm :: - (ASTRep rep, IndexOp (Op rep), Aliases.Aliased rep) => + (IndexOp (Op rep), Aliases.Aliased rep) => Stm rep -> SymbolTable rep -> SymbolTable rep @@ -475,7 +481,7 @@ update' e = e insertStms :: - (ASTRep rep, IndexOp (Op rep), Aliases.Aliased rep) => + (IndexOp (Op rep), Aliases.Aliased rep) => Stms rep -> SymbolTable rep -> SymbolTable rep 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 @@ -153,7 +153,7 @@ -- | Produce a usage table reflecting the use of the free variables in -- a single statement. -usageInStm :: (ASTRep rep, Aliased rep) => Stm rep -> UsageTable +usageInStm :: Aliased rep => Stm rep -> UsageTable usageInStm (Let pat rep e) = mconcat [ usageInPat pat `without` patNames pat, diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -54,7 +54,7 @@ -- | The results for a single named dataset is either an error message, or -- runtime measurements, the number of bytes used, and the stderr that was -- produced. -data DataResult = DataResult String (Either T.Text Result) +data DataResult = DataResult T.Text (Either T.Text Result) deriving (Eq, Show) -- | The results for all datasets for some benchmark program. @@ -88,16 +88,16 @@ DataResults <$> mapM datasetResult (JSON.toList o) where datasetResult (k, v) = - DataResult (JSON.toString k) + DataResult (JSON.toText k) <$> ((Right <$> success v) <|> (Left <$> JSON.parseJSON v)) success = JSON.withObject "result" $ \o -> Result <$> o JSON..: "runtimes" <*> o JSON..: "bytes" <*> o JSON..:? "stderr" dataResultJSON :: DataResult -> (JSON.Key, JSON.Value) dataResultJSON (DataResult desc (Left err)) = - (JSON.fromString desc, JSON.toJSON err) + (JSON.fromText desc, JSON.toJSON err) dataResultJSON (DataResult desc (Right (Result runtimes bytes progerr_opt))) = - ( JSON.fromString desc, + ( JSON.fromText desc, JSON.object $ [ ("runtimes", JSON.toJSON $ map runMicroseconds runtimes), ("bytes", JSON.toJSON bytes) 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 @@ -4,11 +4,12 @@ import Control.Monad import Data.ByteString.Char8 qualified as SBS import Data.Function (on) -import Data.List (elemIndex, intersect, isPrefixOf, minimumBy, sort, sortOn) +import Data.List (elemIndex, intersect, minimumBy, sort, sortOn) import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S import Data.Text qualified as T +import Data.Text.IO qualified as T import Data.Tree import Futhark.Bench import Futhark.Server @@ -73,26 +74,26 @@ runResultAction = const $ pure () } -type Path = [(String, Int)] +type Path = [(T.Text, Int)] -regexGroups :: Regex -> String -> Maybe [String] +regexGroups :: Regex -> T.Text -> Maybe [T.Text] regexGroups regex s = do (_, _, _, groups) <- - matchM regex s :: Maybe (String, String, String, [String]) + matchM regex s :: Maybe (T.Text, T.Text, T.Text, [T.Text]) Just groups -comparisons :: String -> [(String, Int)] -comparisons = mapMaybe isComparison . lines +comparisons :: T.Text -> [(T.Text, Int)] +comparisons = mapMaybe isComparison . T.lines where regex = makeRegex ("Compared ([^ ]+) <= (-?[0-9]+)" :: String) isComparison l = do [thresh, val] <- regexGroups regex l - val' <- readMaybe val + val' <- readMaybe $ T.unpack val pure (thresh, val') -type RunDataset = Server -> Int -> Path -> IO (Either String ([(String, Int)], Int)) +type RunDataset = Server -> Int -> Path -> IO (Either String ([(T.Text, Int)], Int)) -type DatasetName = String +type DatasetName = T.Text serverOptions :: AutotuneOptions -> [String] serverOptions opts = @@ -101,10 +102,10 @@ : "-L" : optExtraOptions opts -setTuningParam :: Server -> String -> Int -> IO () +setTuningParam :: Server -> T.Text -> Int -> IO () setTuningParam server name val = either (error . T.unpack . T.unlines . failureMsg) (const $ pure ()) - =<< cmdSetTuningParam server (T.pack name) (showText val) + =<< cmdSetTuningParam server name (showText val) setTuningParams :: Server -> Path -> IO () setTuningParams server = mapM_ (uncurry $ setTuningParam server) @@ -165,9 +166,9 @@ pure (dataset, do_run, iosEntryPoint ios) where run server entry_point trun expected timeout path = do - let bestRuntime :: ([RunResult], T.Text) -> ([(String, Int)], Int) + let bestRuntime :: ([RunResult], T.Text) -> ([(T.Text, Int)], Int) bestRuntime (runres, errout) = - ( comparisons (T.unpack errout), + ( comparisons errout, minimum $ map runMicroseconds runres ) @@ -196,14 +197,14 @@ --- Benchmarking a program -data DatasetResult = DatasetResult [(String, Int)] Double +data DatasetResult = DatasetResult [(T.Text, Int)] Double deriving (Show) --- Finding initial comparisons. --- Extracting threshold hierarchy. -type ThresholdForest = Forest (String, Bool) +type ThresholdForest = Forest (T.Text, Bool) thresholdMin, thresholdMax :: Int thresholdMin = 1 @@ -212,7 +213,7 @@ -- | Depth-first list of thresholds to tune in order, and a -- corresponding assignment of ancestor thresholds to ensure that they -- are used. -tuningPaths :: ThresholdForest -> [(String, Path)] +tuningPaths :: ThresholdForest -> [(T.Text, Path)] tuningPaths = concatMap (treePaths []) where treePaths ancestors (Node (v, _) children) = @@ -227,7 +228,7 @@ thresholdForest :: FilePath -> IO ThresholdForest thresholdForest prog = do thresholds <- - getThresholds + getThresholds . T.pack <$> readProcess ("." dropExtension prog) ["--print-params"] "" let root (v, _) = ((v, False), []) pure $ @@ -235,22 +236,22 @@ map root $ filter (null . snd) thresholds where - getThresholds = mapMaybe findThreshold . lines - regex = makeRegex ("(.*) \\(threshold\\(([^ ]+,)(.*)\\)\\)" :: String) + getThresholds = mapMaybe findThreshold . T.lines + regex = makeRegex ("(.*) \\(threshold\\(([^ ]+,)(.*)\\)\\)" :: T.Text) - findThreshold :: String -> Maybe (String, [(String, Bool)]) + findThreshold :: T.Text -> Maybe (T.Text, [(T.Text, Bool)]) findThreshold l = do [grp1, _, grp2] <- regexGroups regex l pure ( grp1, - filter (not . null . fst) + filter (not . T.null . fst) $ map ( \x -> - if "!" `isPrefixOf` x - then (drop 1 x, False) + if "!" `T.isPrefixOf` x + then (T.drop 1 x, False) else (x, True) ) - $ words grp2 + $ T.words grp2 ) unfold thresholds ((parent, parent_cmp), ancestors) = @@ -276,7 +277,7 @@ Server -> [(DatasetName, RunDataset, T.Text)] -> (Path, M.Map DatasetName Int) -> - (String, Path) -> + (T.Text, Path) -> IO (Path, M.Map DatasetName Int) tuneThreshold opts server datasets (already_tuned, best_runtimes0) (v, _v_path) = do (tune_result, best_runtimes) <- @@ -287,21 +288,24 @@ Just (_, threshold) -> pure ((v, threshold) : already_tuned, best_runtimes) where - tuneDataset :: (Maybe (Int, Int), M.Map DatasetName Int) -> (DatasetName, RunDataset, T.Text) -> IO (Maybe (Int, Int), M.Map DatasetName Int) + tuneDataset :: + (Maybe (Int, Int), M.Map DatasetName Int) -> + (DatasetName, RunDataset, T.Text) -> + IO (Maybe (Int, Int), M.Map DatasetName Int) tuneDataset (thresholds, best_runtimes) (dataset_name, run, entry_point) = - if not $ isPrefixOf (T.unpack entry_point ++ ".") v + if not $ T.isPrefixOf (entry_point <> ".") v then do when (optVerbose opts > 0) $ - putStrLn $ - unwords [v, "is irrelevant for", T.unpack entry_point] + T.putStrLn $ + T.unwords [v, "is irrelevant for", entry_point] pure (thresholds, best_runtimes) else do - putStrLn $ - unwords + T.putStrLn $ + T.unwords [ "Tuning", v, "on entry point", - T.unpack entry_point, + entry_point, "and dataset", dataset_name ] @@ -351,16 +355,16 @@ case dataset_name `M.lookup` best_runtimes of Just rt | fromIntegral rt * epsilon < fromIntegral best_t -> do - putStrLn $ - unwords + T.putStrLn $ + T.unwords [ "WARNING! Possible non-monotonicity detected. Previous best run-time for dataset", dataset_name, " was", - show rt, + showText rt, "but after tuning threshold", v, "it is", - show best_t + showText best_t ] pure best_runtimes _ -> @@ -374,7 +378,7 @@ -- We wish to let datasets run for the untuned time + 20% + 1 second. timeout elapsed = ceiling (fromIntegral elapsed * 1.2 :: Double) + 1 - candidateEPar :: (Int, Int) -> (String, Int) -> Bool + candidateEPar :: (Int, Int) -> (T.Text, Int) -> Bool candidateEPar (tMin, tMax) (threshold, ePar) = ePar > tMin && ePar < tMax && threshold == v @@ -451,17 +455,17 @@ runAutotuner opts prog = do best <- tune opts prog - let tuning = unlines $ do + let tuning = T.unlines $ do (s, n) <- sortOn fst best - pure $ s ++ "=" ++ show n + pure $ s <> "=" <> showText n case optTuning opts of Nothing -> pure () Just suffix -> do - writeFile (prog <.> suffix) tuning + T.writeFile (prog <.> suffix) tuning putStrLn $ "Wrote " ++ prog <.> suffix - putStrLn $ "Result of autotuning:\n" ++ tuning + T.putStrLn $ "Result of autotuning:\n" <> tuning commandLineOptions :: [FunOptDescr AutotuneOptions] commandLineOptions = 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 @@ -242,7 +242,8 @@ relevant = maybe (const True) (==) (optEntryPoint opts) . T.unpack . iosEntryPoint - pad_to = foldl max 0 $ concatMap (map (length . atMostChars maxDatasetNameLength . runDescription) . iosTestRuns) cases + len = T.length . atMostChars maxDatasetNameLength . runDescription + pad_to = foldl max 0 $ concatMap (map len . iosTestRuns) cases runOptions :: ((Int, Maybe Double) -> IO ()) -> BenchOptions -> RunOptions runOptions f opts = @@ -256,8 +257,8 @@ runResultAction = f } -descString :: String -> Int -> String -descString desc pad_to = desc ++ ": " ++ replicate (pad_to - length desc) ' ' +descText :: T.Text -> Int -> T.Text +descText desc pad_to = desc <> ": " <> T.replicate (pad_to - T.length desc) " " progress :: Double -> T.Text progress elapsed = @@ -290,17 +291,17 @@ data BenchPhase = Initial | Convergence -mkProgressPrompt :: BenchOptions -> Int -> String -> UTCTime -> IO ((Maybe Int, Maybe Double) -> IO ()) +mkProgressPrompt :: BenchOptions -> Int -> T.Text -> UTCTime -> IO ((Maybe Int, Maybe Double) -> IO ()) mkProgressPrompt opts pad_to dataset_desc start_time | fancyTerminal = do count <- newIORef (0, 0) phase_var <- newIORef Initial spin_count <- newIORef 0 pure $ \(us, rse) -> do - putStr "\r" -- Go to start of line. + T.putStr "\r" -- Go to start of line. let p s = T.putStr $ - T.pack (descString (atMostChars maxDatasetNameLength dataset_desc) pad_to) <> s + descText (atMostChars maxDatasetNameLength dataset_desc) pad_to <> s (us_sum, i) <- readIORef count @@ -343,7 +344,7 @@ putStr " " -- Just to move the cursor away from the progress bar. hFlush stdout | otherwise = do - putStr $ descString dataset_desc pad_to + T.putStr $ descText dataset_desc pad_to hFlush stdout pure $ const $ pure () where @@ -390,8 +391,8 @@ when fancyTerminal $ do clearLine - putStr "\r" - putStr $ descString (atMostChars maxDatasetNameLength dataset_desc) pad_to + T.putStr "\r" + T.putStr $ descText (atMostChars maxDatasetNameLength dataset_desc) pad_to case res of Left err -> liftIO $ do diff --git a/src/Futhark/CLI/Benchcmp.hs b/src/Futhark/CLI/Benchcmp.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Benchcmp.hs @@ -0,0 +1,327 @@ +-- | @futhark benchcmp@ +module Futhark.CLI.Benchcmp (main) where + +import Control.Exception (catch) +import Data.Bifunctor (Bifunctor (bimap, first, second)) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Either qualified as E +import Data.List qualified as L +import Data.Map qualified as M +import Data.Text qualified as T +import Data.Vector qualified as V +import Futhark.Bench +import Futhark.Util (showText) +import Futhark.Util.Options (mainWithOptions) +import Statistics.Sample qualified as S +import System.Console.ANSI (hSupportsANSI) +import System.IO (stdout) +import Text.Printf (printf) + +-- | Record that summerizes a comparison between two benchmarks. +data SpeedUp = SpeedUp + { -- | What factor the benchmark is improved by. + speedup :: Double, + -- | Memory usage. + memoryUsage :: M.Map T.Text Double, + -- | If the speedup was significant. + significant :: Bool + } + deriving (Show) + +-- | Terminal colors used when printing the comparisons. Some of these are not +-- colors ways of emphasising text. +data Colors = Colors + { -- | The header color. + header :: T.Text, + -- | Okay color + okblue :: T.Text, + -- | A second okay color + okgreen :: T.Text, + -- | Warning color. + warning :: T.Text, + -- | When something fails. + failing :: T.Text, + -- | Default color. + endc :: T.Text, + -- | Bold text. + bold :: T.Text, + -- | Underline text. + underline :: T.Text + } + +-- | Colors to use for a terminal device. +ttyColors :: Colors +ttyColors = + Colors + { header = "\ESC[95m", + okblue = "\ESC[94m", + okgreen = "\ESC[92m", + warning = "\ESC[93m", + failing = "\ESC[91m", + endc = "\ESC[0m", + bold = "\ESC[1m", + underline = "\ESC[4m" + } + +-- | Colors to use for a non-terminal device. +nonTtyColors :: Colors +nonTtyColors = + Colors + { header = "", + okblue = "", + okgreen = "", + warning = "", + failing = "", + endc = "", + bold = "", + underline = "" + } + +-- | Reads a file without throwing an error. +readFileSafely :: T.Text -> IO (Either T.Text LBS.ByteString) +readFileSafely filepath = + (Right <$> LBS.readFile (T.unpack filepath)) `catch` couldNotRead + where + couldNotRead e = pure $ Left $ showText (e :: IOError) + +-- | Converts DataResults to a Map with the text as a key. +toDataResultsMap :: [DataResult] -> M.Map T.Text (Either T.Text Result) +toDataResultsMap = M.fromList . fmap toTuple + where + toTuple (DataResult dataset dataResults) = (dataset, dataResults) + +-- | Converts BenchResults to a Map with the file path as a key. +toBenchResultsMap :: + [BenchResult] -> + M.Map T.Text (M.Map T.Text (Either T.Text Result)) +toBenchResultsMap = M.fromList . fmap toTuple + where + toTuple (BenchResult path dataResults) = + (T.pack path, toDataResultsMap dataResults) + +-- | Given a file path to a json file which has the form of a futhark benchmark +-- result, it will try to parse the file to a Map of Maps. The key +-- in the outer most dictionary is a file path the inner key is the dataset. +decodeFileBenchResultsMap :: + T.Text -> + IO (Either T.Text (M.Map T.Text (M.Map T.Text (Either T.Text Result)))) +decodeFileBenchResultsMap path = do + file <- readFileSafely path + pure $ toBenchResultsMap <$> (file >>= (first T.pack . decodeBenchResults)) + +-- | Will return a text with an error saying there is a missing program in a +-- given result. +formatMissingProg :: T.Text -> T.Text -> T.Text -> T.Text +formatMissingProg = ((T.pack .) .) . printf "In %s but not %s: program %s" + +-- | Will return a text with an error saying there is a missing dataset in a +-- given result. +formatMissingData :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text +formatMissingData = + (((T.pack .) .) .) . printf "In %s but not %s: program %s dataset %s" + +-- | Will return texts that say there are a missing program. +formatManyMissingProg :: T.Text -> T.Text -> [T.Text] -> [T.Text] +formatManyMissingProg a_path b_path = + zipWith3 formatMissingProg a_paths b_paths + where + a_paths = repeat a_path + b_paths = repeat b_path + +-- | Will return texts that say there are missing datasets for a program. +formatManyMissingData :: T.Text -> T.Text -> T.Text -> [T.Text] -> [T.Text] +formatManyMissingData prog a_path b_path = + L.zipWith4 formatMissingData a_paths b_paths progs + where + a_paths = repeat a_path + b_paths = repeat b_path + progs = repeat prog + +-- | Finds the keys two Maps does not have in common and returns a appropiate +-- error based on the functioned passed. +missingResults :: + (T.Text -> T.Text -> [T.Text] -> [T.Text]) -> + T.Text -> + T.Text -> + M.Map T.Text a -> + M.Map T.Text b -> + [T.Text] +missingResults toMissingMap a_path b_path a_results b_results = missing + where + a_keys = M.keys a_results + b_keys = M.keys b_results + a_missing = toMissingMap a_path b_path $ a_keys L.\\ b_keys + b_missing = toMissingMap b_path a_path $ b_keys L.\\ a_keys + missing = a_missing `L.union` b_missing + +-- | Compares the memory usage of two results. +computeMemoryUsage :: + M.Map T.Text Int -> + M.Map T.Text Int -> + M.Map T.Text Double +computeMemoryUsage a b = M.intersectionWith divide b $ M.filter (/= 0) a + where + divide x y = fromIntegral x / fromIntegral y + +-- | Compares two results and thereby computes the Speed Up records. +compareResult :: Result -> Result -> SpeedUp +compareResult a b = + SpeedUp + { speedup = speedup', + significant = significant', + memoryUsage = memory_usage + } + where + runResultToDouble :: RunResult -> Double + runResultToDouble = fromIntegral . runMicroseconds + toVector = V.fromList . (runResultToDouble <$>) . runResults + a_memory_usage = memoryMap a + b_memory_usage = memoryMap b + a_run_results = toVector a + b_run_results = toVector b + a_std = S.stdDev a_run_results + b_std = S.stdDev b_run_results + a_mean = S.mean a_run_results + b_mean = S.mean b_run_results + diff = abs $ a_mean - b_mean + speedup' = a_mean / b_mean + significant' = diff > a_std / 2 + b_std / 2 + memory_usage = computeMemoryUsage a_memory_usage b_memory_usage + +-- | Given two Maps containing datasets as keys and results as values, compare +-- the results and return the errors in a tuple. +compareDataResults :: + T.Text -> + T.Text -> + T.Text -> + M.Map T.Text (Either T.Text Result) -> + M.Map T.Text (Either T.Text Result) -> + (M.Map T.Text SpeedUp, ([T.Text], [T.Text])) +compareDataResults prog a_path b_path a_data b_data = result + where + formatMissing = formatManyMissingData prog + partition = E.partitionEithers . fmap sequence . M.toList + (a_errors, a_data') = second M.fromList $ partition a_data + (b_errors, b_data') = second M.fromList $ partition b_data + missing = missingResults formatMissing a_path b_path a_data' b_data' + exists = M.intersectionWith compareResult a_data' b_data' + errors = a_errors ++ b_errors + result = (exists, (errors, missing)) + +-- | Given two Maps containing program file paths as keys and values as datasets +-- with results. Compare the results for each dataset in each program and +-- return the errors in a tuple. +compareBenchResults :: + T.Text -> + T.Text -> + M.Map T.Text (M.Map T.Text (Either T.Text Result)) -> + M.Map T.Text (M.Map T.Text (Either T.Text Result)) -> + (M.Map T.Text (M.Map T.Text SpeedUp), ([T.Text], [T.Text])) +compareBenchResults a_path b_path a_bench b_bench = (exists, errors_missing) + where + missing = missingResults formatManyMissingProg a_path b_path a_bench b_bench + result = M.intersectionWithKey auxiliary a_bench b_bench + auxiliary prog = compareDataResults prog a_path b_path + exists = M.filter (not . null) $ fst <$> result + errors_missing' = bimap concat concat . unzip . M.elems $ snd <$> result + errors_missing = second (missing ++) errors_missing' + +-- | Formats memory usage such that it is human readable. If the memory usage +-- is not significant an empty text is returned. +memoryFormatter :: Colors -> T.Text -> Double -> T.Text +memoryFormatter colors key value + | value < 0.99 = memoryFormat $ okgreen colors + | value > 1.01 = memoryFormat $ failing colors + | otherwise = "" + where + memoryFormat c = T.pack $ printf "%s%4.2fx@%s%s" c value key endc' + endc' = endc colors + +-- | Given a SpeedUp record the memory usage will be formatted to a colored +-- human readable text. +toMemoryText :: Colors -> SpeedUp -> T.Text +toMemoryText colors data_result + | T.null memory_text = "" + | otherwise = " (mem: " <> memory_text <> ")" + where + memory_text = M.foldrWithKey formatFolder "" memory + memory = memoryUsage data_result + formatFolder key value lst = lst <> memoryFormatter colors key value + +-- | Given a text shorten it to a given length and add a suffix as the last +-- word. +shorten :: Int -> T.Text -> T.Text -> T.Text +shorten c end string + | T.length string > c = (T.unwords . init $ T.words shortened) <> " " <> end + | otherwise = string + where + end_len = T.length end + (shortened, _) = T.splitAt (c - end_len) string + +-- | Given a text add padding to the right of the text in form of spaces. +rightPadding :: Int -> T.Text -> T.Text +rightPadding c = T.pack . printf s + where + s = "%-" <> show c <> "s" + +-- | Given a SpeedUp record print the SpeedUp in a human readable manner. +printSpeedUp :: Colors -> T.Text -> SpeedUp -> IO () +printSpeedUp colors dataset data_result = do + let color + | significant data_result && speedup data_result > 1.01 = okgreen colors + | significant data_result && speedup data_result < 0.99 = failing colors + | otherwise = "" + let short_dataset = rightPadding 64 . (<> ":") $ shorten 63 "[...]" dataset + let memoryText = toMemoryText colors data_result + let speedup' = speedup data_result + let endc' = endc colors + let format = " %s%s%10.2fx%s%s" + putStrLn $ printf format short_dataset color speedup' endc' memoryText + +-- | Given a Map of SpeedUp records where the key is the program, print the +-- SpeedUp in a human readable manner. +printProgSpeedUps :: Colors -> T.Text -> M.Map T.Text SpeedUp -> IO () +printProgSpeedUps colors prog bench_result = do + putStrLn "" + putStrLn $ printf "%s%s%s%s" (header colors) (bold colors) prog (endc colors) + mapM_ (uncurry (printSpeedUp colors)) $ M.toList bench_result + +-- | Given a Map of programs with dataset speedups and relevant errors, print +-- the errors and print the speedups in a human readable manner. +printComparisons :: + Colors -> + M.Map T.Text (M.Map T.Text SpeedUp) -> + ([T.Text], [T.Text]) -> + IO () +printComparisons colors speedups (errors, missing) = do + mapM_ (putStrLn . T.unpack) $ L.sort missing + mapM_ (putStrLn . T.unpack) $ L.sort errors + mapM_ (uncurry (printProgSpeedUps colors)) $ M.toList speedups + +-- | Run @futhark benchcmp@ +main :: String -> [String] -> IO () +main = mainWithOptions () [] " " f + where + f [a_path', b_path'] () = Just $ do + let a_path = T.pack a_path' + let b_path = T.pack b_path' + a_either <- decodeFileBenchResultsMap a_path + b_either <- decodeFileBenchResultsMap b_path + + isTty <- hSupportsANSI stdout + + let colors = + if isTty + then ttyColors + else nonTtyColors + + let comparePrint = + (uncurry (printComparisons colors) .) + . compareBenchResults a_path b_path + + case (a_either, b_either) of + (Left a, Left b) -> putStrLn . T.unpack $ (a <> "\n" <> b) + (Left a, _) -> putStrLn . T.unpack $ a + (_, Left b) -> putStrLn . T.unpack $ b + (Right a, Right b) -> comparePrint a b + f _ _ = 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 @@ -114,9 +114,9 @@ "Generate a random value of this type.", Option [] - ["pretty"] + ["text"] (NoArg $ Right $ \opts -> opts {format = Text}) - "Output data in pretty format (must precede --generate).", + "Output data in text format (default; must precede --generate).", Option "b" ["binary"] 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 @@ -13,13 +13,13 @@ import Futhark.Analysis.Alias qualified as Alias import Futhark.Analysis.Metrics (OpMetrics) import Futhark.Compiler.CLI hiding (compilerMain) -import Futhark.IR (ASTRep, Op, Prog, prettyString) +import Futhark.IR (Op, Prog, prettyString) +import Futhark.IR.Aliases (AliasableRep) import Futhark.IR.GPU qualified as GPU import Futhark.IR.GPUMem qualified as GPUMem import Futhark.IR.MC qualified as MC import Futhark.IR.MCMem qualified as MCMem import Futhark.IR.Parse -import Futhark.IR.Prop.Aliases (CanBeAliased) import Futhark.IR.SOACS qualified as SOACS import Futhark.IR.Seq qualified as Seq import Futhark.IR.SeqMem qualified as SeqMem @@ -154,8 +154,7 @@ | SeqMemAction (BackendAction SeqMem.SeqMem) | PolyAction ( forall (rep :: Data.Kind.Type). - ( ASTRep rep, - (CanBeAliased (Op rep)), + ( AliasableRep rep, (OpMetrics (Op rep)) ) => Action rep @@ -506,14 +505,6 @@ ( NoArg $ Right $ \opts -> opts {futharkAction = GPUMemAction $ \_ _ _ -> printLastUseGPU} - ) - "Print last use information.", - Option - [] - ["print-last-use-gpu-ss"] - ( NoArg $ - Right $ \opts -> - opts {futharkAction = GPUMemAction $ \_ _ _ -> printLastUseGPUSS} ) "Print last use information ss.", Option diff --git a/src/Futhark/CLI/Eval.hs b/src/Futhark/CLI/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Eval.hs @@ -0,0 +1,130 @@ +module Futhark.CLI.Eval (main) where + +import Control.Exception +import Control.Monad +import Control.Monad.Except +import Control.Monad.Free.Church +import Data.Map qualified as M +import Data.Maybe +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Futhark.Compiler +import Futhark.MonadFreshNames +import Futhark.Pipeline +import Futhark.Util.Options +import Futhark.Util.Pretty +import Language.Futhark.Interpreter qualified as I +import Language.Futhark.Parser +import Language.Futhark.Semantic qualified as T +import Language.Futhark.TypeChecker qualified as I +import Language.Futhark.TypeChecker qualified as T +import System.Exit +import System.FilePath +import System.IO +import Prelude + +main :: String -> [String] -> IO () +main = mainWithOptions interpreterConfig options "options... " run + where + run [] _ = Nothing + run exprs config = Just $ runExprs exprs config + +runExprs :: [String] -> InterpreterConfig -> IO () +runExprs exprs cfg = do + let InterpreterConfig _ file = cfg + maybe_new_state <- newFutharkiState cfg file + (src, env, ctx) <- case maybe_new_state of + Left _ -> do + hPutStrLn stderr $ fromJust file <> ": file not found." + exitWith $ ExitFailure 2 + Right s -> pure s + mapM_ (runExpr src env ctx) exprs + +-- Use parseExp, checkExp, then interpretExp. +runExpr :: VNameSource -> T.Env -> I.Ctx -> String -> IO () +runExpr src env ctx str = do + uexp <- case parseExp "" (T.pack str) of + Left (SyntaxError _ serr) -> do + T.hPutStrLn stderr serr + exitWith $ ExitFailure 1 + Right e -> pure e + fexp <- case T.checkExp [] src env uexp of + (_, Left terr) -> do + hPutDoc stderr $ I.prettyTypeError terr + exitWith $ ExitFailure 1 + (_, Right (_, e)) -> pure e + pval <- runInterpreterNoBreak $ I.interpretExp ctx fexp + case pval of + Left err -> do + hPutDoc stderr $ I.prettyInterpreterError err + exitWith $ ExitFailure 1 + Right val -> putDoc $ I.prettyValue val <> hardline + +data InterpreterConfig = InterpreterConfig + { interpreterPrintWarnings :: Bool, + interpreterFile :: Maybe String + } + +interpreterConfig :: InterpreterConfig +interpreterConfig = InterpreterConfig True Nothing + +options :: [FunOptDescr InterpreterConfig] +options = + [ Option + "f" + ["file"] + ( ReqArg + ( \entry -> Right $ \config -> + config {interpreterFile = Just entry} + ) + "NAME" + ) + "The file to load before evaluating expressions.", + Option + "w" + ["no-warnings"] + (NoArg $ Right $ \config -> config {interpreterPrintWarnings = False}) + "Do not print warnings." + ] + +newFutharkiState :: + InterpreterConfig -> + Maybe FilePath -> + IO (Either (Doc AnsiStyle) (VNameSource, T.Env, I.Ctx)) +newFutharkiState cfg maybe_file = runExceptT $ do + (ws, imports, src) <- + badOnLeft prettyCompilerError + =<< liftIO + ( runExceptT (readProgramFiles [] $ maybeToList maybe_file) + `catch` \(err :: IOException) -> + pure (externalErrorS (show err)) + ) + when (interpreterPrintWarnings cfg) $ + liftIO $ + hPutDoc stderr $ + prettyWarnings ws + + ictx <- + foldM (\ctx -> badOnLeft I.prettyInterpreterError <=< runInterpreterNoBreak . I.interpretImport ctx) I.initialCtx $ + map (fmap fileProg) imports + + let (tenv, ienv) = + let (iname, fm) = last imports + in ( fileScope fm, + ictx {I.ctxEnv = I.ctxImports ictx M.! iname} + ) + + pure (src, tenv, ienv) + where + badOnLeft :: (err -> err') -> Either err a -> ExceptT err' IO a + badOnLeft _ (Right x) = pure x + badOnLeft p (Left err) = throwError $ p err + +runInterpreterNoBreak :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) +runInterpreterNoBreak m = runF m (pure . Right) intOp + where + intOp (I.ExtOpError err) = pure $ Left err + intOp (I.ExtOpTrace w v c) = do + liftIO $ putDocLn $ pretty w <> ":" <+> align (unAnnotate v) + c + intOp (I.ExtOpBreak _ _ _ c) = c 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 @@ -18,12 +18,12 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T +import Data.Text.Read qualified as T import Data.Vector.Storable qualified as SVec import Data.Vector.Storable.ByteString qualified as SVec import Data.Void import Data.Word (Word32, Word8) import Futhark.Data -import Futhark.Data.Reader import Futhark.Script import Futhark.Server import Futhark.Test @@ -597,18 +597,33 @@ void $ system "convert" [imgfile, "-type", "TrueColorAlpha", bmpfile] mempty loadBMP bmpfile -loadData :: FilePath -> ScriptM (Compound Value) -loadData datafile = do - contents <- liftIO $ LBS.readFile datafile - let maybe_vs = readValues contents - case maybe_vs of - Nothing -> - throwError $ "Failed to read data file " <> T.pack datafile - Just [v] -> - pure $ ValueAtom v - Just vs -> - pure $ ValueTuple $ map ValueAtom vs +loadPCM :: Int -> FilePath -> ScriptM (Compound Value) +loadPCM num_channels pcmfile = do + contents <- liftIO $ LBS.readFile pcmfile + let v = SVec.byteStringToVector $ LBS.toStrict contents + channel_length = SVec.length v `div` num_channels + shape = + SVec.fromList + [ fromIntegral num_channels, + fromIntegral channel_length + ] + -- ffmpeg outputs audio data in column-major format. `backPermuter` computes the + -- tranposed indexes for a backpermutation. + backPermuter i = (i `mod` channel_length) * num_channels + i `div` channel_length + perm = SVec.generate (SVec.length v) backPermuter + pure $ ValueAtom $ F64Value shape $ SVec.backpermute v perm +loadAudio :: FilePath -> ScriptM (Compound Value) +loadAudio audiofile = do + s <- system "ffprobe" [audiofile, "-show_entries", "stream=channels", "-select_streams", "a", "-of", "compact=p=0:nk=1", "-v", "0"] mempty + case T.decimal s of + Right (num_channels, _) -> do + withTempDir $ \dir -> do + let pcmfile = dir takeBaseName audiofile `replaceExtension` "pcm" + void $ system "ffmpeg" ["-i", audiofile, "-c:a", "pcm_f64le", "-map", "0", "-f", "data", pcmfile] mempty + loadPCM num_channels pcmfile + _ -> throwError "$loadImg failed to detect the number of channels in the audio input" + literateBuiltin :: EvalBuiltin ScriptM literateBuiltin "loadimg" vs = case vs of @@ -620,18 +635,18 @@ throwError $ "$loadimg does not accept arguments of types: " <> T.intercalate ", " (map (prettyText . fmap valueType) vs) -literateBuiltin "loaddata" vs = +literateBuiltin "loadaudio" vs = case vs of [ValueAtom v] | Just path <- getValue v -> do let path' = map (chr . fromIntegral) (path :: [Word8]) - loadData path' + loadAudio path' _ -> throwError $ - "$loaddata does not accept arguments of types: " + "$loadaudio does not accept arguments of types: " <> T.intercalate ", " (map (prettyText . fmap valueType) vs) -literateBuiltin f _ = - throwError $ "Unknown builtin function $" <> prettyText f +literateBuiltin f vs = + scriptBuiltin "." f vs data Options = Options { scriptBackend :: String, 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 @@ -7,6 +7,7 @@ import Data.Text.IO qualified as T import Futhark.CLI.Autotune qualified as Autotune import Futhark.CLI.Bench qualified as Bench +import Futhark.CLI.Benchcmp qualified as Benchcmp import Futhark.CLI.C qualified as C import Futhark.CLI.CUDA qualified as CCUDA import Futhark.CLI.Check qualified as Check @@ -15,6 +16,7 @@ import Futhark.CLI.Defs qualified as Defs import Futhark.CLI.Dev qualified as Dev import Futhark.CLI.Doc qualified as Doc +import Futhark.CLI.Eval qualified as Eval import Futhark.CLI.LSP qualified as LSP import Futhark.CLI.Literate qualified as Literate import Futhark.CLI.Misc qualified as Misc @@ -47,6 +49,7 @@ sortOn fst [ ("dev", (Dev.main, "Run compiler passes directly.")), + ("eval", (Eval.main, "Evaluate Futhark expressions passed in as arguments")), ("repl", (REPL.main, "Run interactive Read-Eval-Print-Loop.")), ("run", (Run.main, "Run a program through the (slow!) interpreter.")), ("c", (C.main, "Compile to sequential C.")), @@ -75,7 +78,8 @@ ("literate", (Literate.main, "Process a literate Futhark program.")), ("lsp", (LSP.main, "Run LSP server.")), ("thanks", (Misc.mainThanks, "Express gratitude.")), - ("tokens", (Misc.mainTokens, "Print tokens from Futhark file.")) + ("tokens", (Misc.mainTokens, "Print tokens from Futhark file.")), + ("benchcmp", (Benchcmp.main, "Compare two Futhark benchmarks.")) ] msg :: String 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 @@ -12,8 +12,9 @@ import Control.Monad.State import Data.ByteString.Lazy qualified as BS import Data.Function (on) -import Data.List (isInfixOf, nubBy) +import Data.List (nubBy) import Data.Loc (L (..), startPos) +import Data.Text qualified as T import Data.Text.IO qualified as T import Futhark.Compiler import Futhark.Test @@ -53,7 +54,7 @@ mainDataget :: String -> [String] -> IO () mainDataget = mainWithOptions () [] "program dataset" $ \args () -> case args of - [file, dataset] -> Just $ dataget file dataset + [file, dataset] -> Just $ dataget file $ T.pack dataset _ -> Nothing where dataget prog dataset = do @@ -62,7 +63,7 @@ runs <- testSpecRuns <$> testSpecFromProgramOrDie prog let exact = filter ((dataset ==) . runDescription) runs - infixes = filter ((dataset `isInfixOf`) . runDescription) runs + infixes = filter ((dataset `T.isInfixOf`) . runDescription) runs futhark <- FutharkExe <$> getExecutablePath @@ -70,13 +71,13 @@ if null exact then infixes else exact of [x] -> BS.putStr =<< getValuesBS futhark dir (runInput x) [] -> do - hPutStr stderr $ "No dataset '" ++ dataset ++ "'.\n" - hPutStr stderr "Available datasets:\n" - mapM_ (hPutStrLn stderr . (" " ++) . runDescription) runs + T.hPutStr stderr $ "No dataset '" <> dataset <> "'.\n" + T.hPutStr stderr "Available datasets:\n" + mapM_ (T.hPutStrLn stderr . (" " <>) . runDescription) runs exitFailure runs' -> do - hPutStr stderr $ "Dataset '" ++ dataset ++ "' ambiguous:\n" - mapM_ (hPutStrLn stderr . (" " ++) . runDescription) runs' + T.hPutStr stderr $ "Dataset '" <> dataset <> "' ambiguous:\n" + mapM_ (T.hPutStrLn stderr . (" " <>) . runDescription) runs' exitFailure testSpecRuns = testActionRuns . testAction 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 @@ -1,12 +1,10 @@ -- | @futhark pkg@ module Futhark.CLI.Pkg (main) where -import Codec.Archive.Zip qualified as Zip import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State -import Data.ByteString.Lazy qualified as LBS -import Data.List (intercalate, isPrefixOf) +import Data.List (intercalate) import Data.Map qualified as M import Data.Maybe import Data.Monoid @@ -22,57 +20,17 @@ import System.Environment import System.Exit import System.FilePath -import System.FilePath.Posix qualified as Posix import System.IO +import System.IO.Temp (withSystemTempDirectory) import Prelude --- Installing packages -installInDir :: BuildList -> FilePath -> PkgM () -installInDir (BuildList bl) dir = do - let putEntry from_dir pdir entry - -- The archive may contain all kinds of other stuff that we don't want. - | not (isInPkgDir from_dir $ Zip.eRelativePath entry) - || hasTrailingPathSeparator (Zip.eRelativePath entry) = - pure Nothing - | otherwise = do - -- Since we are writing to paths indicated in a zipfile we - -- downloaded from the wild Internet, we are going to be a - -- little bit paranoid. Specifically, we want to avoid - -- writing outside of the 'lib/' directory. We do this by - -- bailing out if the path contains any '..' components. We - -- have to use System.FilePath.Posix, because the zip library - -- claims to encode filepaths with '/' directory seperators no - -- matter the host OS. - when (".." `elem` Posix.splitPath (Zip.eRelativePath entry)) $ - fail $ - "Zip archive for " - <> pdir - <> " contains suspicious path: " - <> Zip.eRelativePath entry - let f = pdir makeRelative from_dir (Zip.eRelativePath entry) - createDirectoryIfMissing True $ takeDirectory f - LBS.writeFile f $ Zip.fromEntry entry - pure $ Just f - - isInPkgDir from_dir f = - Posix.splitPath from_dir `isPrefixOf` Posix.splitPath f - +installInDir :: CacheDir -> BuildList -> FilePath -> PkgM () +installInDir cachedir (BuildList bl) dir = forM_ (M.toList bl) $ \(p, v) -> do - info <- lookupPackageRev p v - a <- downloadZipball info - m <- getManifest $ pkgRevGetManifest info - - -- Compute the directory in the zipball that should contain the - -- package files. - let noPkgDir = - fail $ - "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 + info <- lookupPackageRev cachedir p v + (filedir, files) <- getFiles $ pkgGetFiles info -- The directory in the local file system that will contain the -- package files. @@ -83,17 +41,13 @@ -- have a way to recognise this situation, and not download the -- zipball in that case. liftIO $ removePathForcibly pdir - liftIO $ createDirectoryIfMissing True pdir - written <- - catMaybes <$> liftIO (mapM (putEntry from_dir pdir) $ Zip.zEntries a) - - when (null written) $ - fail $ - "Zip archive for package " - ++ T.unpack p - ++ " does not contain any files in " - ++ from_dir + forM_ files $ \file -> do + let from = filedir file + to = pdir file + liftIO $ createDirectoryIfMissing True $ takeDirectory to + logMsg $ "Copying " <> from <> "\n" <> "to " <> to + liftIO $ copyFile from to libDir, libNewDir, libOldDir :: FilePath (libDir, libNewDir, libOldDir) = ("lib", "lib~new", "lib~old") @@ -124,8 +78,8 @@ -- Since POSIX at least guarantees atomic renames, the only place this -- can fail is between steps 3, 4, and 5. In that case, at least the -- @lib~old@ will still exist and can be put back by the user. -installBuildList :: Maybe PkgPath -> BuildList -> PkgM () -installBuildList p bl = do +installBuildList :: CacheDir -> Maybe PkgPath -> BuildList -> PkgM () +installBuildList cachedir p bl = do libdir_exists <- liftIO $ doesDirectoryExist libDir -- 1 @@ -134,7 +88,7 @@ createDirectoryIfMissing False libNewDir -- 2 - installInDir bl libNewDir + installInDir cachedir bl libNewDir -- 3 when libdir_exists $ @@ -230,61 +184,65 @@ T.writeFile futharkPkg $ prettyPkgManifest m _ -> Nothing +withCacheDir :: (CacheDir -> IO a) -> IO a +withCacheDir f = withSystemTempDirectory "futhark-pkg" $ f . CacheDir + doCheck :: String -> [String] -> IO () doCheck = cmdMain "check" $ \args cfg -> case args of - [] -> Just $ - runPkgM cfg $ do - m <- getPkgManifest - bl <- solveDeps $ pkgRevDeps m + [] -> Just . withCacheDir $ \cachedir -> runPkgM cfg $ do + m <- getPkgManifest + bl <- solveDeps cachedir $ pkgRevDeps m - liftIO $ T.putStrLn "Dependencies chosen:" - liftIO $ T.putStr $ prettyBuildList bl + liftIO $ T.putStrLn "Dependencies chosen:" + liftIO $ T.putStr $ prettyBuildList bl - case commented $ manifestPkgPath m of - Nothing -> pure () - Just p -> do - let pdir = "lib" T.unpack p + case commented $ manifestPkgPath m of + Nothing -> pure () + Just p -> do + let pdir = "lib" T.unpack p - pdir_exists <- liftIO $ doesDirectoryExist pdir + pdir_exists <- liftIO $ doesDirectoryExist pdir - unless pdir_exists $ - liftIO $ do - T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not exist." - exitFailure + unless pdir_exists $ + liftIO $ do + T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not exist." + exitFailure - anything <- - liftIO $ - any ((== ".fut") . takeExtension) - <$> directoryContents ("lib" T.unpack p) - unless anything $ - liftIO $ do - T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not contain any .fut files." - exitFailure + anything <- + liftIO $ + any ((== ".fut") . takeExtension) + <$> directoryContents ("lib" T.unpack p) + unless anything $ + liftIO $ do + T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not contain any .fut files." + exitFailure _ -> Nothing doSync :: String -> [String] -> IO () doSync = cmdMain "" $ \args cfg -> case args of - [] -> Just $ - runPkgM cfg $ do - m <- getPkgManifest - bl <- solveDeps $ pkgRevDeps m - installBuildList (commented $ manifestPkgPath m) bl + [] -> Just . withCacheDir $ \cachedir -> runPkgM cfg $ do + m <- getPkgManifest + bl <- solveDeps cachedir $ pkgRevDeps m + installBuildList cachedir (commented $ manifestPkgPath m) bl _ -> Nothing doAdd :: String -> [String] -> IO () doAdd = cmdMain "PKGPATH" $ \args cfg -> case args of - [p, v] | Right v' <- parseVersion $ T.pack v -> Just $ runPkgM cfg $ doAdd' (T.pack p) v' + [p, v] + | Right v' <- parseVersion $ T.pack v -> + Just $ withCacheDir $ \cachedir -> + runPkgM cfg $ doAdd' cachedir (T.pack p) v' [p] -> - Just $ + Just $ withCacheDir $ \cachedir -> runPkgM cfg $ -- Look up the newest revision of the package. - doAdd' (T.pack p) =<< lookupNewestRev (T.pack p) + doAdd' cachedir (T.pack p) =<< lookupNewestRev cachedir (T.pack p) _ -> Nothing where - doAdd' p v = do + doAdd' cachedir p v = do m <- getPkgManifest -- See if this package (and its dependencies) even exists. We @@ -292,11 +250,11 @@ -- in the manifest, plus this new one. The Monoid instance for -- PkgRevDeps is left-biased, so we are careful to use the new -- version for this package. - _ <- solveDeps $ PkgRevDeps (M.singleton p (v, Nothing)) <> pkgRevDeps m + _ <- solveDeps cachedir $ PkgRevDeps (M.singleton p (v, Nothing)) <> pkgRevDeps m -- We either replace any existing occurence of package 'p', or -- we add a new one. - p_info <- lookupPackageRev p v + p_info <- lookupPackageRev cachedir p v let hash = case (_svMajor v, _svMinor v, _svPatch v) of -- We do not perform hash-pinning for -- (0,0,0)-versions, because these already embed a @@ -372,19 +330,18 @@ doUpgrade :: String -> [String] -> IO () doUpgrade = cmdMain "" $ \args cfg -> case args of - [] -> Just $ - runPkgM cfg $ do - m <- getPkgManifest - rs <- traverse (mapM (traverse upgrade)) $ manifestRequire m - putPkgManifest m {manifestRequire = rs} - if rs == manifestRequire m - then liftIO $ T.putStrLn "Nothing to upgrade." - else liftIO $ T.putStrLn "Remember to run 'futhark pkg sync'." + [] -> Just . withCacheDir $ \cachedir -> runPkgM cfg $ do + m <- getPkgManifest + rs <- traverse (mapM (traverse (upgrade cachedir))) $ manifestRequire m + putPkgManifest m {manifestRequire = rs} + if rs == manifestRequire m + then liftIO $ T.putStrLn "Nothing to upgrade." + else liftIO $ T.putStrLn "Remember to run 'futhark pkg sync'." _ -> Nothing where - upgrade req = do - v <- lookupNewestRev $ requiredPkg req - h <- pkgRevCommit <$> lookupPackageRev (requiredPkg req) v + upgrade cachedir req = do + v <- lookupNewestRev cachedir $ requiredPkg req + h <- pkgRevCommit <$> lookupPackageRev cachedir (requiredPkg req) v when (v /= requiredPkgRev req) $ liftIO $ @@ -406,12 +363,13 @@ doVersions :: String -> [String] -> IO () doVersions = cmdMain "PKGPATH" $ \args cfg -> case args of - [p] -> Just $ runPkgM cfg $ doVersions' $ T.pack p + [p] -> Just $ withCacheDir $ \cachedir -> + runPkgM cfg $ doVersions' cachedir $ T.pack p _ -> Nothing where - doVersions' = + doVersions' cachedir = mapM_ (liftIO . T.putStrLn . prettySemVer) . M.keys . pkgVersions - <=< lookupPackage + <=< lookupPackage cachedir -- | Run @futhark pkg@. main :: String -> [String] -> IO () @@ -453,12 +411,11 @@ _ -> do let bad _ () = Just $ do let k = maxinum (map (length . fst) commands) + 3 - usageMsg $ - T.unlines $ - [" ...:", "", "Commands:"] - ++ [ " " <> T.pack cmd <> T.pack (replicate (k - length cmd) ' ') <> desc - | (cmd, (_, desc)) <- commands - ] + usageMsg . T.unlines $ + [" ...:", "", "Commands:"] + ++ [ " " <> T.pack cmd <> T.pack (replicate (k - length cmd) ' ') <> desc + | (cmd, (_, desc)) <- commands + ] mainWithOptions () [] usage bad prog args where 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 @@ -30,7 +30,6 @@ import NeatInterpolation (text) import System.Console.Haskeline qualified as Haskeline import System.Directory -import System.FilePath import System.IO (stdout) import Text.Read (readMaybe) @@ -150,36 +149,24 @@ newFutharkiState :: Int -> LoadedProg -> Maybe FilePath -> IO (Either (Doc AnsiStyle) FutharkiState) newFutharkiState count prev_prog maybe_file = runExceptT $ do - (prog, tenv, ienv) <- case maybe_file of - Nothing -> do - -- Load the builtins through the type checker. - prog <- - badOnLeft prettyProgErrors =<< liftIO (reloadProg prev_prog [] M.empty) - -- Then into the interpreter. - ienv <- - foldM - (\ctx -> badOnLeft (pretty . show) <=< runInterpreter' . I.interpretImport ctx) - I.initialCtx - $ map (fmap fileProg) (lpImports prog) - - let (tenv, ienv') = - extendEnvs prog (T.initialEnv, ienv) ["/prelude/prelude"] - - pure (prog, tenv, ienv') - Just file -> do - prog <- badOnLeft prettyProgErrors =<< liftIO (reloadProg prev_prog [file] M.empty) - liftIO $ putDoc $ prettyWarnings $ lpWarnings prog - - ienv <- - foldM - (\ctx -> badOnLeft (pretty . show) <=< runInterpreter' . I.interpretImport ctx) - I.initialCtx - $ map (fmap fileProg) (lpImports prog) - - let (tenv, ienv') = - extendEnvs prog (T.initialEnv, ienv) ["/prelude/prelude", dropExtension file] + let files = maybeToList maybe_file + -- Put code through the type checker. + prog <- + badOnLeft prettyProgErrors + =<< liftIO (reloadProg prev_prog files M.empty) + liftIO $ putDoc $ prettyWarnings $ lpWarnings prog + -- Then into the interpreter. + ictx <- + foldM + (\ctx -> badOnLeft (pretty . show) <=< runInterpreterNoBreak . I.interpretImport ctx) + I.initialCtx + $ map (fmap fileProg) (lpImports prog) - pure (prog, tenv, ienv') + let (tenv, ienv) = + let (iname, fm) = last $ lpImports prog + in ( fileScope fm, + ictx {I.ctxEnv = I.ctxImports ictx M.! iname} + ) pure FutharkiState @@ -267,7 +254,7 @@ Left e -> liftIO $ putDoc $ prettyProgErrors e Right prog -> do env <- gets futharkiEnv - let (tenv, ienv) = extendEnvs prog env (map fst $ decImports d) + let (tenv, ienv) = extendEnvs prog env $ map fst $ decImports d imports = lpImports prog src = lpNameSource prog case T.checkDec imports src tenv cur_import d of @@ -371,8 +358,8 @@ c -runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) -runInterpreter' m = runF m (pure . Right) intOp +runInterpreterNoBreak :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) +runInterpreterNoBreak m = runF m (pure . Right) intOp where intOp (I.ExtOpError err) = pure $ Left err intOp (I.ExtOpTrace w v c) = do 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 @@ -12,13 +12,11 @@ import Futhark.Compiler import Futhark.Data.Reader (readValues) import Futhark.Pipeline -import Futhark.Util (toPOSIX) import Futhark.Util.Options import Futhark.Util.Pretty (AnsiStyle, Doc, align, hPutDoc, hPutDocLn, pretty, unAnnotate, (<+>)) import Language.Futhark import Language.Futhark.Interpreter qualified as I import Language.Futhark.Semantic qualified as T -import Language.Futhark.TypeChecker qualified as T import System.Exit import System.FilePath import System.IO @@ -112,7 +110,7 @@ FilePath -> IO (Either (Doc AnsiStyle) (T.Env, I.Ctx)) newFutharkiState cfg file = runExceptT $ do - (ws, imports, src) <- + (ws, imports, _src) <- badOnLeft prettyCompilerError =<< liftIO ( runExceptT (readProgramFile [] file) @@ -124,30 +122,20 @@ hPutDoc stderr $ prettyWarnings ws - let imp = T.mkInitialImport "." - ienv1 <- + ictx <- foldM (\ctx -> badOnLeft I.prettyInterpreterError <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $ map (fmap fileProg) imports - (tenv1, d1, src') <- - badOnLeft T.prettyTypeError . snd $ - T.checkDec imports src T.initialEnv imp $ - mkOpen "/prelude/prelude" - (tenv2, d2, _) <- - badOnLeft T.prettyTypeError . snd $ - T.checkDec imports src' tenv1 imp $ - mkOpen $ - toPOSIX $ - dropExtension file - ienv2 <- badOnLeft I.prettyInterpreterError =<< runInterpreter' (I.interpretDec ienv1 d1) - ienv3 <- badOnLeft I.prettyInterpreterError =<< runInterpreter' (I.interpretDec ienv2 d2) - pure (tenv2, ienv3) + let (tenv, ienv) = + let (iname, fm) = last imports + in ( fileScope fm, + ictx {I.ctxEnv = I.ctxImports ictx M.! iname} + ) + + pure (tenv, ienv) where badOnLeft :: (err -> err') -> Either err a -> ExceptT err' IO a badOnLeft _ (Right x) = pure x badOnLeft p (Left err) = throwError $ p err - -mkOpen :: FilePath -> UncheckedDec -mkOpen f = OpenDec (ModImport f NoInfo mempty) mempty runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) runInterpreter' m = runF m (pure . Right) intOp 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 @@ -15,6 +15,7 @@ import Data.Map.Strict qualified as M import Data.Text qualified as T import Data.Text.Encoding qualified as T +import Data.Text.IO qualified as T import Futhark.Analysis.Metrics.Type import Futhark.Server import Futhark.Test @@ -215,7 +216,7 @@ let dir = takeDirectory program runInterpretedCase run@(TestRun _ inputValues _ index _) = unless (any (`elem` runTags run) ["compiled", "script"]) $ - context ("Entry point: " <> entry <> "; dataset: " <> T.pack (runDescription run)) $ do + context ("Entry point: " <> entry <> "; dataset: " <> runDescription run) $ do input <- T.unlines . map valueText <$> getValues (FutharkExe futhark) dir inputValues expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run (code, output, err) <- @@ -325,7 +326,7 @@ "Entry point: " <> entry <> "; dataset: " - <> T.pack (runDescription run) + <> runDescription run context1 case_ctx $ do expected <- getExpectedResult futhark program entry run @@ -491,9 +492,9 @@ putStatusTable ts clearLine w <- maybe 80 Terminal.width <$> Terminal.size - putStrLn $ atMostChars (w - length labelstr) running + T.putStrLn $ atMostChars (w - T.length labelstr) running where - running = labelstr ++ (unwords . reverse . map testCaseProgram . testStatusRun) ts + running = labelstr <> (T.unwords . reverse . map (T.pack . testCaseProgram) . testStatusRun) ts labelstr = "Now testing: " moveCursorToTableTop :: IO () 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 @@ -69,13 +69,12 @@ GC.opsAllocate = allocateCUDABuffer, GC.opsDeallocate = deallocateCUDABuffer, GC.opsCopy = copyCUDAMemory, - GC.opsStaticArray = staticCUDAArray, GC.opsMemoryType = cudaMemoryType, GC.opsCompiler = callKernel, GC.opsFatMemory = True, GC.opsCritical = - ( [C.citems|CUDA_SUCCEED_FATAL(cuCtxPushCurrent(ctx->cuda.cu_ctx));|], - [C.citems|CUDA_SUCCEED_FATAL(cuCtxPopCurrent(&ctx->cuda.cu_ctx));|] + ( [C.citems|CUDA_SUCCEED_FATAL(cuCtxPushCurrent(ctx->cu_ctx));|], + [C.citems|CUDA_SUCCEED_FATAL(cuCtxPopCurrent(&ctx->cu_ctx));|] ) } cuda_includes = @@ -199,7 +198,7 @@ allocateCUDABuffer mem size tag "device" = GC.stm [C.cstm|ctx->error = - CUDA_SUCCEED_NONFATAL(cuda_alloc(&ctx->cuda, ctx->log, + CUDA_SUCCEED_NONFATAL(cuda_alloc(ctx, ctx->log, (size_t)$exp:size, $exp:tag, &$exp:mem, (size_t*)&$exp:size));|] allocateCUDABuffer _ _ _ space = @@ -207,7 +206,7 @@ deallocateCUDABuffer :: GC.Deallocate OpenCL () deallocateCUDABuffer mem size tag "device" = - GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_free(&ctx->cuda, $exp:mem, $exp:size, $exp:tag));|] + GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_free(ctx, $exp:mem, $exp:size, $exp:tag));|] deallocateCUDABuffer _ _ _ space = error $ "Cannot deallocate in '" ++ space ++ "' memory space." @@ -238,43 +237,6 @@ ++ show srcSpace ++ "'." -staticCUDAArray :: GC.StaticArray OpenCL () -staticCUDAArray name "device" t vs = do - let ct = GC.primTypeToCType t - name_realtype <- newVName $ baseString name ++ "_realtype" - num_elems <- 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''};|] - pure $ length vs'' - ArrayZeros n -> do - GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] - pure n - -- Fake a memory block. - GC.contextFieldDyn - (C.toIdent name mempty) - [C.cty|struct memblock_device|] - Nothing - [C.cstm|cuMemFree(ctx->$id:name.mem);|] - -- During startup, copy the data to where we need it. - GC.atInit - [C.cstm|{ - ctx->$id:name.references = NULL; - ctx->$id:name.size = 0; - CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->$id:name.mem, - ($int:num_elems > 0 ? $int:num_elems : 1)*sizeof($ty:ct))); - if ($int:num_elems > 0) { - CUDA_SUCCEED_FATAL(cuMemcpyHtoD(ctx->$id:name.mem, $id:name_realtype, - $int:num_elems*sizeof($ty:ct))); - } - }|] - GC.item [C.citem|struct memblock_device $id:name = ctx->$id:name;|] -staticCUDAArray _ space _ _ = - error $ - "CUDA backend cannot create static array in '" - ++ space - ++ "' memory space" - cudaMemoryType :: GC.MemoryType OpenCL () cudaMemoryType "device" = pure [C.cty|typename CUdeviceptr|] cudaMemoryType space = @@ -284,7 +246,7 @@ kernelConstToExp (SizeConst key) = [C.cexp|*ctx->tuning_params.$id:key|] kernelConstToExp (SizeMaxConst size_class) = - [C.cexp|ctx->cuda.$id:field|] + [C.cexp|ctx->$id:field|] where field = "max_" <> cudaSizeClass size_class cudaSizeClass SizeThreshold {} = "threshold" @@ -379,7 +341,7 @@ } $items:bef CUDA_SUCCEED_OR_RETURN( - cuLaunchKernel(ctx->$id:kernel_name, + cuLaunchKernel(ctx->program->$id:kernel_name, grid[0], grid[1], grid[2], $exp:block_x, $exp:block_y, $exp:block_z, $exp:shared_tot, NULL, 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 @@ -8,8 +8,8 @@ ) where +import Control.Monad import Data.Map qualified as M -import Data.Maybe import Data.Text qualified as T import Futhark.CodeGen.Backends.COpenCL.Boilerplate ( copyDevToDev, @@ -18,15 +18,16 @@ copyScalarFromDev, copyScalarToDev, costCentreReport, - failureSwitch, + failureMsgFunction, + generateTuningParams, kernelRuns, kernelRuntime, ) import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.GenericC.Pretty import Futhark.CodeGen.ImpCode.OpenCL -import Futhark.CodeGen.RTS.C (cudaH) -import Futhark.Util (chunk, zEncodeText) +import Futhark.CodeGen.RTS.C (backendsCudaH) +import Futhark.Util (chunk) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C @@ -39,9 +40,9 @@ ( [C.citems| typename cudaEvent_t *pevents = NULL; if (ctx->profiling && !ctx->profiling_paused) { - pevents = cuda_get_events(&ctx->cuda, - &ctx->$id:(kernelRuns name), - &ctx->$id:(kernelRuntime name)); + pevents = cuda_get_events(ctx, + &ctx->program->$id:(kernelRuns name), + &ctx->program->$id:(kernelRuntime name)); CUDA_SUCCEED_FATAL(cudaEventRecord(pevents[0], 0)); } |], @@ -52,6 +53,35 @@ |] ) +generateCUDADecls :: + [Name] -> + M.Map KernelName KernelSafety -> + GC.CompilerM op s () +generateCUDADecls cost_centres kernels = do + let forCostCentre name = do + GC.contextField + (C.toIdent (kernelRuntime name) mempty) + [C.cty|typename int64_t|] + (Just [C.cexp|0|]) + GC.contextField + (C.toIdent (kernelRuns name) mempty) + [C.cty|int|] + (Just [C.cexp|0|]) + + forM_ (M.keys kernels) $ \name -> do + GC.contextFieldDyn + (C.toIdent name mempty) + [C.cty|typename CUfunction|] + [C.cstm| + CUDA_SUCCEED_FATAL(cuModuleGetFunction( + &ctx->program->$id:name, + ctx->module, + $string:(T.unpack (idText (C.toIdent name mempty)))));|] + [C.cstm|{}|] + forCostCentre name + + mapM_ forCostCentre cost_centres + -- | Called after most code has been generated to generate the bulk of -- the boilerplate. generateBoilerplate :: @@ -63,414 +93,54 @@ [FailureMsg] -> GC.CompilerM OpenCL () () generateBoilerplate cuda_program cuda_prelude cost_centres kernels sizes failures = do + let cuda_program_fragments = + -- Some C compilers limit the size of literal strings, so + -- chunk the entire program into small bits here, and + -- concatenate it again at runtime. + [[C.cinit|$string:s|] | s <- chunk 2000 $ T.unpack $ cuda_prelude <> cuda_program] + program_fragments = cuda_program_fragments ++ [[C.cinit|NULL|]] + let max_failure_args = foldl max 0 $ map (errorMsgNumArgs . failureError) failures + generateTuningParams sizes mapM_ GC.earlyDecl - [C.cunit| - $esc:("#include ") - $esc:("#include ") - $esc:(T.unpack cudaH) - const char *cuda_program[] = {$inits:fragments, NULL}; - |] - - generateSizeFuns sizes - cfg <- generateConfigFuns sizes - generateContextFuns cfg cost_centres kernels sizes failures - - GC.profileReport [C.citem|CUDA_SUCCEED_FATAL(cuda_tally_profiling_records(&ctx->cuda));|] - mapM_ GC.profileReport $ costCentreReport $ cost_centres ++ M.keys kernels - where - fragments = - [ [C.cinit|$string:s|] - | s <- chunk 2000 $ T.unpack $ cuda_prelude <> cuda_program - ] - -generateSizeFuns :: M.Map Name SizeClass -> GC.CompilerM OpenCL () () -generateSizeFuns sizes = do - let strinit s = [C.cinit|$string:(T.unpack s)|] - size_name_inits = map (strinit . prettyText) $ M.keys sizes - size_var_inits = map (strinit . zEncodeText . prettyText) $ M.keys sizes - size_class_inits = map (strinit . prettyText) $ M.elems sizes - - GC.earlyDecl [C.cedecl|static const char *tuning_param_names[] = { $inits:size_name_inits };|] - GC.earlyDecl [C.cedecl|static const char *tuning_param_vars[] = { $inits:size_var_inits };|] - GC.earlyDecl [C.cedecl|static const char *tuning_param_classes[] = { $inits:size_class_inits };|] - -generateConfigFuns :: M.Map Name SizeClass -> GC.CompilerM OpenCL () T.Text -generateConfigFuns sizes = do - let size_decls = map (\k -> [C.csdecl|typename int64_t *$id:k;|]) $ M.keys sizes - num_sizes = M.size sizes - GC.earlyDecl [C.cedecl|struct tuning_params { $sdecls:size_decls };|] - cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s {int in_use; - struct cuda_config cu_cfg; - int profiling; - typename int64_t tuning_params[$int:num_sizes]; - int num_nvrtc_opts; - const char **nvrtc_opts; - const char *cache_fname; - };|] - ) - - let size_value_inits = zipWith sizeInit [0 .. M.size sizes - 1] (M.elems sizes) - sizeInit i size = [C.cstm|cfg->tuning_params[$int:i] = $int:val;|] - where - val = fromMaybe 0 $ sizeDefault size - GC.publicDef_ "context_config_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:cfg* $id:s(void);|], - [C.cedecl|struct $id:cfg* $id:s(void) { - struct $id:cfg *cfg = (struct $id:cfg*) malloc(sizeof(struct $id:cfg)); - if (cfg == NULL) { - return NULL; - } - cfg->in_use = 0; - - cfg->profiling = 0; - cfg->num_nvrtc_opts = 0; - cfg->nvrtc_opts = (const char**) malloc(sizeof(const char*)); - cfg->nvrtc_opts[0] = NULL; - cfg->cache_fname = NULL; - $stms:size_value_inits - cuda_config_init(&cfg->cu_cfg, $int:num_sizes, - tuning_param_names, tuning_param_vars, - cfg->tuning_params, tuning_param_classes); - return cfg; - }|] - ) - - GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg) { - assert(!cfg->in_use); - free(cfg->nvrtc_opts); - free(cfg); - }|] - ) - - GC.publicDef_ "context_config_add_nvrtc_option" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *opt);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *opt) { - cfg->nvrtc_opts[cfg->num_nvrtc_opts] = opt; - cfg->num_nvrtc_opts++; - cfg->nvrtc_opts = (const char**) realloc(cfg->nvrtc_opts, (cfg->num_nvrtc_opts+1) * sizeof(const char*)); - cfg->nvrtc_opts[cfg->num_nvrtc_opts] = NULL; - }|] - ) - - GC.publicDef_ "context_config_set_debugging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - cfg->cu_cfg.logging = cfg->cu_cfg.debugging = flag; - }|] - ) - - GC.publicDef_ "context_config_set_profiling" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - cfg->profiling = flag; - }|] - ) - - GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - cfg->cu_cfg.logging = flag; - }|] - ) - - GC.publicDef_ "context_config_set_device" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *s);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *s) { - set_preferred_device(&cfg->cu_cfg, s); - }|] - ) - - GC.publicDef_ "context_config_dump_program_to" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { - cfg->cu_cfg.dump_program_to = path; - }|] - ) - - GC.publicDef_ "context_config_load_program_from" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { - cfg->cu_cfg.load_program_from = path; - }|] - ) - - GC.publicDef_ "context_config_dump_ptx_to" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { - cfg->cu_cfg.dump_ptx_to = path; - }|] - ) - - GC.publicDef_ "context_config_load_ptx_from" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { - cfg->cu_cfg.load_ptx_from = path; - }|] - ) - - GC.publicDef_ "context_config_set_default_group_size" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int size);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { - cfg->cu_cfg.default_block_size = size; - cfg->cu_cfg.default_block_size_changed = 1; - }|] - ) - - GC.publicDef_ "context_config_set_default_num_groups" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int num) { - cfg->cu_cfg.default_grid_size = num; - cfg->cu_cfg.default_grid_size_changed = 1; - }|] - ) - - GC.publicDef_ "context_config_set_default_tile_size" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { - cfg->cu_cfg.default_tile_size = size; - cfg->cu_cfg.default_tile_size_changed = 1; - }|] - ) - - GC.publicDef_ "context_config_set_default_reg_tile_size" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { - cfg->cu_cfg.default_reg_tile_size = size; - }|] - ) - - GC.publicDef_ "context_config_set_default_threshold" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { - cfg->cu_cfg.default_threshold = size; - }|] - ) - - GC.publicDef_ "context_config_set_tuning_param" GC.InitDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *param_name, size_t new_value);|], - [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *param_name, size_t new_value) { - - for (int i = 0; i < $int:num_sizes; i++) { - if (strcmp(param_name, tuning_param_names[i]) == 0) { - cfg->tuning_params[i] = new_value; - return 0; - } - } - - if (strcmp(param_name, "default_group_size") == 0) { - cfg->cu_cfg.default_block_size = new_value; - return 0; - } - - if (strcmp(param_name, "default_num_groups") == 0) { - cfg->cu_cfg.default_grid_size = new_value; - return 0; - } - - if (strcmp(param_name, "default_threshold") == 0) { - cfg->cu_cfg.default_threshold = new_value; - return 0; - } - - if (strcmp(param_name, "default_tile_size") == 0) { - cfg->cu_cfg.default_tile_size = new_value; - return 0; - } - - if (strcmp(param_name, "default_reg_tile_size") == 0) { - cfg->cu_cfg.default_reg_tile_size = new_value; - return 0; - } - - return 1; - }|] - ) - pure cfg - -generateContextFuns :: - T.Text -> - [Name] -> - M.Map KernelName KernelSafety -> - M.Map Name SizeClass -> - [FailureMsg] -> - GC.CompilerM OpenCL () () -generateContextFuns cfg cost_centres kernels sizes failures = do - final_inits <- GC.contextFinalInits - (fields, init_fields, free_fields) <- GC.contextContents - let forCostCentre name = - [ ( [C.csdecl|typename int64_t $id:(kernelRuntime name);|], - [C.cstm|ctx->$id:(kernelRuntime name) = 0;|] - ), - ( [C.csdecl|int $id:(kernelRuns name);|], - [C.cstm|ctx->$id:(kernelRuns name) = 0;|] - ) - ] - - forKernel name = - ( [C.csdecl|typename CUfunction $id:name;|], - [C.cstm|CUDA_SUCCEED_FATAL(cuModuleGetFunction( - &ctx->$id:name, - ctx->cuda.module, - $string:(T.unpack (idText (C.toIdent name mempty)))));|] - ) - : forCostCentre name - - (kernel_fields, init_kernel_fields) = - unzip $ - concatMap forKernel (M.keys kernels) - ++ concatMap forCostCentre cost_centres + [C.cunit|static const int max_failure_args = $int:max_failure_args; + static const char *cuda_program[] = {$inits:program_fragments, NULL}; + $esc:(T.unpack backendsCudaH) + |] + GC.earlyDecl $ failureMsgFunction failures - ctx <- GC.publicDef "context" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { - struct $id:cfg* cfg; - int detail_memory; - int debugging; - int profiling; - int profiling_paused; - int logging; - struct free_list free_list; - typename lock_t lock; - char *error; - typename lock_t error_lock; - typename FILE *log; - $sdecls:fields - $sdecls:kernel_fields - typename CUdeviceptr global_failure; - typename CUdeviceptr global_failure_args; - struct cuda_context cuda; - struct tuning_params tuning_params; - // True if a potentially failing kernel has been enqueued. - typename int32_t failure_is_an_option; + generateCUDADecls cost_centres kernels - int total_runs; - long int total_runtime; - };|] - ) + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_add_nvrtc_option(struct futhark_context_config *cfg, const char* opt);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_ptx_from(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size);|] let set_tuning_params = zipWith - (\i k -> [C.cstm|ctx->tuning_params.$id:k = &cfg->tuning_params[$int:i];|]) + (\i k -> [C.cstm|ctx->tuning_params.$id:k = &ctx->cfg->tuning_params[$int:i];|]) [(0 :: Int) ..] $ M.keys sizes - max_failure_args = - foldl max 0 $ map (errorMsgNumArgs . failureError) failures - GC.publicDef_ "context_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], - [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) { - assert(!cfg->in_use); - struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); - if (ctx == NULL) { - return NULL; - } - ctx->cfg = cfg; - ctx->cfg->in_use = 1; - ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging; - ctx->profiling = cfg->profiling; - ctx->profiling_paused = 0; - ctx->logging = cfg->cu_cfg.logging; - ctx->error = NULL; - context_setup(ctx); - ctx->log = stderr; - ctx->cuda.profiling_records_capacity = 200; - ctx->cuda.profiling_records_used = 0; - ctx->cuda.profiling_records = - malloc(ctx->cuda.profiling_records_capacity * - sizeof(struct profiling_record)); - - ctx->cuda.cfg = cfg->cu_cfg; - - ctx->failure_is_an_option = 0; - ctx->total_runs = 0; - ctx->total_runtime = 0; - $stms:init_fields - - ctx->error = cuda_setup(&ctx->cuda, cuda_program, cfg->nvrtc_opts, cfg->cache_fname); - - if (ctx->error != NULL) { - futhark_panic(1, "%s\n", ctx->error); - } - - typename int32_t no_error = -1; - CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->global_failure, sizeof(no_error))); - CUDA_SUCCEED_FATAL(cuMemcpyHtoD(ctx->global_failure, &no_error, sizeof(no_error))); - // The +1 is to avoid zero-byte allocations. - CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->global_failure_args, sizeof(int64_t)*($int:max_failure_args+1))); - - $stms:init_kernel_fields - - $stms:final_inits - $stms:set_tuning_params - - init_constants(ctx); - // Clear the free list of any deallocations that occurred while initialising constants. - CUDA_SUCCEED_FATAL(cuda_free_all(&ctx->cuda)); - - futhark_context_sync(ctx); - - return ctx; - }|] - ) - - GC.publicDef_ "context_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|], - [C.cedecl|void $id:s(struct $id:ctx* ctx) { - $stms:free_fields - context_teardown(ctx); - cuMemFree(ctx->global_failure); - cuMemFree(ctx->global_failure_args); - cuda_cleanup(&ctx->cuda); - ctx->cfg->in_use = 0; - free(ctx); - }|] - ) - - GC.publicDef_ "context_sync" GC.MiscDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|], - [C.cedecl|int $id:s(struct $id:ctx* ctx) { - CUDA_SUCCEED_OR_RETURN(cuCtxPushCurrent(ctx->cuda.cu_ctx)); - CUDA_SUCCEED_OR_RETURN(cuCtxSynchronize()); - if (ctx->failure_is_an_option) { - // Check for any delayed error. - typename int32_t failure_idx; - CUDA_SUCCEED_OR_RETURN( - cuMemcpyDtoH(&failure_idx, - ctx->global_failure, - sizeof(int32_t))); - ctx->failure_is_an_option = 0; - - if (failure_idx >= 0) { - // We have to clear global_failure so that the next entry point - // is not considered a failure from the start. - typename int32_t no_failure = -1; - CUDA_SUCCEED_OR_RETURN( - cuMemcpyHtoD(ctx->global_failure, - &no_failure, - sizeof(int32_t))); - - typename int64_t args[$int:max_failure_args+1]; - CUDA_SUCCEED_OR_RETURN( - cuMemcpyDtoH(&args, - ctx->global_failure_args, - sizeof(args))); - - $stm:(failureSwitch failures) + GC.earlyDecl + [C.cedecl|static void set_tuning_params(struct futhark_context* ctx) { + $stms:set_tuning_params + }|] - return FUTHARK_PROGRAM_ERROR; - } - } - CUDA_SUCCEED_OR_RETURN(cuCtxPopCurrent(&ctx->cuda.cu_ctx)); - return 0; - }|] - ) + GC.generateProgramStruct GC.onClear [C.citem|if (ctx->error == NULL) { - CUDA_SUCCEED_NONFATAL(cuda_free_all(&ctx->cuda)); + CUDA_SUCCEED_NONFATAL(cuda_free_all(ctx)); }|] + + GC.profileReport [C.citem|CUDA_SUCCEED_FATAL(cuda_tally_profiling_records(ctx));|] + mapM_ GC.profileReport $ costCentreReport $ cost_centres ++ M.keys kernels +{-# NOINLINE generateBoilerplate #-} diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -78,7 +78,6 @@ GC.opsAllocate = allocateOpenCLBuffer, GC.opsDeallocate = deallocateOpenCLBuffer, GC.opsCopy = copyOpenCLMemory, - GC.opsStaticArray = staticOpenCLArray, GC.opsMemoryType = openclMemoryType, GC.opsFatMemory = True } @@ -177,7 +176,7 @@ GC.stm [C.cstm|{$item:decl OPENCL_SUCCEED_OR_RETURN( - clEnqueueWriteBuffer(ctx->opencl.queue, $exp:mem, $exp:blocking, + clEnqueueWriteBuffer(ctx->queue, $exp:mem, $exp:blocking, $exp:i * sizeof($ty:t), sizeof($ty:t), &$id:val', 0, NULL, $exp:(profilingEvent copyScalarToDev))); @@ -195,7 +194,7 @@ GC.decl [C.cdecl|$ty:t $id:val;|] GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN( - clEnqueueReadBuffer(ctx->opencl.queue, $exp:mem, + clEnqueueReadBuffer(ctx->queue, $exp:mem, ctx->failure_is_an_option ? CL_FALSE : CL_TRUE, $exp:i * sizeof($ty:t), sizeof($ty:t), &$id:val, @@ -212,7 +211,7 @@ allocateOpenCLBuffer mem size tag "device" = GC.stm [C.cstm|ctx->error = - OPENCL_SUCCEED_NONFATAL(opencl_alloc(&ctx->opencl, ctx->log, + OPENCL_SUCCEED_NONFATAL(opencl_alloc(ctx, ctx->log, (size_t)$exp:size, $exp:tag, &$exp:mem, (size_t*)&$exp:size));|] allocateOpenCLBuffer _ _ _ space = @@ -220,7 +219,7 @@ deallocateOpenCLBuffer :: GC.Deallocate OpenCL () deallocateOpenCLBuffer mem size tag "device" = - GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_free(&ctx->opencl, $exp:mem, $exp:size, $exp:tag));|] + GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_free(ctx, $exp:mem, $exp:size, $exp:tag));|] deallocateOpenCLBuffer _ _ _ space = error $ "Cannot deallocate in '" ++ space ++ "' space" @@ -238,7 +237,7 @@ if ($exp:nbytes > 0) { typename cl_bool sync_call = $exp:(syncArg b); OPENCL_SUCCEED_OR_RETURN( - clEnqueueReadBuffer(ctx->opencl.queue, $exp:srcmem, + clEnqueueReadBuffer(ctx->queue, $exp:srcmem, ctx->failure_is_an_option ? CL_FALSE : sync_call, (size_t)$exp:srcidx, (size_t)$exp:nbytes, $exp:destmem + $exp:destidx, @@ -253,7 +252,7 @@ [C.cstm| if ($exp:nbytes > 0) { OPENCL_SUCCEED_OR_RETURN( - clEnqueueWriteBuffer(ctx->opencl.queue, $exp:destmem, $exp:(syncArg b), + clEnqueueWriteBuffer(ctx->queue, $exp:destmem, $exp:(syncArg b), (size_t)$exp:destidx, (size_t)$exp:nbytes, $exp:srcmem + $exp:srcidx, 0, NULL, $exp:(profilingEvent copyDevToHost))); @@ -266,13 +265,13 @@ [C.cstm|{ if ($exp:nbytes > 0) { OPENCL_SUCCEED_OR_RETURN( - clEnqueueCopyBuffer(ctx->opencl.queue, + clEnqueueCopyBuffer(ctx->queue, $exp:srcmem, $exp:destmem, (size_t)$exp:srcidx, (size_t)$exp:destidx, (size_t)$exp:nbytes, 0, NULL, $exp:(profilingEvent copyDevToDev))); if (ctx->debugging) { - OPENCL_SUCCEED_FATAL(clFinish(ctx->opencl.queue)); + OPENCL_SUCCEED_FATAL(clFinish(ctx->queue)); } } }|] @@ -286,52 +285,11 @@ openclMemoryType space = error $ "OpenCL backend does not support '" ++ space ++ "' memory space." -staticOpenCLArray :: GC.StaticArray OpenCL () -staticOpenCLArray name "device" t vs = do - let ct = GC.primTypeToCType t - name_realtype <- newVName $ baseString name ++ "_realtype" - num_elems <- 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''};|] - pure $ length vs'' - ArrayZeros n -> do - GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] - pure n - -- Fake a memory block. - GC.contextFieldDyn - (C.toIdent name mempty) - [C.cty|struct memblock_device|] - Nothing - [C.cstm|OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->$id:name.mem));|] - -- During startup, copy the data to where we need it. - GC.atInit - [C.cstm|{ - typename cl_int success; - ctx->$id:name.references = NULL; - ctx->$id:name.size = 0; - ctx->$id:name.mem = - clCreateBuffer(ctx->opencl.ctx, CL_MEM_READ_WRITE, - ($int:num_elems > 0 ? $int:num_elems : 1)*sizeof($ty:ct), NULL, - &success); - OPENCL_SUCCEED_OR_RETURN(success); - if ($int:num_elems > 0) { - OPENCL_SUCCEED_OR_RETURN( - clEnqueueWriteBuffer(ctx->opencl.queue, ctx->$id:name.mem, CL_TRUE, - 0, $int:num_elems*sizeof($ty:ct), - $id:name_realtype, - 0, NULL, NULL)); - } - }|] - GC.item [C.citem|struct memblock_device $id:name = ctx->$id:name;|] -staticOpenCLArray _ space _ _ = - error $ "OpenCL backend cannot create static array in memory space '" ++ space ++ "'" - kernelConstToExp :: KernelConst -> C.Exp kernelConstToExp (SizeConst key) = [C.cexp|*ctx->tuning_params.$id:key|] kernelConstToExp (SizeMaxConst size_class) = - [C.cexp|ctx->opencl.$id:field|] + [C.cexp|ctx->$id:field|] where field = "max_" <> prettyString size_class @@ -357,7 +315,7 @@ when (safety == SafetyFull) $ GC.stm [C.cstm| - OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->$id:name, 1, + OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->program->$id:name, 1, sizeof(ctx->failure_is_an_option), &ctx->failure_is_an_option)); |] @@ -385,19 +343,19 @@ _ -> GC.compileExpToName "kernel_arg" pt e GC.stm [C.cstm| - OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->$id:name, $int:i, sizeof($id:v), &$id:v)); + OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->program->$id:name, $int:i, sizeof($id:v), &$id:v)); |] setKernelArg i (MemKArg v) = do v' <- GC.rawMem v GC.stm [C.cstm| - OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->$id:name, $int:i, sizeof($exp:v'), &$exp:v')); + OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->program->$id:name, $int:i, sizeof($exp:v'), &$exp:v')); |] setKernelArg i (SharedMemoryKArg num_bytes) = do num_bytes' <- GC.compileExp $ unCount num_bytes GC.stm [C.cstm| - OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->$id:name, $int:i, (size_t)$exp:num_bytes', NULL)); + OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->program->$id:name, $int:i, (size_t)$exp:num_bytes', NULL)); |] localBytes cur (SharedMemoryKArg num_bytes) = do @@ -433,11 +391,11 @@ } typename cl_event *pevent = $exp:(profilingEvent kernel_name); OPENCL_SUCCEED_OR_RETURN( - clEnqueueNDRangeKernel(ctx->opencl.queue, ctx->$id:kernel_name, $int:kernel_rank, NULL, + clEnqueueNDRangeKernel(ctx->queue, ctx->program->$id:kernel_name, $int:kernel_rank, NULL, $id:global_work_size, $id:local_work_size, 0, NULL, pevent)); if (ctx->debugging) { - OPENCL_SUCCEED_FATAL(clFinish(ctx->opencl.queue)); + OPENCL_SUCCEED_FATAL(clFinish(ctx->queue)); $id:time_end = get_wall_time(); long int $id:time_diff = $id:time_end - $id:time_start; fprintf(ctx->log, "kernel %s runtime: %ldus\n", diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -9,11 +9,12 @@ copyScalarToDev, copyScalarFromDev, commonOptions, - failureSwitch, + failureMsgFunction, costCentreReport, kernelRuntime, kernelRuns, sizeLoggingCode, + generateTuningParams, ) where @@ -26,7 +27,7 @@ import Futhark.CodeGen.Backends.GenericC.Pretty import Futhark.CodeGen.ImpCode.OpenCL import Futhark.CodeGen.OpenCL.Heuristics -import Futhark.CodeGen.RTS.C (openclH) +import Futhark.CodeGen.RTS.C (backendsOpenclH) import Futhark.Util (chunk, zEncodeText) import Futhark.Util.Pretty (prettyTextOneLine) import Language.C.Quote.OpenCL qualified as C @@ -35,8 +36,8 @@ errorMsgNumArgs :: ErrorMsg a -> Int errorMsgNumArgs = length . errorMsgArgTypes -failureSwitch :: [FailureMsg] -> C.Stm -failureSwitch failures = +failureMsgFunction :: [FailureMsg] -> C.Definition +failureMsgFunction failures = let printfEscape = let escapeChar '%' = "%%" escapeChar c = [c] @@ -47,10 +48,13 @@ onFailure i (FailureMsg emsg@(ErrorMsg parts) backtrace) = let msg = concatMap onPart parts ++ "\n" ++ printfEscape backtrace msgargs = [[C.cexp|args[$int:j]|] | j <- [0 .. errorMsgNumArgs emsg - 1]] - in [C.cstm|case $int:i: {ctx->error = msgprintf($string:msg, $args:msgargs); break;}|] + in [C.cstm|case $int:i: {return msgprintf($string:msg, $args:msgargs); break;}|] failure_cases = zipWith onFailure [(0 :: Int) ..] failures - in [C.cstm|switch (failure_idx) { $stms:failure_cases }|] + in [C.cedecl|static char* get_failure_msg(int failure_idx, typename int64_t args[]) { + switch (failure_idx) { $stms:failure_cases } + return strdup("Unknown error. This is a compiler bug."); + }|] copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev :: Name copyDevToDev = "copy_dev_to_dev" @@ -62,525 +66,34 @@ profilingEvent :: Name -> C.Exp profilingEvent name = [C.cexp|(ctx->profiling_paused || !ctx->profiling) ? NULL - : opencl_get_event(&ctx->opencl, - &ctx->$id:(kernelRuns name), - &ctx->$id:(kernelRuntime name))|] - --- | Called after most code has been generated to generate the bulk of --- the boilerplate. -generateBoilerplate :: - T.Text -> - T.Text -> - [Name] -> - M.Map KernelName KernelSafety -> - [PrimType] -> - M.Map Name SizeClass -> - [FailureMsg] -> - GC.CompilerM OpenCL () () -generateBoilerplate opencl_code opencl_prelude cost_centres kernels types sizes failures = do - final_inits <- GC.contextFinalInits - - let (ctx_opencl_fields, ctx_opencl_inits, top_decls, later_top_decls) = - openClDecls cost_centres kernels (opencl_prelude <> opencl_code) - - mapM_ GC.earlyDecl top_decls + : opencl_get_event(ctx, + &ctx->program->$id:(kernelRuns name), + &ctx->program->$id:(kernelRuntime name))|] +generateTuningParams :: M.Map Name SizeClass -> GC.CompilerM op a () +generateTuningParams sizes = do let strinit s = [C.cinit|$string:(T.unpack s)|] + intinit x = [C.cinit|$int:x|] size_name_inits = map (strinit . prettyText) $ M.keys sizes size_var_inits = map (strinit . zEncodeText . prettyText) $ M.keys sizes size_class_inits = map (strinit . prettyText) $ M.elems sizes - num_sizes = M.size sizes - + size_default_inits = map (intinit . fromMaybe 0 . sizeDefault) $ M.elems sizes + size_decls = map (\k -> [C.csdecl|typename int64_t *$id:k;|]) $ M.keys sizes + num_sizes = length sizes + GC.earlyDecl [C.cedecl|struct tuning_params { $sdecls:size_decls };|] + GC.earlyDecl [C.cedecl|static const int num_tuning_params = $int:num_sizes;|] GC.earlyDecl [C.cedecl|static const char *tuning_param_names[] = { $inits:size_name_inits };|] GC.earlyDecl [C.cedecl|static const char *tuning_param_vars[] = { $inits:size_var_inits };|] GC.earlyDecl [C.cedecl|static const char *tuning_param_classes[] = { $inits:size_class_inits };|] - - let size_decls = map (\k -> [C.csdecl|typename int64_t *$id:k;|]) $ M.keys sizes - GC.earlyDecl [C.cedecl|struct tuning_params { $sdecls:size_decls };|] - cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { int in_use; - struct opencl_config opencl; - typename int64_t tuning_params[$int:num_sizes]; - int num_build_opts; - const char **build_opts; - const char *cache_fname; - };|] - ) - - let size_value_inits = zipWith sizeInit [0 .. M.size sizes - 1] (M.elems sizes) - sizeInit i size = [C.cstm|cfg->tuning_params[$int:i] = $int:val;|] - where - val = fromMaybe 0 $ sizeDefault size - GC.publicDef_ "context_config_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:cfg* $id:s(void);|], - [C.cedecl|struct $id:cfg* $id:s(void) { - struct $id:cfg *cfg = (struct $id:cfg*) malloc(sizeof(struct $id:cfg)); - if (cfg == NULL) { - return NULL; - } - - cfg->in_use = 0; - cfg->num_build_opts = 0; - cfg->build_opts = (const char**) malloc(sizeof(const char*)); - cfg->build_opts[0] = NULL; - cfg->cache_fname = NULL; - $stms:size_value_inits - opencl_config_init(&cfg->opencl, $int:num_sizes, - tuning_param_names, tuning_param_vars, - cfg->tuning_params, tuning_param_classes); - return cfg; - }|] - ) - - GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg) { - assert(!cfg->in_use); - free(cfg->build_opts); - free(cfg); - }|] - ) - - GC.publicDef_ "context_config_add_build_option" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *opt);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *opt) { - cfg->build_opts[cfg->num_build_opts] = opt; - cfg->num_build_opts++; - cfg->build_opts = (const char**) realloc(cfg->build_opts, (cfg->num_build_opts+1) * sizeof(const char*)); - cfg->build_opts[cfg->num_build_opts] = NULL; - }|] - ) - - GC.publicDef_ "context_config_set_debugging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - cfg->opencl.profiling = cfg->opencl.logging = cfg->opencl.debugging = flag; - }|] - ) - - GC.publicDef_ "context_config_set_profiling" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - cfg->opencl.profiling = flag; - }|] - ) - - GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - cfg->opencl.logging = flag; - }|] - ) - - GC.publicDef_ "context_config_set_device" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *s);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *s) { - set_preferred_device(&cfg->opencl, s); - }|] - ) - - GC.publicDef_ "context_config_set_platform" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *s);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *s) { - set_preferred_platform(&cfg->opencl, s); - }|] - ) - - GC.publicDef_ "context_config_select_device_interactively" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg) { - select_device_interactively(&cfg->opencl); - }|] - ) - - GC.publicDef_ "context_config_list_devices" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg) { - (void)cfg; - list_devices(); - }|] - ) - - GC.publicDef_ "context_config_dump_program_to" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { - cfg->opencl.dump_program_to = path; - }|] - ) - - GC.publicDef_ "context_config_load_program_from" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { - cfg->opencl.load_program_from = path; - }|] - ) - - GC.publicDef_ "context_config_dump_binary_to" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { - cfg->opencl.dump_binary_to = path; - }|] - ) - - GC.publicDef_ "context_config_load_binary_from" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { - cfg->opencl.load_binary_from = path; - }|] - ) - - GC.publicDef_ "context_config_set_default_group_size" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int size);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { - cfg->opencl.default_group_size = size; - cfg->opencl.default_group_size_changed = 1; - }|] - ) - - GC.publicDef_ "context_config_set_default_num_groups" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int num) { - cfg->opencl.default_num_groups = num; - }|] - ) - - GC.publicDef_ "context_config_set_default_tile_size" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { - cfg->opencl.default_tile_size = size; - cfg->opencl.default_tile_size_changed = 1; - }|] - ) - - GC.publicDef_ "context_config_set_default_reg_tile_size" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { - cfg->opencl.default_reg_tile_size = size; - }|] - ) - - GC.publicDef_ "context_config_set_default_threshold" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { - cfg->opencl.default_threshold = size; - }|] - ) - - GC.publicDef_ "context_config_set_tuning_param" GC.InitDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *param_name, size_t new_value);|], - [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *param_name, size_t new_value) { - - for (int i = 0; i < $int:num_sizes; i++) { - if (strcmp(param_name, tuning_param_names[i]) == 0) { - cfg->tuning_params[i] = new_value; - return 0; - } - } - - if (strcmp(param_name, "default_group_size") == 0) { - cfg->opencl.default_group_size = new_value; - return 0; - } - - if (strcmp(param_name, "default_num_groups") == 0) { - cfg->opencl.default_num_groups = new_value; - return 0; - } - - if (strcmp(param_name, "default_threshold") == 0) { - cfg->opencl.default_threshold = new_value; - return 0; - } - - if (strcmp(param_name, "default_tile_size") == 0) { - cfg->opencl.default_tile_size = new_value; - return 0; - } - - if (strcmp(param_name, "default_reg_tile_size") == 0) { - cfg->opencl.default_reg_tile_size = new_value; - return 0; - } - - return 1; - }|] - ) - - (fields, init_fields, free_fields) <- GC.contextContents - ctx <- GC.publicDef "context" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { - struct $id:cfg* cfg; - int detail_memory; - int debugging; - int profiling; - int profiling_paused; - int logging; - typename lock_t lock; - char *error; - typename lock_t error_lock; - typename FILE *log; - struct free_list free_list; - $sdecls:fields - $sdecls:ctx_opencl_fields - typename cl_mem global_failure; - typename cl_mem global_failure_args; - struct opencl_context opencl; - struct tuning_params tuning_params; - // True if a potentially failing kernel has been enqueued. - typename cl_int failure_is_an_option; - };|] - ) - - mapM_ GC.earlyDecl later_top_decls - - GC.earlyDecl - [C.cedecl|static void init_context_early(struct $id:cfg *cfg, struct $id:ctx* ctx) { - ctx->opencl.cfg = cfg->opencl; - ctx->detail_memory = cfg->opencl.debugging; - ctx->debugging = cfg->opencl.debugging; - ctx->profiling = cfg->opencl.profiling; - ctx->profiling_paused = 0; - ctx->logging = cfg->opencl.logging; - ctx->error = NULL; - context_setup(ctx); - ctx->log = stderr; - ctx->opencl.profiling_records_capacity = 200; - ctx->opencl.profiling_records_used = 0; - ctx->opencl.profiling_records = - malloc(ctx->opencl.profiling_records_capacity * - sizeof(struct profiling_record)); - - ctx->failure_is_an_option = 0; - $stms:init_fields - $stms:ctx_opencl_inits - }|] - - let set_tuning_params = - zipWith - (\i k -> [C.cstm|ctx->tuning_params.$id:k = &cfg->tuning_params[$int:i];|]) - [(0 :: Int) ..] - $ M.keys sizes - max_failure_args = - foldl max 0 $ map (errorMsgNumArgs . failureError) failures - - GC.earlyDecl - [C.cedecl|static int init_context_late(struct $id:cfg *cfg, struct $id:ctx* ctx, typename cl_program prog) { - typename cl_int error; - - typename cl_int no_error = -1; - ctx->global_failure = - clCreateBuffer(ctx->opencl.ctx, - CL_MEM_READ_WRITE | CL_MEM_COPY_HOST_PTR, - sizeof(cl_int), &no_error, &error); - OPENCL_SUCCEED_OR_RETURN(error); - - // The +1 is to avoid zero-byte allocations. - ctx->global_failure_args = - clCreateBuffer(ctx->opencl.ctx, - CL_MEM_READ_WRITE, - sizeof(int64_t)*($int:max_failure_args+1), NULL, &error); - OPENCL_SUCCEED_OR_RETURN(error); - - // Load all the kernels. - $stms:(map loadKernel (M.toList kernels)) - - $stms:final_inits - $stms:set_tuning_params - - init_constants(ctx); - // Clear the free list of any deallocations that occurred while initialising constants. - OPENCL_SUCCEED_OR_RETURN(opencl_free_all(&ctx->opencl)); - - // The program will be properly freed after all the kernels have also been freed. - OPENCL_SUCCEED_OR_RETURN(clReleaseProgram(prog)); - - return futhark_context_sync(ctx); - }|] - - let set_required_types = - [ [C.cstm|required_types |= OPENCL_F64; |] - | FloatType Float64 `elem` types - ] - - GC.publicDef_ "context_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], - [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) { - assert(!cfg->in_use); - struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); - if (ctx == NULL) { - return NULL; - } - ctx->cfg = cfg; - ctx->cfg->in_use = 1; - - int required_types = 0; - $stms:set_required_types - - init_context_early(cfg, ctx); - typename cl_program prog = - setup_opencl(&ctx->opencl, opencl_program, required_types, cfg->build_opts, - cfg->cache_fname); - init_context_late(cfg, ctx, prog); - return ctx; - }|] - ) - - GC.publicDef_ "context_new_with_command_queue" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg, typename cl_command_queue queue);|], - [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg, typename cl_command_queue queue) { - assert(!cfg->in_use); - struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); - if (ctx == NULL) { - return NULL; - } - ctx->cfg = cfg; - ctx->cfg->in_use = 1; - - int required_types = 0; - $stms:set_required_types - - init_context_early(cfg, ctx); - typename cl_program prog = - setup_opencl_with_command_queue(&ctx->opencl, queue, opencl_program, required_types, cfg->build_opts, - cfg->cache_fname); - init_context_late(cfg, ctx, prog); - return ctx; - }|] - ) - - GC.publicDef_ "context_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|], - [C.cedecl|void $id:s(struct $id:ctx* ctx) { - $stms:free_fields - context_teardown(ctx); - $stms:(map releaseKernel (M.toList kernels)) - OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->global_failure)); - OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->global_failure_args)); - teardown_opencl(&ctx->opencl); - ctx->cfg->in_use = 0; - free(ctx); - }|] - ) - - GC.publicDef_ "context_sync" GC.MiscDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|], - [C.cedecl|int $id:s(struct $id:ctx* ctx) { - // Check for any delayed error. - typename cl_int failure_idx = -1; - if (ctx->failure_is_an_option) { - OPENCL_SUCCEED_OR_RETURN( - clEnqueueReadBuffer(ctx->opencl.queue, - ctx->global_failure, - CL_FALSE, - 0, sizeof(typename cl_int), &failure_idx, - 0, NULL, $exp:(profilingEvent copyScalarFromDev))); - ctx->failure_is_an_option = 0; - } - - OPENCL_SUCCEED_OR_RETURN(clFinish(ctx->opencl.queue)); - - if (failure_idx >= 0) { - // We have to clear global_failure so that the next entry point - // is not considered a failure from the start. - typename cl_int no_failure = -1; - OPENCL_SUCCEED_OR_RETURN( - clEnqueueWriteBuffer(ctx->opencl.queue, ctx->global_failure, CL_TRUE, - 0, sizeof(cl_int), &no_failure, - 0, NULL, NULL)); - - typename int64_t args[$int:max_failure_args+1]; - OPENCL_SUCCEED_OR_RETURN( - clEnqueueReadBuffer(ctx->opencl.queue, - ctx->global_failure_args, - CL_TRUE, - 0, sizeof(args), &args, - 0, NULL, $exp:(profilingEvent copyDevToHost))); - - $stm:(failureSwitch failures) - - return FUTHARK_PROGRAM_ERROR; - } - return 0; - }|] - ) - - GC.publicDef_ "context_get_command_queue" GC.InitDecl $ \s -> - ( [C.cedecl|typename cl_command_queue $id:s(struct $id:ctx* ctx);|], - [C.cedecl|typename cl_command_queue $id:s(struct $id:ctx* ctx) { - return ctx->opencl.queue; - }|] - ) - - GC.onClear - [C.citem|if (ctx->error == NULL) { - ctx->error = OPENCL_SUCCEED_NONFATAL(opencl_free_all(&ctx->opencl)); - }|] - - GC.profileReport [C.citem|OPENCL_SUCCEED_FATAL(opencl_tally_profiling_records(&ctx->opencl));|] - mapM_ GC.profileReport $ - costCentreReport $ - cost_centres ++ M.keys kernels - -openClDecls :: - [Name] -> - M.Map KernelName KernelSafety -> - T.Text -> - ([C.FieldGroup], [C.Stm], [C.Definition], [C.Definition]) -openClDecls cost_centres kernels opencl_program = - (ctx_fields, ctx_inits, openCL_boilerplate, openCL_load) - where - opencl_program_fragments = - -- Some C compilers limit the size of literal strings, so - -- chunk the entire program into small bits here, and - -- concatenate it again at runtime. - [ [C.cinit|$string:s|] - | s <- chunk 2000 $ T.unpack opencl_program - ] - - ctx_fields = - [ [C.csdecl|int total_runs;|], - [C.csdecl|long int total_runtime;|] - ] - ++ [ [C.csdecl|typename cl_kernel $id:name;|] - | name <- M.keys kernels - ] - ++ concat - [ [ [C.csdecl|typename int64_t $id:(kernelRuntime name);|], - [C.csdecl|int $id:(kernelRuns name);|] - ] - | name <- cost_centres ++ M.keys kernels - ] - - ctx_inits = - [ [C.cstm|ctx->total_runs = 0;|], - [C.cstm|ctx->total_runtime = 0;|] - ] - ++ concat - [ [ [C.cstm|ctx->$id:(kernelRuntime name) = 0;|], - [C.cstm|ctx->$id:(kernelRuns name) = 0;|] - ] - | name <- cost_centres ++ M.keys kernels - ] - - openCL_load = - [ [C.cedecl| -void post_opencl_setup(struct opencl_context *ctx, struct opencl_device_option *option) { - $stms:(map sizeHeuristicsCode sizeHeuristicsTable) -}|] - ] + GC.earlyDecl [C.cedecl|static typename int64_t tuning_param_defaults[] = { $inits:size_default_inits };|] - program_fragments = opencl_program_fragments ++ [[C.cinit|NULL|]] - openCL_boilerplate = - [C.cunit| - $esc:(T.unpack openclH) - static const char *opencl_program[] = {$inits:program_fragments};|] +releaseKernel :: (KernelName, KernelSafety) -> C.Stm +releaseKernel (name, _) = [C.cstm|OPENCL_SUCCEED_FATAL(clReleaseKernel(ctx->program->$id:name));|] loadKernel :: (KernelName, KernelSafety) -> C.Stm loadKernel (name, safety) = [C.cstm|{ - ctx->$id:name = clCreateKernel(prog, $string:(T.unpack (idText (C.toIdent name mempty))), &error); + ctx->program->$id:name = clCreateKernel(ctx->clprogram, $string:(T.unpack (idText (C.toIdent name mempty))), &error); OPENCL_SUCCEED_FATAL(error); $items:set_args if (ctx->debugging) { @@ -590,20 +103,113 @@ where set_global_failure = [C.citem|OPENCL_SUCCEED_FATAL( - clSetKernelArg(ctx->$id:name, 0, sizeof(typename cl_mem), + clSetKernelArg(ctx->program->$id:name, 0, sizeof(typename cl_mem), &ctx->global_failure));|] set_global_failure_args = [C.citem|OPENCL_SUCCEED_FATAL( - clSetKernelArg(ctx->$id:name, 2, sizeof(typename cl_mem), + clSetKernelArg(ctx->program->$id:name, 2, sizeof(typename cl_mem), &ctx->global_failure_args));|] set_args = case safety of SafetyNone -> [] SafetyCheap -> [set_global_failure] SafetyFull -> [set_global_failure, set_global_failure_args] -releaseKernel :: (KernelName, KernelSafety) -> C.Stm -releaseKernel (name, _) = [C.cstm|OPENCL_SUCCEED_FATAL(clReleaseKernel(ctx->$id:name));|] +generateOpenCLDecls :: + [Name] -> + M.Map KernelName KernelSafety -> + GC.CompilerM op s () +generateOpenCLDecls cost_centres kernels = do + forM_ (M.toList kernels) $ \(name, safety) -> + GC.contextFieldDyn + (C.toIdent name mempty) + [C.cty|typename cl_kernel|] + (loadKernel (name, safety)) + (releaseKernel (name, safety)) + forM_ (cost_centres <> M.keys kernels) $ \name -> do + GC.contextField + (C.toIdent (kernelRuntime name) mempty) + [C.cty|typename int64_t|] + (Just [C.cexp|0|]) + GC.contextField + (C.toIdent (kernelRuns name) mempty) + [C.cty|int|] + (Just [C.cexp|0|]) + GC.earlyDecl + [C.cedecl| +void post_opencl_setup(struct futhark_context *ctx, struct opencl_device_option *option) { + $stms:(map sizeHeuristicsCode sizeHeuristicsTable) +}|] +-- | Called after most code has been generated to generate the bulk of +-- the boilerplate. +generateBoilerplate :: + T.Text -> + T.Text -> + [Name] -> + M.Map KernelName KernelSafety -> + [PrimType] -> + M.Map Name SizeClass -> + [FailureMsg] -> + GC.CompilerM OpenCL () () +generateBoilerplate opencl_program opencl_prelude cost_centres kernels types sizes failures = do + let opencl_program_fragments = + -- Some C compilers limit the size of literal strings, so + -- chunk the entire program into small bits here, and + -- concatenate it again at runtime. + [[C.cinit|$string:s|] | s <- chunk 2000 $ T.unpack $ opencl_prelude <> opencl_program] + program_fragments = opencl_program_fragments ++ [[C.cinit|NULL|]] + f64_required + | FloatType Float64 `elem` types = [C.cexp|1|] + | otherwise = [C.cexp|0|] + max_failure_args = foldl max 0 $ map (errorMsgNumArgs . failureError) failures + generateTuningParams sizes + mapM_ + GC.earlyDecl + [C.cunit|static const int max_failure_args = $int:max_failure_args; + static const int f64_required = $exp:f64_required; + static const char *opencl_program[] = {$inits:program_fragments}; + $esc:(T.unpack backendsOpenclH) + |] + GC.earlyDecl $ failureMsgFunction failures + + generateOpenCLDecls cost_centres kernels + + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_add_build_option(struct futhark_context_config *cfg, const char* opt);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_platform(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_select_device_interactively(struct futhark_context_config *cfg);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_list_devices(struct futhark_context_config *cfg);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_binary_from(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_command_queue(struct futhark_context_config *cfg, typename cl_command_queue);|] + GC.headerDecl GC.MiscDecl [C.cedecl|typename cl_command_queue futhark_context_get_command_queue(struct futhark_context* ctx);|] + + let set_tuning_params = + zipWith + (\i k -> [C.cstm|ctx->tuning_params.$id:k = &ctx->cfg->tuning_params[$int:i];|]) + [(0 :: Int) ..] + $ M.keys sizes + + GC.earlyDecl + [C.cedecl|static void set_tuning_params(struct futhark_context* ctx) { + $stms:set_tuning_params + }|] + + GC.generateProgramStruct + + GC.onClear + [C.citem|if (ctx->error == NULL) { ctx->error = OPENCL_SUCCEED_NONFATAL(opencl_free_all(ctx)); }|] + + GC.profileReport [C.citem|OPENCL_SUCCEED_FATAL(opencl_tally_profiling_records(ctx));|] + mapM_ GC.profileReport $ costCentreReport $ cost_centres ++ M.keys kernels + kernelRuntime :: KernelName -> Name kernelRuntime = (<> "_total_runtime") @@ -627,19 +233,17 @@ in [ [C.citem| str_builder(&builder, $string:(format_string (prettyString name)), - ctx->$id:runs, - (long int) ctx->$id:total_runtime / (ctx->$id:runs != 0 ? ctx->$id:runs : 1), - (long int) ctx->$id:total_runtime); + ctx->program->$id:runs, + (long int) ctx->program->$id:total_runtime / (ctx->program->$id:runs != 0 ? ctx->program->$id:runs : 1), + (long int) ctx->program->$id:total_runtime); |], - [C.citem|ctx->total_runtime += ctx->$id:total_runtime;|], - [C.citem|ctx->total_runs += ctx->$id:runs;|] + [C.citem|ctx->total_runtime += ctx->program->$id:total_runtime;|], + [C.citem|ctx->total_runs += ctx->program->$id:runs;|] ] report_total = - [C.citem| - str_builder(&builder, "%d operations with cumulative runtime: %6ldus\n", - ctx->total_runs, ctx->total_runtime); - |] + [C.citem|str_builder(&builder, "%d operations with cumulative runtime: %6ldus\n", + ctx->total_runs, ctx->total_runtime);|] sizeHeuristicsCode :: SizeHeuristic -> C.Stm sizeHeuristicsCode (SizeHeuristic platform_name device_type which (TPrimExp what)) = @@ -655,11 +259,11 @@ which' = case which of LockstepWidth -> [C.cexp|ctx->lockstep_width|] - NumGroups -> [C.cexp|ctx->cfg.default_num_groups|] - GroupSize -> [C.cexp|ctx->cfg.default_group_size|] - TileSize -> [C.cexp|ctx->cfg.default_tile_size|] - RegTileSize -> [C.cexp|ctx->cfg.default_reg_tile_size|] - Threshold -> [C.cexp|ctx->cfg.default_threshold|] + NumGroups -> [C.cexp|ctx->cfg->default_num_groups|] + GroupSize -> [C.cexp|ctx->cfg->default_group_size|] + TileSize -> [C.cexp|ctx->cfg->default_tile_size|] + RegTileSize -> [C.cexp|ctx->cfg->default_reg_tile_size|] + Threshold -> [C.cexp|ctx->cfg->default_threshold|] get_size = let (e, m) = runState (GC.compilePrimExp onLeaf what) mempty @@ -743,3 +347,5 @@ optionAction = [C.cstm|futhark_context_config_set_default_threshold(cfg, atoi(optarg));|] } ] + +{-# NOINLINE generateBoilerplate #-} 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 @@ -66,7 +66,6 @@ opsAllocate = defAllocate, opsDeallocate = defDeallocate, opsCopy = defCopy, - opsStaticArray = defStaticArray, opsMemoryType = defMemoryType, opsCompiler = defCompiler, opsFatMemory = True, @@ -87,8 +86,6 @@ copyMemoryDefaultSpace destmem destoffset srcmem srcoffset size defCopy _ _ _ _ _ _ _ _ = error "Cannot copy to or from non-default memory space" - defStaticArray _ _ _ _ = - error "Cannot create static array in non-default memory space" defMemoryType _ = error "Has no type for non-default memory space" defCompiler _ = @@ -119,17 +116,14 @@ entryDecls = declsCode (== EntryDecl) miscDecls = declsCode (== MiscDecl) -defineMemorySpace :: Space -> CompilerM op s (C.Definition, [C.Definition], C.BlockItem) +defineMemorySpace :: Space -> CompilerM op s ([C.Definition], C.BlockItem) defineMemorySpace space = do rm <- rawMemCType space - let structdef = - [C.cedecl|struct $id:sname { int *references; - $ty:rm mem; - typename int64_t size; - const char *desc; };|] - - contextField peakname [C.cty|typename int64_t|] $ Just [C.cexp|0|] - contextField usagename [C.cty|typename int64_t|] $ Just [C.cexp|0|] + earlyDecl + [C.cedecl|struct $id:sname { int *references; + $ty:rm mem; + typename int64_t size; + const char *desc; };|] -- Unreferencing a memory block consists of decreasing its reference -- count and freeing the corresponding memory if the count reaches @@ -234,8 +228,7 @@ let peakmsg = "Peak memory usage for " ++ spacedesc ++ ": %lld bytes.\n" pure - ( structdef, - [unrefdef, allocdef, setdef], + ( [unrefdef, allocdef, setdef], -- Do not report memory usage for DefaultSpace (CPU memory), -- because it would not be accurate anyway. This whole -- tracking probably needs to be rethought. @@ -458,7 +451,7 @@ Definitions types consts (Functions funs) = prog compileProgAction = do - (memstructs, memfuns, memreport) <- unzip3 <$> mapM defineMemorySpace spaces + (memfuns, memreport) <- unzip <$> mapM defineMemorySpace spaces get_consts <- compileConstants consts @@ -467,10 +460,19 @@ (prototypes, functions) <- unzip <$> mapM (compileFun get_consts [[C.cparam|$ty:ctx_ty *ctx|]]) funs - mapM_ earlyDecl memstructs (entry_points, entry_points_manifest) <- unzip . catMaybes <$> mapM (uncurry (onEntryPoint get_consts)) funs + headerDecl InitDecl [C.cedecl|struct futhark_context_config;|] + headerDecl InitDecl [C.cedecl|struct futhark_context_config* futhark_context_config_new(void);|] + headerDecl InitDecl [C.cedecl|void futhark_context_config_free(struct futhark_context_config* cfg);|] + headerDecl InitDecl [C.cedecl|int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg, const char *param_name, size_t new_value);|] + + headerDecl InitDecl [C.cedecl|struct futhark_context;|] + headerDecl InitDecl [C.cedecl|struct futhark_context* futhark_context_new(struct futhark_context_config* cfg);|] + headerDecl InitDecl [C.cedecl|void futhark_context_free(struct futhark_context* cfg);|] + headerDecl MiscDecl [C.cedecl|int futhark_context_sync(struct futhark_context* ctx);|] + extra mapM_ earlyDecl $ concat memfuns @@ -508,6 +510,27 @@ ops <- asks envOperations profilereport <- gets $ DL.toList . compProfileItems + publicDef_ "context_config_set_debugging" InitDecl $ \s -> + ( [C.cedecl|void $id:s($ty:cfg* cfg, int flag);|], + [C.cedecl|void $id:s($ty:cfg* cfg, int flag) { + cfg->profiling = cfg->logging = cfg->debugging = flag; + }|] + ) + + publicDef_ "context_config_set_profiling" InitDecl $ \s -> + ( [C.cedecl|void $id:s($ty:cfg* cfg, int flag);|], + [C.cedecl|void $id:s($ty:cfg* cfg, int flag) { + cfg->profiling = flag; + }|] + ) + + publicDef_ "context_config_set_logging" InitDecl $ \s -> + ( [C.cedecl|void $id:s($ty:cfg* cfg, int flag);|], + [C.cedecl|void $id:s($ty:cfg* cfg, int flag) { + cfg->logging = flag; + }|] + ) + publicDef_ "context_config_set_cache_file" MiscDecl $ \s -> ( [C.cedecl|void $id:s($ty:cfg* cfg, const char *f);|], [C.cedecl|void $id:s($ty:cfg* cfg, const char *f) { @@ -518,7 +541,7 @@ publicDef_ "get_tuning_param_count" InitDecl $ \s -> ( [C.cedecl|int $id:s(void);|], [C.cedecl|int $id:s(void) { - return sizeof(tuning_param_names)/sizeof(tuning_param_names[0]); + return num_tuning_params; }|] ) @@ -588,22 +611,16 @@ publicDef_ "context_clear_caches" MiscDecl $ \s -> ( [C.cedecl|int $id:s($ty:ctx* ctx);|], [C.cedecl|int $id:s($ty:ctx* ctx) { - $items:(criticalSection ops clears) - return ctx->error != NULL; - }|] + $items:(criticalSection ops clears) + return ctx->error != NULL; + }|] ) compileConstants :: Constants op -> CompilerM op s [C.BlockItem] compileConstants (Constants ps init_consts) = do ctx_ty <- contextType const_fields <- mapM constParamField ps - -- Avoid an empty struct, as that is apparently undefined behaviour. - let const_fields' - | null const_fields = [[C.csdecl|int dummy;|]] - | otherwise = const_fields - contextField "constants" [C.cty|struct { $sdecls:const_fields' }|] Nothing - earlyDecl [C.cedecl|static int init_constants($ty:ctx_ty*);|] - earlyDecl [C.cedecl|static int free_constants($ty:ctx_ty*);|] + earlyDecl [C.cedecl|struct constants { int dummy; $sdecls:const_fields };|] inNewFunction $ do -- We locally define macros for the constants, so that when we @@ -650,18 +667,18 @@ constMacro p = ([C.citem|$escstm:def|], [C.citem|$escstm:undef|]) where p' = T.unpack $ idText (C.toIdent (paramName p) mempty) - def = "#define " ++ p' ++ " (" ++ "ctx->constants." ++ p' ++ ")" + def = "#define " ++ p' ++ " (" ++ "ctx->constants->" ++ p' ++ ")" undef = "#undef " ++ p' resetMemConst ScalarParam {} = pure () resetMemConst (MemParam name space) = resetMem name space freeConst ScalarParam {} = pure () - freeConst (MemParam name space) = unRefMem [C.cexp|ctx->constants.$id:name|] space + freeConst (MemParam name space) = unRefMem [C.cexp|ctx->constants->$id:name|] space getConst (ScalarParam name bt) = do let ctp = primTypeToCType bt - pure [C.citem|$ty:ctp $id:name = ctx->constants.$id:name;|] + pure [C.citem|$ty:ctp $id:name = ctx->constants->$id:name;|] getConst (MemParam name space) = do ty <- memToCType name space - pure [C.citem|$ty:ty $id:name = ctx->constants.$id:name;|] + pure [C.citem|$ty:ty $id:name = ctx->constants->$id:name;|] 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 @@ -13,6 +13,7 @@ import Futhark.CodeGen.Backends.GenericC.Pretty import Futhark.CodeGen.Backends.SimpleRep ( cproduct, + escapeName, primAPIType, primStorageType, scalarToPrim, @@ -305,7 +306,8 @@ printstms = printResult manifest $ zip (map outputType outputs) output_vals - cli_entry_point_function_name = "futrts_cli_entry_" ++ T.unpack entry_point_name + cli_entry_point_function_name = + "futrts_cli_entry_" <> T.unpack (escapeName entry_point_name) pause_profiling = "futhark_context_pause_profiling" :: T.Text unpause_profiling = "futhark_context_unpause_profiling" :: T.Text diff --git a/src/Futhark/CodeGen/Backends/GenericC/Code.hs b/src/Futhark/CodeGen/Backends/GenericC/Code.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Code.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Code.hs @@ -12,7 +12,6 @@ where import Control.Monad.Reader -import Data.Loc import Data.Maybe import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC.Monad @@ -325,9 +324,7 @@ compileCode (DeclareScalar name vol t) = do let ct = primTypeToCType t decl [C.cdecl|$tyquals:(volQuals vol) $ty:ct $id:name;|] -compileCode (DeclareArray name ScalarSpace {} _ _) = - error $ "Cannot declare array " ++ prettyString name ++ " in scalar space." -compileCode (DeclareArray name DefaultSpace t vs) = do +compileCode (DeclareArray name t vs) = do name_realtype <- newVName $ baseString name ++ "_realtype" let ct = primTypeToCType t case vs of @@ -337,22 +334,12 @@ ArrayZeros n -> earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|] -- Fake a memory block. - contextField - (C.toIdent name noLoc) - [C.cty|struct memblock|] - $ Just - [C.cexp|(struct memblock){NULL, - (unsigned char*)$id:name_realtype, - 0, - $string:(prettyString name)}|] - item [C.citem|struct memblock $id:name = ctx->$id:name;|] -compileCode (DeclareArray name (Space space) t vs) = - join $ - asks (opsStaticArray . envOperations) - <*> pure name - <*> pure space - <*> pure t - <*> pure vs + item + [C.citem|struct memblock $id:name = + (struct memblock){NULL, + (unsigned char*)$id:name_realtype, + 0, + $string:(prettyString name)};|] -- For assignments of the form 'x = x OP e', we generate C assignment -- operators to make the resulting code slightly nicer. This has no -- effect on performance. diff --git a/src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs b/src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs --- a/src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs @@ -13,7 +13,6 @@ import Futhark.CodeGen.Backends.GenericC.Types (opaqueToCType, valueTypeToCType) import Futhark.CodeGen.ImpCode import Futhark.Manifest qualified as Manifest -import Futhark.Util (zEncodeText) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C @@ -132,9 +131,7 @@ stms $ zipWith maybeCopyDim shape [0 .. rank - 1] entryName :: Name -> T.Text -entryName v - | isValidCName (nameToText v) = "entry_" <> nameToText v - | otherwise = "entry_" <> zEncodeText (nameToText v) +entryName = ("entry_" <>) . escapeName . nameToText onEntryPoint :: [C.BlockItem] -> diff --git a/src/Futhark/CodeGen/Backends/GenericC/Fun.hs b/src/Futhark/CodeGen/Backends/GenericC/Fun.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Fun.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Fun.hs @@ -29,8 +29,9 @@ let ctp = primTypeToCType pt decl [C.cdecl|$ty:ctp $id:name;|] - setRetVal' p (MemParam name space) = do - resetMem [C.cexp|*$exp:p|] space + setRetVal' p (MemParam name space) = + -- It is required that the memory block is already initialised + -- (although it may be NULL). setMem [C.cexp|*$exp:p|] name space setRetVal' p (ScalarParam name _) = stm [C.cstm|*$exp:p = $id:name;|] diff --git a/src/Futhark/CodeGen/Backends/GenericC/Monad.hs b/src/Futhark/CodeGen/Backends/GenericC/Monad.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Monad.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Monad.hs @@ -18,7 +18,6 @@ Deallocate, CopyBarrier (..), Copy, - StaticArray, -- * Monadic compiler interface CompilerM, @@ -26,8 +25,7 @@ CompilerEnv (..), getUserState, modifyUserState, - contextContents, - contextFinalInits, + generateProgramStruct, runCompilerM, inNewFunction, cachingMemory, @@ -38,7 +36,6 @@ stm, stms, decl, - atInit, headerDecl, publicDef, publicDef_, @@ -77,7 +74,6 @@ fatMemUnRef, criticalSection, module Futhark.CodeGen.Backends.SimpleRep, - isValidCName, ) where @@ -85,7 +81,6 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor (first) -import Data.Char (isAlpha, isAlphaNum) import Data.DList qualified as DL import Data.List (unzip4) import Data.Loc @@ -110,12 +105,11 @@ data CompilerState s = CompilerState { compArrayTypes :: M.Map ArrayType Publicness, compEarlyDecls :: DL.DList C.Definition, - compInit :: [C.Stm], compNameSrc :: VNameSource, compUserState :: s, compHeaderDecls :: M.Map HeaderSection (DL.DList C.Definition), compLibDecls :: DL.DList C.Definition, - compCtxFields :: DL.DList (C.Id, C.Type, Maybe C.Exp, Maybe C.Stm), + compCtxFields :: DL.DList (C.Id, C.Type, Maybe C.Exp, Maybe (C.Stm, C.Stm)), compProfileItems :: DL.DList C.BlockItem, compClearItems :: DL.DList C.BlockItem, compDeclaredMem :: [(VName, Space)], @@ -127,7 +121,6 @@ CompilerState { compArrayTypes = mempty, compEarlyDecls = mempty, - compInit = [], compNameSrc = src, compUserState = s, compHeaderDecls = mempty, @@ -158,7 +151,7 @@ -- | The address space qualifiers for a pointer of the given type with -- the given annotation. -type PointerQuals op s = String -> CompilerM op s [C.TypeQual] +type PointerQuals = String -> [C.TypeQual] -- | The type of a memory block in the given memory space. type MemoryType op s = SpaceId -> CompilerM op s C.Type @@ -187,9 +180,6 @@ -- given size,, which is in the given memory space. type Deallocate op s = C.Exp -> C.Exp -> C.Exp -> SpaceId -> CompilerM op s () --- | 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 @@ -222,7 +212,6 @@ opsAllocate :: Allocate op s, opsDeallocate :: Deallocate op s, opsCopy :: Copy op s, - opsStaticArray :: StaticArray op s, opsMemoryType :: MemoryType op s, opsCompiler :: OpCompiler op s, opsError :: ErrorCompiler op s, @@ -265,13 +254,34 @@ | (name, ty) <- zip field_names field_types ] init_fields = - [ [C.cstm|ctx->$id:name = $exp:e;|] + [ [C.cstm|ctx->program->$id:name = $exp:e;|] | (name, Just e) <- zip field_names field_values ] - pure (fields, init_fields, catMaybes field_frees) + (setup, free) = unzip $ catMaybes field_frees + pure (fields, init_fields <> setup, free) -contextFinalInits :: CompilerM op s [C.Stm] -contextFinalInits = gets compInit +generateProgramStruct :: CompilerM op s () +generateProgramStruct = do + (fields, init_fields, free_fields) <- contextContents + mapM_ + earlyDecl + [C.cunit|struct program { + $sdecls:fields + }; + static void setup_program(struct futhark_context* ctx) { + (void)ctx; + int error = 0; + (void)error; + ctx->program = malloc(sizeof(struct program)); + $stms:init_fields + } + static void teardown_program(struct futhark_context *ctx) { + (void)ctx; + int error = 0; + (void)error; + $stms:free_fields + free(ctx->program); + }|] newtype CompilerM op s a = CompilerM (ReaderT (CompilerEnv op s) (State (CompilerState s)) a) @@ -305,10 +315,6 @@ modifyUserState f = modify $ \compstate -> compstate {compUserState = f $ compUserState compstate} -atInit :: C.Stm -> CompilerM op s () -atInit x = modify $ \s -> - s {compInit = compInit s ++ [x]} - collect :: CompilerM op s () -> CompilerM op s [C.BlockItem] collect m = snd <$> collect' m @@ -394,9 +400,9 @@ contextField name ty initial = modify $ \s -> s {compCtxFields = compCtxFields s <> DL.singleton (name, ty, initial, Nothing)} -contextFieldDyn :: C.Id -> C.Type -> Maybe C.Exp -> C.Stm -> CompilerM op s () -contextFieldDyn name ty initial free = modify $ \s -> - s {compCtxFields = compCtxFields s <> DL.singleton (name, ty, initial, Just free)} +contextFieldDyn :: C.Id -> C.Type -> C.Stm -> C.Stm -> CompilerM op s () +contextFieldDyn name ty create free = modify $ \s -> + s {compCtxFields = compCtxFields s <> DL.singleton (name, ty, Nothing, Just (create, free))} profileReport :: C.BlockItem -> CompilerM op s () profileReport x = modify $ \s -> @@ -634,21 +640,15 @@ volQuals Volatile = [C.ctyquals|volatile|] volQuals Nonvolatile = [] -writeScalarPointerWithQuals :: PointerQuals op s -> WriteScalar op s +writeScalarPointerWithQuals :: PointerQuals -> WriteScalar op s writeScalarPointerWithQuals quals_f dest i elemtype space vol v = do - quals <- quals_f space - let quals' = volQuals vol ++ quals - deref = - derefPointer - dest - i - [C.cty|$tyquals:quals' $ty:elemtype*|] + let quals' = volQuals vol ++ quals_f space + deref = derefPointer dest i [C.cty|$tyquals:quals' $ty:elemtype*|] stm [C.cstm|$exp:deref = $exp:v;|] -readScalarPointerWithQuals :: PointerQuals op s -> ReadScalar op s +readScalarPointerWithQuals :: PointerQuals -> ReadScalar op s readScalarPointerWithQuals quals_f dest i elemtype space vol = do - quals <- quals_f space - let quals' = volQuals vol ++ quals + let quals' = volQuals vol ++ quals_f space pure $ derefPointer dest i [C.cty|$tyquals:quals' $ty:elemtype*|] criticalSection :: Operations op s -> [C.BlockItem] -> [C.BlockItem] @@ -672,11 +672,3 @@ configType = do name <- publicName "context_config" pure [C.cty|struct $id:name|] - --- | Is this name a valid C identifier? If not, it should be escaped --- before being emitted into C. -isValidCName :: T.Text -> Bool -isValidCName = maybe True check . T.uncons - where - check (c, cs) = isAlpha c && T.all constituent cs - constituent c = isAlphaNum c || c == '_' 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 @@ -28,7 +28,6 @@ ReadScalar, Allocate, Copy, - StaticArray, EntryOutput, EntryInput, CompilerEnv (..), @@ -44,6 +43,7 @@ import Control.Monad.Identity import Control.Monad.RWS +import Data.Char (isAlpha, isAlphaNum) import Data.Map qualified as M import Data.Maybe import Data.Text qualified as T @@ -102,9 +102,6 @@ PrimType -> CompilerM op s () --- | Create a static array of values - initialised at load time. -type StaticArray op s = VName -> Imp.SpaceId -> PrimType -> Imp.ArrayContents -> CompilerM op s () - -- | Construct the Python array being returned from an entry point. type EntryOutput op s = VName -> @@ -129,7 +126,6 @@ opsReadScalar :: ReadScalar op s, opsAllocate :: Allocate op s, opsCopy :: Copy op s, - opsStaticArray :: StaticArray op s, opsCompiler :: OpCompiler op s, opsEntryOutput :: EntryOutput op s, opsEntryInput :: EntryInput op s @@ -145,7 +141,6 @@ opsReadScalar = defReadScalar, opsAllocate = defAllocate, opsCopy = defCopy, - opsStaticArray = defStaticArray, opsCompiler = defCompiler, opsEntryOutput = defEntryOutput, opsEntryInput = defEntryInput @@ -159,8 +154,6 @@ error "Cannot allocate in non-default memory space" defCopy _ _ _ _ _ _ _ _ = error "Cannot copy to or from non-default memory space" - defStaticArray _ _ _ _ = - error "Cannot create static array in non-default memory space" defCompiler _ = error "The default compiler cannot compile extended operations" defEntryOutput _ _ _ _ = @@ -170,7 +163,7 @@ data CompilerEnv op s = CompilerEnv { envOperations :: Operations op s, - envVarExp :: M.Map VName PyExp + envVarExp :: M.Map String PyExp } envOpCompiler :: CompilerEnv op s -> OpCompiler op s @@ -188,9 +181,6 @@ envCopy :: CompilerEnv op s -> Copy op s envCopy = opsCopy . envOperations -envStaticArray :: CompilerEnv op s -> StaticArray op s -envStaticArray = opsStaticArray . envOperations - envEntryOutput :: CompilerEnv op s -> EntryOutput op s envEntryOutput = opsEntryOutput . envOperations @@ -331,6 +321,23 @@ functionExternalValues entry = map snd (Imp.entryPointResults entry) ++ map snd (Imp.entryPointArgs entry) +-- | Is this name a valid Python identifier? If not, it should be escaped +-- before being emitted. +isValidPyName :: T.Text -> Bool +isValidPyName = maybe True check . T.uncons + where + check (c, cs) = isAlpha c && T.all constituent cs + constituent c = isAlphaNum c || c == '_' + +-- | If the provided text is a valid identifier, then return it +-- verbatim. Otherwise, escape it such that it becomes valid. +escapeName :: Name -> T.Text +escapeName v + | isValidPyName v' = v' + | otherwise = zEncodeText v' + where + v' = nameToText v + opaqueDefs :: Imp.Functions a -> M.Map T.Text [PyExp] opaqueDefs (Imp.Functions funs) = mconcat @@ -491,7 +498,7 @@ where constExp p = M.singleton - (Imp.paramName p) + (compileName $ Imp.paramName p) (Index (Var "self.constants") $ IdxExp $ String $ prettyText $ Imp.paramName p) compileConstants :: Imp.Constants op -> CompilerM op s () @@ -886,9 +893,15 @@ pure $ Just - ( Def (nameToString ename) ("self" : params) $ + ( Def (T.unpack (escapeName ename)) ("self" : params) $ prepareIn ++ do_run ++ prepareOut ++ sync ++ [ret], - (String (nameToText ename), Tuple [List (map String pts), List (map String rts)]) + ( String (nameToText ename), + Tuple + [ String (escapeName ename), + List (map String pts), + List (map String rts) + ] + ) ) | otherwise = pure Nothing @@ -930,7 +943,7 @@ str_output <- printValue res - let fname' = "entry_" ++ nameToString fname + let fname' = "entry_" ++ T.unpack (escapeName fname) pure $ Just @@ -1105,8 +1118,9 @@ compilePrimValue UnitValue = Var "None" compileVar :: VName -> CompilerM op s PyExp -compileVar v = - asks $ fromMaybe (Var $ compileName v) . M.lookup v . envVarExp +compileVar v = asks $ fromMaybe (Var v') . M.lookup v' . envVarExp + where + v' = compileName v -- | Tell me how to compile a @v@, and I'll Compile any @PrimExp v@ for you. compilePrimExp :: Monad m => (v -> m PyExp) -> Imp.PrimExp v -> m PyExp @@ -1197,38 +1211,27 @@ v' <- compileVar v stm $ Assign v' $ Var "True" compileCode Imp.DeclareScalar {} = pure () -compileCode (Imp.DeclareArray name (Space space) t vs) = - join $ - asks envStaticArray - <*> pure name - <*> pure space - <*> pure t - <*> pure vs -compileCode (Imp.DeclareArray name _ t vs) = do +compileCode (Imp.DeclareArray name t vs) = do let arr_name = compileName name <> "_arr" -- It is important to store the Numpy array in a temporary variable -- to prevent it from going "out-of-scope" before calling -- unwrapArray (which internally uses the .ctype method); see -- https://docs.scipy.org/doc/numpy/reference/generated/numpy.ndarray.ctypes.html - atInit $ - Assign (Field (Var "self") arr_name) $ case vs of - Imp.ArrayValues vs' -> - Call - (Var "np.array") - [ Arg $ List $ map compilePrimValue vs', - ArgKeyword "dtype" $ Var $ compilePrimToNp t - ] - Imp.ArrayZeros n -> - Call - (Var "np.zeros") - [ Arg $ Integer $ fromIntegral n, - ArgKeyword "dtype" $ Var $ compilePrimToNp t - ] - atInit $ - Assign (Field (Var "self") (compileName name)) $ - simpleCall "unwrapArray" [Field (Var "self") arr_name] + stm $ Assign (Var arr_name) $ case vs of + Imp.ArrayValues vs' -> + Call + (Var "np.array") + [ Arg $ List $ map compilePrimValue vs', + ArgKeyword "dtype" $ Var $ compilePrimToNp t + ] + Imp.ArrayZeros n -> + Call + (Var "np.zeros") + [ Arg $ Integer $ fromIntegral n, + ArgKeyword "dtype" $ Var $ compilePrimToNp t + ] name' <- compileVar name - stm $ Assign name' $ Field (Var "self") (compileName name) + stm $ Assign name' $ simpleCall "unwrapArray" [Var arr_name] compileCode (Imp.Comment s code) = do code' <- collect $ compileCode code stm $ Comment (T.unpack s) code' 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 @@ -53,7 +53,7 @@ emccExportNames :: [JSEntryPoint] -> [String] emccExportNames jses = - map (\jse -> "'_futhark_entry_" ++ name jse ++ "'") jses + map (\jse -> "'_futhark_entry_" ++ T.unpack (GC.escapeName (T.pack (name jse))) ++ "'") jses ++ map (\arg -> "'" ++ gfn "new" arg ++ "'") arrays ++ map (\arg -> "'" ++ gfn "free" arg ++ "'") arrays ++ map (\arg -> "'" ++ gfn "shape" arg ++ "'") arrays @@ -151,9 +151,10 @@ dicEntry :: JSEntryPoint -> T.Text dicEntry jse = [text| - '${ename}' : [${params}, ${rets}] + "${ename}" : ["${fname}", ${params}, ${rets}] |] where + fname = GC.escapeName $ T.pack $ name jse ename = T.pack $ name jse params = showText $ parameters jse rets = showText $ ret jse @@ -176,7 +177,7 @@ } |] where - func_name = T.pack $ name jse + func_name = GC.escapeName $ T.pack $ name jse alp = [0 .. length (parameters jse) - 1] inparams = T.pack $ intercalate ", " ["in" ++ show i | i <- alp] 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 @@ -4,7 +4,6 @@ -- program to an equivalent C program. module Futhark.CodeGen.Backends.MulticoreC ( compileProg, - generateContext, GC.CParts (..), GC.asLibrary, GC.asExecutable, @@ -35,10 +34,10 @@ import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.GenericC.Options +import Futhark.CodeGen.Backends.MulticoreC.Boilerplate (generateBoilerplate) import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode.Multicore hiding (ValueType) import Futhark.CodeGen.ImpGen.Multicore qualified as ImpGen -import Futhark.CodeGen.RTS.C (schedulerH) import Futhark.IR.MCMem (MCMem, Prog) import Futhark.MonadFreshNames import Language.C.Quote.OpenCL qualified as C @@ -53,187 +52,13 @@ "multicore" version operations - generateContext + generateBoilerplate "" (DefaultSpace, [DefaultSpace]) cliOptions ) <=< ImpGen.compileProg --- | Generate the multicore context definitions. This is exported --- because the WASM backend needs it. -generateContext :: GC.CompilerM op s () -generateContext = do - mapM_ GC.earlyDecl [C.cunit|$esc:(T.unpack schedulerH)|] - - cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { int in_use; - int debugging; - int profiling; - int num_threads; - const char *cache_fname; - };|] - ) - - GC.publicDef_ "context_config_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:cfg* $id:s(void);|], - [C.cedecl|struct $id:cfg* $id:s(void) { - struct $id:cfg *cfg = (struct $id:cfg*) malloc(sizeof(struct $id:cfg)); - if (cfg == NULL) { - return NULL; - } - cfg->in_use = 0; - cfg->debugging = 0; - cfg->profiling = 0; - cfg->cache_fname = NULL; - cfg->num_threads = 0; - return cfg; - }|] - ) - - GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg) { - assert(!cfg->in_use); - free(cfg); - }|] - ) - - GC.publicDef_ "context_config_set_debugging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { - cfg->debugging = detail; - }|] - ) - - GC.publicDef_ "context_config_set_profiling" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - cfg->profiling = flag; - }|] - ) - - GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { - // Does nothing for this backend. - (void)cfg; (void)detail; - }|] - ) - - GC.publicDef_ "context_config_set_num_threads" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg *cfg, int n);|], - [C.cedecl|void $id:s(struct $id:cfg *cfg, int n) { - cfg->num_threads = n; - }|] - ) - - (fields, init_fields, free_fields) <- GC.contextContents - - ctx <- GC.publicDef "context" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { - struct $id:cfg* cfg; - struct scheduler scheduler; - int detail_memory; - int debugging; - int profiling; - int profiling_paused; - int logging; - typename lock_t lock; - char *error; - typename lock_t error_lock; - typename FILE *log; - int total_runs; - long int total_runtime; - struct free_list free_list; - $sdecls:fields - - // Tuning parameters - typename int64_t tuning_timing; - typename int64_t tuning_iter; - };|] - ) - - GC.publicDef_ "context_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], - [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) { - assert(!cfg->in_use); - struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); - if (ctx == NULL) { - return NULL; - } - ctx->cfg = cfg; - ctx->cfg->in_use = 1; - - // Initialize rand() - fast_srand(time(0)); - ctx->detail_memory = cfg->debugging; - ctx->debugging = cfg->debugging; - ctx->profiling = cfg->profiling; - ctx->profiling_paused = 0; - ctx->logging = 0; - ctx->error = NULL; - ctx->log = stderr; - - context_setup(ctx); - - int tune_kappa = 0; - double kappa = 5.1f * 1000; - - if (tune_kappa) { - if (determine_kappa(&kappa) != 0) { - return NULL; - } - } - - if (scheduler_init(&ctx->scheduler, - cfg->num_threads > 0 ? - cfg->num_threads : num_processors(), - kappa) != 0) { - return NULL; - } - - $stms:init_fields - - init_constants(ctx); - - return ctx; - }|] - ) - - GC.publicDef_ "context_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|], - [C.cedecl|void $id:s(struct $id:ctx* ctx) { - $stms:free_fields - context_teardown(ctx); - (void)scheduler_destroy(&ctx->scheduler); - ctx->cfg->in_use = 0; - free(ctx); - }|] - ) - - GC.publicDef_ "context_sync" GC.InitDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|], - [C.cedecl|int $id:s(struct $id:ctx* ctx) { - (void)ctx; - return 0; - }|] - ) - - GC.earlyDecl [C.cedecl|static const char *tuning_param_names[0];|] - GC.earlyDecl [C.cedecl|static const char *tuning_param_vars[0];|] - GC.earlyDecl [C.cedecl|static const char *tuning_param_classes[0];|] - - GC.publicDef_ "context_config_set_tuning_param" GC.InitDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *param_name, size_t param_value);|], - [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *param_name, size_t param_value) { - (void)cfg; (void)param_name; (void)param_value; - return 1; - }|] - ) - -- | Multicore-related command line options. cliOptions :: [Option] cliOptions = @@ -415,12 +240,12 @@ fprintf(ctx->log, $string:(format_string name is_array), i, - ctx->$id:runs[i], - (long int) ctx->$id:total_runtime[i] / (ctx->$id:runs[i] != 0 ? ctx->$id:runs[i] : 1), - (long int) ctx->$id:total_runtime[i], - (double) ctx->$id:total_runtime[i] / (ctx->$id:iters[i] == 0 ? 1 : (double)ctx->$id:iters[i]), - (long int) (ctx->$id:iters[i]), - (long int) (ctx->$id:iters[i]) / (ctx->$id:runs[i] != 0 ? ctx->$id:runs[i] : 1) + ctx->program->$id:runs[i], + (long int) ctx->program->$id:total_runtime[i] / (ctx->program->$id:runs[i] != 0 ? ctx->program->$id:runs[i] : 1), + (long int) ctx->program->$id:total_runtime[i], + (double) ctx->program->$id:total_runtime[i] / (ctx->program->$id:iters[i] == 0 ? 1 : (double)ctx->program->$id:iters[i]), + (long int) (ctx->program->$id:iters[i]), + (long int) (ctx->program->$id:iters[i]) / (ctx->program->$id:runs[i] != 0 ? ctx->program->$id:runs[i] : 1) ); } |] @@ -429,15 +254,15 @@ [ [C.citem| fprintf(ctx->log, $string:(format_string name is_array), - ctx->$id:runs, - (long int) ctx->$id:total_runtime / (ctx->$id:runs != 0 ? ctx->$id:runs : 1), - (long int) ctx->$id:total_runtime, - (double) ctx->$id:total_runtime / (ctx->$id:iters == 0 ? 1 : (double)ctx->$id:iters), - (long int) (ctx->$id:iters), - (long int) (ctx->$id:iters) / (ctx->$id:runs != 0 ? ctx->$id:runs : 1)); + ctx->program->$id:runs, + (long int) ctx->program->$id:total_runtime / (ctx->program->$id:runs != 0 ? ctx->program->$id:runs : 1), + (long int) ctx->program->$id:total_runtime, + (double) ctx->program->$id:total_runtime / (ctx->program->$id:iters == 0 ? 1 : (double)ctx->program->$id:iters), + (long int) (ctx->program->$id:iters), + (long int) (ctx->program->$id:iters) / (ctx->program->$id:runs != 0 ? ctx->program->$id:runs : 1)); |], - [C.citem|ctx->total_runtime += ctx->$id:total_runtime;|], - [C.citem|ctx->total_runs += ctx->$id:runs;|] + [C.citem|ctx->total_runtime += ctx->program->$id:total_runtime;|], + [C.citem|ctx->total_runs += ctx->program->$id:runs;|] ] addBenchmarkFields :: Name -> Maybe C.Id -> GC.CompilerM op s () @@ -445,18 +270,18 @@ GC.contextFieldDyn (functionRuntime name) [C.cty|typename int64_t*|] - (Just [C.cexp|calloc(sizeof(typename int64_t), ctx->scheduler.num_threads)|]) - [C.cstm|free(ctx->$id:(functionRuntime name));|] + [C.cstm|ctx->program->$id:(functionRuntime name) = calloc(sizeof(typename int64_t), ctx->scheduler.num_threads);|] + [C.cstm|free(ctx->program->$id:(functionRuntime name));|] GC.contextFieldDyn (functionRuns name) [C.cty|int*|] - (Just [C.cexp|calloc(sizeof(int), ctx->scheduler.num_threads)|]) - [C.cstm|free(ctx->$id:(functionRuns name));|] + [C.cstm|ctx->program->$id:(functionRuns name) = calloc(sizeof(int), ctx->scheduler.num_threads);|] + [C.cstm|free(ctx->program->$id:(functionRuns name));|] GC.contextFieldDyn (functionIter name) [C.cty|typename int64_t*|] - (Just [C.cexp|calloc(sizeof(sizeof(typename int64_t)), ctx->scheduler.num_threads)|]) - [C.cstm|free(ctx->$id:(functionIter name));|] + [C.cstm|ctx->program->$id:(functionIter name) = calloc(sizeof(sizeof(typename int64_t)), ctx->scheduler.num_threads);|] + [C.cstm|free(ctx->program->$id:(functionIter name));|] addBenchmarkFields name Nothing = do GC.contextField (functionRuntime name) [C.cty|typename int64_t|] $ Just [C.cexp|0|] GC.contextField (functionRuns name) [C.cty|int|] $ Just [C.cexp|0|] @@ -482,13 +307,13 @@ start = name <> "_start" end = name <> "_end" updateFields Nothing = - [C.citems|__atomic_fetch_add(&ctx->$id:(functionRuns name), 1, __ATOMIC_RELAXED); - __atomic_fetch_add(&ctx->$id:(functionRuntime name), elapsed, __ATOMIC_RELAXED); - __atomic_fetch_add(&ctx->$id:(functionIter name), iterations, __ATOMIC_RELAXED);|] + [C.citems|__atomic_fetch_add(&ctx->program->$id:(functionRuns name), 1, __ATOMIC_RELAXED); + __atomic_fetch_add(&ctx->program->$id:(functionRuntime name), elapsed, __ATOMIC_RELAXED); + __atomic_fetch_add(&ctx->program->$id:(functionIter name), iterations, __ATOMIC_RELAXED);|] updateFields (Just _tid') = - [C.citems|ctx->$id:(functionRuns name)[tid]++; - ctx->$id:(functionRuntime name)[tid] += elapsed; - ctx->$id:(functionIter name)[tid] += iterations;|] + [C.citems|ctx->program->$id:(functionRuns name)[tid]++; + ctx->program->$id:(functionRuntime name)[tid] += elapsed; + ctx->program->$id:(functionIter name)[tid] += iterations;|] functionTiming :: Name -> C.Id functionTiming = (`C.toIdent` mempty) . (<> "_total_time") @@ -609,8 +434,8 @@ GC.stm [C.cstm|$id:ftask_name.name = $string:(nameToString fpar_task);|] GC.stm [C.cstm|$id:ftask_name.iterations = $exp:e';|] -- Create the timing fields for the task - GC.stm [C.cstm|$id:ftask_name.task_time = &ctx->$id:(functionTiming fpar_task);|] - GC.stm [C.cstm|$id:ftask_name.task_iter = &ctx->$id:(functionIterations fpar_task);|] + GC.stm [C.cstm|$id:ftask_name.task_time = &ctx->program->$id:(functionTiming fpar_task);|] + GC.stm [C.cstm|$id:ftask_name.task_iter = &ctx->program->$id:(functionIterations fpar_task);|] case sched of Dynamic -> GC.stm [C.cstm|$id:ftask_name.sched = DYNAMIC;|] diff --git a/src/Futhark/CodeGen/Backends/MulticoreC/Boilerplate.hs b/src/Futhark/CodeGen/Backends/MulticoreC/Boilerplate.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/MulticoreC/Boilerplate.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Boilerplate for multicore C code. +module Futhark.CodeGen.Backends.MulticoreC.Boilerplate (generateBoilerplate) where + +import Data.Text qualified as T +import Futhark.CodeGen.Backends.GenericC qualified as GC +import Futhark.CodeGen.RTS.C (backendsMulticoreH, schedulerH) +import Language.C.Quote.OpenCL qualified as C + +-- | Generate the necessary boilerplate. +generateBoilerplate :: GC.CompilerM op s () +generateBoilerplate = do + GC.earlyDecl [C.cedecl|static const int num_tuning_params = 0;|] + GC.earlyDecl [C.cedecl|static const char *tuning_param_names[1];|] + GC.earlyDecl [C.cedecl|static const char *tuning_param_vars[1];|] + GC.earlyDecl [C.cedecl|static const char *tuning_param_classes[1];|] + GC.earlyDecl [C.cedecl|static typename int64_t *tuning_param_defaults[1];|] + mapM_ GC.earlyDecl [C.cunit|$esc:(T.unpack schedulerH)|] + mapM_ GC.earlyDecl [C.cunit|$esc:(T.unpack backendsMulticoreH)|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_num_threads(struct futhark_context_config *cfg, int n);|] + GC.generateProgramStruct +{-# NOINLINE generateBoilerplate #-} diff --git a/src/Futhark/CodeGen/Backends/MulticoreISPC.hs b/src/Futhark/CodeGen/Backends/MulticoreISPC.hs --- a/src/Futhark/CodeGen/Backends/MulticoreISPC.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreISPC.hs @@ -27,6 +27,7 @@ import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.GenericC.Pretty import Futhark.CodeGen.Backends.MulticoreC qualified as MC +import Futhark.CodeGen.Backends.MulticoreC.Boilerplate (generateBoilerplate) import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode.Multicore import Futhark.CodeGen.ImpGen.Multicore qualified as ImpGen @@ -74,7 +75,7 @@ operations (ISPCState mempty mempty) ( do - MC.generateContext + generateBoilerplate mapM_ compileBuiltinFun funs ) mempty @@ -499,7 +500,7 @@ 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 +compileCode (DeclareArray name t vs) = do name_realtype <- newVName $ baseString name ++ "_realtype" let ct = GC.primTypeToCType t case vs of @@ -508,19 +509,17 @@ 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 + -- Make an exported C shim to access a faked memory block. shim <- MC.multicoreDef "get_static_array_shim" $ \f -> - pure [C.cedecl|struct memblock* $id:f(struct futhark_context* ctx) { return &ctx->$id:name; }|] + pure + [C.cedecl|struct memblock $id:f(struct futhark_context* ctx) { + return (struct memblock){NULL,(unsigned char*)$id:name_realtype,0}; + }|] ispcDecl - [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform struct memblock * $tyqual:uniform + [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);|] + 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) @@ -782,8 +781,8 @@ 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);|] + GC.stm [C.cstm|$id:ftask_name.task_time = &ctx->program->$id:(MC.functionTiming fpar_task);|] + GC.stm [C.cstm|$id:ftask_name.task_iter = &ctx->program->$id:(MC.functionIterations fpar_task);|] case sched of Dynamic -> GC.stm [C.cstm|$id:ftask_name.sched = DYNAMIC;|] 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 @@ -18,6 +18,7 @@ import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.GenericWASM import Futhark.CodeGen.Backends.MulticoreC qualified as MC +import Futhark.CodeGen.Backends.MulticoreC.Boilerplate (generateBoilerplate) import Futhark.CodeGen.ImpCode.Multicore qualified as Imp import Futhark.CodeGen.ImpGen.Multicore qualified as ImpGen import Futhark.IR.MCMem @@ -48,7 +49,7 @@ "wasm_multicore" version MC.operations - MC.generateContext + generateBoilerplate "" (DefaultSpace, [DefaultSpace]) MC.cliOptions 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 @@ -189,7 +189,6 @@ Py.opsReadScalar = readOpenCLScalar, Py.opsAllocate = allocateOpenCLBuffer, Py.opsCopy = copyOpenCLMemory, - Py.opsStaticArray = staticOpenCLArray, Py.opsEntryOutput = packArrayOutput, Py.opsEntryInput = unpackArrayInput } @@ -346,10 +345,9 @@ ArgKeyword "device_offset" $ asLong srcidx, ArgKeyword "is_blocking" $ Var "synchronous" ] -copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx Imp.DefaultSpace nbytes bt = do - let divide = BinOp "//" nbytes (Integer $ Imp.primByteSize bt) - end = BinOp "+" srcidx divide - src = Index srcmem (IdxRange srcidx end) +copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx Imp.DefaultSpace nbytes _ = do + let end = BinOp "+" srcidx nbytes + src = Index (Py.simpleCall "createArray" [srcmem, List [nbytes], Var "np.byte"]) (IdxRange srcidx end) Py.stm $ ifNotZeroSize nbytes $ Exp $ @@ -379,58 +377,6 @@ Py.copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes copyOpenCLMemory _ _ destspace _ _ srcspace _ _ = error $ "Cannot copy to " ++ show destspace ++ " from " ++ show srcspace - -staticOpenCLArray :: Py.StaticArray Imp.OpenCL () -staticOpenCLArray name "device" t vs = do - mapM_ Py.atInit <=< Py.collect $ do - -- Create host-side Numpy array with intended values. - Py.stm $ - Assign (Var name') $ case vs of - Imp.ArrayValues vs' -> - Call - (Var "np.array") - [ Arg $ List $ map Py.compilePrimValue vs', - ArgKeyword "dtype" $ Var $ Py.compilePrimToNp t - ] - Imp.ArrayZeros n -> - Call - (Var "np.zeros") - [ Arg $ Integer $ fromIntegral n, - ArgKeyword "dtype" $ Var $ Py.compilePrimToNp t - ] - - let num_elems = case vs of - Imp.ArrayValues vs' -> length vs' - Imp.ArrayZeros n -> n - - -- Create memory block on the device. - static_mem <- newVName "static_mem" - let size = Integer $ toInteger num_elems * Imp.primByteSize t - allocateOpenCLBuffer (Var (Py.compileName static_mem)) size "device" - - -- Copy Numpy array to the device memory block. - Py.stm $ - ifNotZeroSize size $ - Exp $ - Call - (Var "cl.enqueue_copy") - [ Arg $ Var "self.queue", - Arg $ Var $ Py.compileName static_mem, - Arg $ Call (Var "normaliseArray") [Arg (Var name')], - ArgKeyword "is_blocking" $ Var "synchronous" - ] - - -- Store the memory block for later reference. - Py.stm $ - Assign (Field (Var "self") name') $ - Var $ - Py.compileName static_mem - - Py.stm $ Assign (Var name') (Field (Var "self") name') - where - name' = Py.compileName name -staticOpenCLArray _ space _ _ = - error $ "PyOpenCL backend cannot create static array in memory space '" ++ space ++ "'" packArrayOutput :: Py.EntryOutput Imp.OpenCL () packArrayOutput mem "device" bt ept dims = do diff --git a/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs b/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs @@ -3,134 +3,19 @@ -- | Boilerplate for sequential C code. module Futhark.CodeGen.Backends.SequentialC.Boilerplate (generateBoilerplate) where +import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC qualified as GC +import Futhark.CodeGen.RTS.C (backendsCH) import Language.C.Quote.OpenCL qualified as C -- | Generate the necessary boilerplate. generateBoilerplate :: GC.CompilerM op s () generateBoilerplate = do - cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { int debugging; - int in_use; - const char *cache_fname; - };|] - ) - - GC.publicDef_ "context_config_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:cfg* $id:s(void);|], - [C.cedecl|struct $id:cfg* $id:s(void) { - struct $id:cfg *cfg = (struct $id:cfg*) malloc(sizeof(struct $id:cfg)); - if (cfg == NULL) { - return NULL; - } - cfg->in_use = 0; - cfg->debugging = 0; - cfg->cache_fname = NULL; - return cfg; - }|] - ) - - GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg) { - assert(!cfg->in_use); - free(cfg); - }|] - ) - - GC.publicDef_ "context_config_set_debugging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { - cfg->debugging = detail; - }|] - ) - - GC.publicDef_ "context_config_set_profiling" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { - (void)cfg; (void)flag; - }|] - ) - - GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], - [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) { - // Does nothing for this backend. - (void)cfg; (void)detail; - }|] - ) - - (fields, init_fields, free_fields) <- GC.contextContents - - ctx <- GC.publicDef "context" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:s;|], - [C.cedecl|struct $id:s { - struct $id:cfg* cfg; - int detail_memory; - int debugging; - int profiling; - int logging; - typename lock_t lock; - char *error; - typename lock_t error_lock; - typename FILE *log; - int profiling_paused; - struct free_list free_list; - $sdecls:fields - };|] - ) - - GC.publicDef_ "context_new" GC.InitDecl $ \s -> - ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], - [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) { - assert(!cfg->in_use); - struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); - if (ctx == NULL) { - return NULL; - } - ctx->cfg = cfg; - ctx->cfg->in_use = 1; - - ctx->detail_memory = cfg->debugging; - ctx->debugging = cfg->debugging; - ctx->profiling = cfg->debugging; - ctx->logging = cfg->debugging; - ctx->error = NULL; - ctx->log = stderr; - context_setup(ctx); - $stms:init_fields - init_constants(ctx); - return ctx; - }|] - ) - - GC.publicDef_ "context_free" GC.InitDecl $ \s -> - ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|], - [C.cedecl|void $id:s(struct $id:ctx* ctx) { - $stms:free_fields - context_teardown(ctx); - ctx->cfg->in_use = 0; - free(ctx); - }|] - ) - - GC.publicDef_ "context_sync" GC.MiscDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|], - [C.cedecl|int $id:s(struct $id:ctx* ctx) { - (void)ctx; - return 0; - }|] - ) - - GC.earlyDecl [C.cedecl|static const char *tuning_param_names[0];|] - GC.earlyDecl [C.cedecl|static const char *tuning_param_vars[0];|] - GC.earlyDecl [C.cedecl|static const char *tuning_param_classes[0];|] - - GC.publicDef_ "context_config_set_tuning_param" GC.InitDecl $ \s -> - ( [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *param_name, size_t param_value);|], - [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *param_name, size_t param_value) { - (void)cfg; (void)param_name; (void)param_value; - return 1; - }|] - ) + GC.earlyDecl [C.cedecl|static const int num_tuning_params = 0;|] + GC.earlyDecl [C.cedecl|static const char *tuning_param_names[1];|] + GC.earlyDecl [C.cedecl|static const char *tuning_param_vars[1];|] + GC.earlyDecl [C.cedecl|static const char *tuning_param_classes[1];|] + GC.earlyDecl [C.cedecl|static typename int64_t *tuning_param_defaults[1];|] + GC.earlyDecl [C.cedecl|$esc:(T.unpack backendsCH)|] + GC.generateProgramStruct +{-# NOINLINE generateBoilerplate #-} 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 @@ -18,6 +18,8 @@ primAPIType, arrayName, opaqueName, + isValidCName, + escapeName, toStorage, fromStorage, cproduct, @@ -35,7 +37,7 @@ where import Data.Bits (shiftR, xor) -import Data.Char (isAlphaNum, isDigit, ord) +import Data.Char (isAlpha, isAlphaNum, isDigit, ord) import Data.Text qualified as T import Futhark.CodeGen.ImpCode import Futhark.CodeGen.RTS.C (scalarF16H, scalarH) @@ -107,6 +109,21 @@ arrayName :: PrimType -> Signedness -> Int -> T.Text arrayName pt signed rank = prettySigned (signed == Unsigned) pt <> "_" <> prettyText rank <> "d" + +-- | Is this name a valid C identifier? If not, it should be escaped +-- before being emitted into C. +isValidCName :: T.Text -> Bool +isValidCName = maybe True check . T.uncons + where + check (c, cs) = isAlpha c && T.all constituent cs + constituent c = isAlphaNum c || c == '_' + +-- | If the provided text is a valid C identifier, then return it +-- verbatim. Otherwise, escape it such that it becomes valid. +escapeName :: T.Text -> T.Text +escapeName v + | isValidCName v = v + | otherwise = zEncodeText v -- | The name of exposed opaque types. opaqueName :: Name -> T.Text 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 @@ -99,6 +99,7 @@ import Data.Bifunctor (second) import Data.List (intersperse) import Data.Map qualified as M +import Data.Ord (comparing) import Data.Set qualified as S import Data.Text qualified as T import Data.Traversable @@ -121,6 +122,7 @@ ValueType (..), errorMsgArgTypes, ) +import Futhark.Util (nubByOrd) import Futhark.Util.Pretty hiding (space) import Language.Futhark.Core import Language.Futhark.Primitive @@ -177,6 +179,13 @@ instance Functor Constants where fmap f (Constants params code) = Constants params (fmap f code) +instance Monoid (Constants a) where + mempty = Constants mempty mempty + +instance Semigroup (Constants a) where + Constants ps1 c1 <> Constants ps2 c2 = + Constants (nubByOrd (comparing (prettyString . paramName)) $ ps1 <> ps2) (c1 <> c2) + -- | A description of an externally meaningful value. data ValueDesc = -- | An array with memory block memory space, element type, @@ -254,12 +263,10 @@ DeclareMem VName Space | -- | Declare a scalar variable with an initially undefined value. DeclareScalar VName Volatility PrimType - | -- | Create an array containing the given values. The - -- lifetime of the array will be the entire application. - -- This is mostly used for constant arrays, but also for - -- some bookkeeping data, like the synchronisation - -- counts used to implement reduction. - DeclareArray VName Space PrimType ArrayContents + | -- | Create a DefaultSpace array containing the given values. The + -- lifetime of the array will be the entire application. This is + -- mostly used for constant arrays. + DeclareArray VName PrimType ArrayContents | -- | Memory space must match the corresponding -- 'DeclareMem'. Allocate VName (Count Bytes (TExp Int64)) Space @@ -534,9 +541,9 @@ vol' = case vol of Volatile -> "volatile " Nonvolatile -> mempty - pretty (DeclareArray name space t vs) = + pretty (DeclareArray name t vs) = "array" - <+> pretty name <> "@" <> pretty space + <+> pretty name <+> ":" <+> pretty t <+> equals @@ -571,7 +578,7 @@ "assert" <> parens (commasep [pretty msg, pretty e]) pretty (Copy t dest destoffset destspace src srcoffset srcspace size) = "copy" - <> parens + <> (parens . align) ( pretty t <> comma ppMemLoc dest destoffset <> pretty destspace <> comma ppMemLoc src srcoffset <> pretty srcspace <> comma @@ -652,8 +659,8 @@ pure $ DeclareMem name space traverse _ (DeclareScalar name vol bt) = pure $ DeclareScalar name vol bt - traverse _ (DeclareArray name space t vs) = - pure $ DeclareArray name space t vs + traverse _ (DeclareArray name t vs) = + pure $ DeclareArray name t vs traverse _ (Allocate name size s) = pure $ Allocate name size s traverse _ (Free name space) = @@ -684,7 +691,7 @@ declaredIn :: Code a -> Names declaredIn (DeclareMem name _) = oneName name declaredIn (DeclareScalar name _ _) = oneName name -declaredIn (DeclareArray name _ _ _) = oneName name +declaredIn (DeclareArray name _ _) = oneName name declaredIn (If _ t f) = declaredIn t <> declaredIn f declaredIn (x :>>: y) = declaredIn x <> declaredIn y declaredIn (For i _ body) = oneName i <> declaredIn body 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 @@ -114,6 +114,7 @@ (<--), (<~~), function, + genConstants, warn, module Language.Futhark.Warnings, ) @@ -285,6 +286,7 @@ { stateVTable :: VTable rep, stateFunctions :: Imp.Functions op, stateCode :: Imp.Code op, + stateConstants :: Imp.Constants op, stateWarnings :: Warnings, -- | Maps the arrays backing each accumulator to their -- update function and neutral elements. This works @@ -297,7 +299,7 @@ } newState :: VNameSource -> ImpState rep r op -newState = ImpState mempty mempty mempty mempty mempty +newState = ImpState mempty mempty mempty mempty mempty mempty newtype ImpM rep r op a = ImpM (ReaderT (Env rep r op) (State (ImpState rep r op)) a) @@ -370,6 +372,7 @@ stateFunctions = mempty, stateCode = mempty, stateNameSource = stateNameSource s, + stateConstants = mempty, stateWarnings = mempty, stateAccs = stateAccs s } @@ -445,11 +448,14 @@ unzip $ parMap rpar (compileFunDef' src) funs free_in_funs = freeIn $ mconcat $ map stateFunctions ss - (consts', s') = + ((), s') = runImpM (compileConsts free_in_funs consts) r ops space $ combineStates ss in ( ( stateWarnings s', - Imp.Definitions types consts' (stateFunctions s') + Imp.Definitions + types + (stateConstants s' <> foldMap stateConstants ss) + (stateFunctions s') ), stateNameSource s' ) @@ -472,27 +478,10 @@ mconcat $ map stateWarnings ss } -compileConsts :: Names -> Stms rep -> ImpM rep r op (Imp.Constants op) -compileConsts used_consts stms = do - code <- collect $ compileStms used_consts stms $ pure () - pure $ uncurry Imp.Constants $ first DL.toList $ extract code - where - -- Fish out those top-level declarations in the constant - -- initialisation code that are free in the functions. - extract (x Imp.:>>: y) = - extract x <> extract y - extract (Imp.DeclareMem name space) - | name `nameIn` used_consts = - ( DL.singleton $ Imp.MemParam name space, - mempty - ) - extract (Imp.DeclareScalar name _ t) - | name `nameIn` used_consts = - ( DL.singleton $ Imp.ScalarParam name t, - mempty - ) - extract s = - (mempty, s) +compileConsts :: Names -> Stms rep -> ImpM rep r op () +compileConsts used_consts stms = genConstants $ do + compileStms used_consts stms $ pure () + pure (used_consts, ()) lookupOpaqueType :: Name -> OpaqueTypes -> OpaqueType lookupOpaqueType v (OpaqueTypes types) = @@ -983,15 +972,13 @@ defCompileBasicOp (Pat [pe]) (ArrayLit es _) | Just vs@(v : _) <- mapM isLiteral es = do dest_mem <- entryArrayLoc <$> lookupArray (patElemName pe) - dest_space <- entryMemSpace <$> lookupMemory (memLocName dest_mem) let t = primValueType v static_array <- newVNameForFun "static_array" - emit $ Imp.DeclareArray static_array dest_space t $ Imp.ArrayValues vs + emit $ Imp.DeclareArray static_array t $ Imp.ArrayValues vs let static_src = MemLoc static_array [intConst Int64 $ fromIntegral $ length es] $ IxFun.iota [fromIntegral $ length es] - entry = MemVar Nothing $ MemEntry dest_space - addVar static_array entry + addVar static_array $ MemVar Nothing $ MemEntry DefaultSpace copy t dest_mem static_src | otherwise = forM_ (zip [0 ..] es) $ \(i, e) -> @@ -1877,15 +1864,15 @@ sAllocArrayPerm name pt shape space [0 .. shapeRank shape - 1] -- | Uses linear/iota index function. -sStaticArray :: String -> Space -> PrimType -> Imp.ArrayContents -> ImpM rep r op VName -sStaticArray name space pt vs = do +sStaticArray :: String -> PrimType -> Imp.ArrayContents -> ImpM rep r op VName +sStaticArray name pt vs = do let num_elems = case vs of Imp.ArrayValues vs' -> length vs' Imp.ArrayZeros n -> fromIntegral n shape = Shape [intConst Int64 $ toInteger num_elems] mem <- newVNameForFun $ name ++ "_mem" - emit $ Imp.DeclareArray mem space pt vs - addVar mem $ MemVar Nothing $ MemEntry space + emit $ Imp.DeclareArray mem pt vs + addVar mem $ MemVar Nothing $ MemEntry DefaultSpace sArray name pt shape mem $ IxFun.iota [fromIntegral num_elems] sWrite :: VName -> [Imp.TExp Int64] -> Imp.Exp -> ImpM rep r op () @@ -1973,6 +1960,40 @@ addParam (Imp.ScalarParam name bt) = addVar name $ ScalarVar Nothing $ ScalarEntry bt newFunction env = env {envFunction = Just fname} + +-- Fish out those top-level declarations in the constant +-- initialisation code that are free in the functions. +constParams :: Names -> Imp.Code a -> (DL.DList Imp.Param, Imp.Code a) +constParams used (x Imp.:>>: y) = + constParams used x <> constParams used y +constParams used (Imp.DeclareMem name space) + | name `nameIn` used = + ( DL.singleton $ Imp.MemParam name space, + mempty + ) +constParams used (Imp.DeclareScalar name _ t) + | name `nameIn` used = + ( DL.singleton $ Imp.ScalarParam name t, + mempty + ) +constParams used s@(Imp.DeclareArray name _ _) + | name `nameIn` used = + ( DL.singleton $ Imp.MemParam name DefaultSpace, + s + ) +constParams _ s = + (mempty, s) + +-- | Generate constants that get put outside of all functions. Will +-- be executed at program startup. Action must return the names that +-- should should be made available. This one has real sharp edges. Do +-- not use inside 'subImpM'. Do not use any variable from the context. +genConstants :: ImpM rep r op (Names, a) -> ImpM rep r op a +genConstants m = do + ((avail, a), code) <- collect' m + let consts = uncurry Imp.Constants $ first DL.toList $ constParams avail code + modify $ \s -> s {stateConstants = stateConstants s <> consts} + pure a dSlices :: [Imp.TExp Int64] -> ImpM rep r op [Imp.TExp Int64] dSlices = fmap (drop 1 . snd) . dSlices' 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 @@ -12,7 +12,6 @@ where import Control.Monad.Except -import Data.Bifunctor (second) import Data.List (foldl') import Data.Map qualified as M import Data.Maybe @@ -25,7 +24,6 @@ import Futhark.CodeGen.ImpGen.GPU.SegRed import Futhark.CodeGen.ImpGen.GPU.SegScan import Futhark.CodeGen.ImpGen.GPU.Transpose -import Futhark.CodeGen.SetDefaultSpace import Futhark.Error import Futhark.IR.GPUMem import Futhark.IR.Mem.IxFun qualified as IxFun @@ -78,19 +76,10 @@ HostEnv -> Prog GPUMem -> m (Warnings, Imp.Program) -compileProg env prog = - second (fmap setOpSpace . setDefaultSpace device_space) - <$> Futhark.CodeGen.ImpGen.compileProg env callKernelOperations device_space prog +compileProg env = + Futhark.CodeGen.ImpGen.compileProg env callKernelOperations device_space where device_space = Imp.Space "device" - global_space = Imp.Space "global" - setOpSpace (Imp.CallKernel kernel) = - Imp.CallKernel - kernel - { Imp.kernelBody = - setDefaultCodeSpace global_space $ Imp.kernelBody kernel - } - setOpSpace op = op -- | Compile a 'GPUMem' program to low-level parallel code, with -- either CUDA or OpenCL characteristics. @@ -228,9 +217,7 @@ | Just (op_lam, _) <- op, AtomicLocking _ <- atomicUpdateLocking atomics op_lam = do let num_locks = 100151 - locks_arr <- - sStaticArray "withacc_locks" (Space "device") int32 $ - Imp.ArrayZeros num_locks + locks_arr <- genZeroes "withacc_locks" num_locks let locks = Locks locks_arr num_locks extend env = env {hostLocks = M.insert c locks $ hostLocks env} localEnv extend $ locksForInputs atomics inputs' 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 @@ -29,6 +29,7 @@ groupCoverSpace, fenceForArrays, updateAcc, + genZeroes, -- * Host-level bulk operations sReplicate, @@ -161,6 +162,16 @@ f locking space arrs is' Nothing -> error $ "Missing locks for " ++ prettyString acc + +-- | Generate a constant device array of 32-bit integer zeroes with +-- the given number of elements. Initialised with a replicate. +genZeroes :: String -> Int -> CallKernelGen VName +genZeroes desc n = genConstants $ do + counters_mem <- sAlloc (desc <> "_mem") (4 * fromIntegral n) (Space "device") + let shape = Shape [intConst Int64 (fromIntegral n)] + counters <- sArrayInMem desc int32 shape counters_mem + sReplicate counters $ intConst Int32 0 + pure (namesFromList [counters_mem], counters) compileThreadExp :: ExpCompiler GPUMem KernelEnv Imp.KernelOp compileThreadExp (Pat [pe]) (BasicOp (Opaque _ se)) = 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 @@ -185,9 +185,7 @@ ++ [tvSize (slugNumSubhistos slug)] ++ shapeDims (histShape (slugOp slug)) - locks <- - sStaticArray "hist_locks" (Space "device") int32 $ - Imp.ArrayZeros num_locks + locks <- genZeroes "hist_locks" num_locks let l' = Locking locks 0 1 0 (pure . (`rem` fromIntegral num_locks) . flattenIndex dims) pure (Just l', f l' (Space "global") dests) @@ -724,8 +722,8 @@ sOp $ Imp.Barrier Imp.FenceLocal - kernelLoop pgtid_in_segment threads_per_segment (sExt32 segment_size') $ \ie -> do - dPrimV_ i_in_segment $ sExt64 ie + kernelLoop (sExt64 pgtid_in_segment) (sExt64 threads_per_segment) segment_size' $ \ie -> do + dPrimV_ i_in_segment ie -- We execute the bucket function once and update each histogram -- serially. This also involves writing to the mapout arrays if 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 @@ -189,9 +189,7 @@ global_tid = Imp.le64 $ segFlat space w = last dims' - counter <- - sStaticArray "counter" (Space "device") int32 $ - Imp.ArrayZeros (fromIntegral maxNumOps) + counter <- genZeroes "counters" $ fromIntegral maxNumOps reds_group_res_arrs <- groupResultArrays num_groups group_size reds @@ -430,9 +428,7 @@ -- if the group count exceeds the maximum group size, which is at -- most 1024 anyway. let num_counters = fromIntegral maxNumOps * 1024 - counter <- - sStaticArray "counter" (Space "device") int32 $ - Imp.ArrayZeros num_counters + counter <- genZeroes "counters" num_counters sKernelThread "segred_large" (segFlat space) (defKernelAttrs num_groups group_size) $ do constants <- kernelConstants <$> askEnv 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 @@ -260,7 +260,7 @@ 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 + globalId <- genZeroes "id_counter" 1 statusFlags <- sAllocArray "status_flags" int8 (Shape [unCount num_groups]) (Space "device") (aggregateArrays, incprefixArrays) <- fmap unzip $ 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 @@ -96,14 +96,18 @@ SizeThreshold (filter ((`elem` known) . fst) path) def clean s = s -pointerQuals :: Monad m => String -> m [C.TypeQual] -pointerQuals "global" = pure [C.ctyquals|__global|] -pointerQuals "local" = pure [C.ctyquals|__local|] -pointerQuals "private" = pure [C.ctyquals|__private|] -pointerQuals "constant" = pure [C.ctyquals|__constant|] -pointerQuals "write_only" = pure [C.ctyquals|__write_only|] -pointerQuals "read_only" = pure [C.ctyquals|__read_only|] -pointerQuals "kernel" = pure [C.ctyquals|__kernel|] +pointerQuals :: String -> [C.TypeQual] +pointerQuals "global" = [C.ctyquals|__global|] +pointerQuals "local" = [C.ctyquals|__local|] +pointerQuals "private" = [C.ctyquals|__private|] +pointerQuals "constant" = [C.ctyquals|__constant|] +pointerQuals "write_only" = [C.ctyquals|__write_only|] +pointerQuals "read_only" = [C.ctyquals|__read_only|] +pointerQuals "kernel" = [C.ctyquals|__kernel|] +-- OpenCL does not actually have a "device" space, but we use it in +-- the compiler pipeline to defer to memory on the device, as opposed +-- to the host. From a kernel's perspective, this is "global". +pointerQuals "device" = pointerQuals "global" pointerQuals s = error $ "'" ++ s ++ "' is not an OpenCL kernel address space." -- In-kernel name and per-workgroup size in bytes. @@ -348,13 +352,17 @@ let (use_params, unpack_params) = unzip $ mapMaybe useAsParam $ kernelUses kernel + -- The local_failure variable is an int despite only really storing + -- a single bit of information, as some OpenCL implementations + -- (e.g. AMD) does not like byte-sized local memory (and the others + -- likely pad to a whole word anyway). let (safety, error_init) -- We conservatively assume that any called function can fail. | not $ null called = ( SafetyFull, - [C.citems|volatile __local bool local_failure; + [C.citems|volatile __local int local_failure; // Harmless for all threads to write this. - local_failure = false;|] + local_failure = 0;|] ) | length (kernelFailures kstate) == length failures = if kernelFailureTolerant kernel @@ -374,7 +382,7 @@ else ( SafetyFull, [C.citems| - volatile __local bool local_failure; + volatile __local int local_failure; if (failure_is_an_option) { int failed = *global_failure >= 0; if (failed) { @@ -382,7 +390,7 @@ } } // All threads write this value - it looks like CUDA has a compiler bug otherwise. - local_failure = false; + local_failure = 0; barrier(CLK_LOCAL_MEM_FENCE); |] ) @@ -696,7 +704,6 @@ GC.opsAllocate = cannotAllocate, GC.opsDeallocate = cannotDeallocate, GC.opsCopy = copyInKernel, - GC.opsStaticArray = noStaticArrays, GC.opsFatMemory = False, GC.opsError = errorInKernel, GC.opsCall = callInKernel, @@ -743,9 +750,9 @@ atomicCast s t = do let volatile = [C.ctyquals|volatile|] - quals <- case s of - Space sid -> pointerQuals sid - _ -> pointerQuals "global" + let quals = case s of + Space sid -> pointerQuals sid + _ -> pointerQuals "global" pure [C.cty|$tyquals:(volatile++quals) $ty:t|] atomicSpace (Space sid) = sid @@ -833,13 +840,8 @@ copyInKernel _ _ _ _ _ _ _ _ = error "Cannot bulk copy in kernel." - noStaticArrays :: GC.StaticArray KernelOp KernelState - noStaticArrays _ _ _ _ = - error "Cannot create static array in kernel." - - kernelMemoryType space = do - quals <- pointerQuals space - pure [C.cty|$tyquals:quals $ty:defaultMemBlockType|] + kernelMemoryType space = + pure [C.cty|$tyquals:(pointerQuals space) $ty:defaultMemBlockType|] kernelWriteScalar = GC.writeScalarPointerWithQuals pointerQuals @@ -852,7 +854,7 @@ pendingError True pure $ if has_communication - then [C.citems|local_failure = true; goto $id:label;|] + then [C.citems|local_failure = 1; goto $id:label;|] else if mode == FunMode then [C.citems|return 1;|] @@ -907,7 +909,7 @@ typesInCode (While (TPrimExp e) c) = typesInExp e <> typesInCode c typesInCode DeclareMem {} = mempty typesInCode (DeclareScalar _ _ t) = S.singleton t -typesInCode (DeclareArray _ _ t _) = S.singleton t +typesInCode (DeclareArray _ t _) = S.singleton t typesInCode (Allocate _ (Count (TPrimExp e)) _) = typesInExp e typesInCode Free {} = mempty typesInCode (Copy _ _ (Count (TPrimExp e1)) _ _ (Count (TPrimExp e2)) _ (Count (TPrimExp e3))) = 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 @@ -105,8 +105,7 @@ AtomicLocking _ <- atomicUpdateLocking atomics op_lam = do let num_locks = 100151 locks_arr <- - sStaticArray "withacc_locks" DefaultSpace int32 $ - Imp.ArrayZeros num_locks + sStaticArray "withacc_locks" int32 $ Imp.ArrayZeros num_locks let locks = Locks locks_arr num_locks extend env = env {hostLocks = M.insert c locks $ hostLocks env} localEnv extend $ locksForInputs atomics inputs' @@ -123,9 +122,9 @@ compileMCOp :: Pat LetDecMem -> - MCOp MCMem () -> + MCOp NoOp MCMem -> ImpM MCMem HostEnv Imp.Multicore () -compileMCOp _ (OtherOp ()) = pure () +compileMCOp _ (OtherOp NoOp) = pure () compileMCOp pat (ParOp par_op op) = do let space = getSpace op dPrimV_ (segFlat space) (0 :: Imp.TExp Int64) 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 @@ -96,7 +96,7 @@ let num_locks = 100151 -- This number is taken from the GPU backend dims = map pe64 $ shapeDims (histOpShape op <> histShape op) locks <- - sStaticArray "hist_locks" DefaultSpace int32 $ + sStaticArray "hist_locks" int32 $ Imp.ArrayZeros num_locks let l' = Locking locks 0 1 0 (pure . (`rem` fromIntegral num_locks) . flattenIndex dims) pure $ f l' diff --git a/src/Futhark/CodeGen/ImpGen/Sequential.hs b/src/Futhark/CodeGen/ImpGen/Sequential.hs --- a/src/Futhark/CodeGen/ImpGen/Sequential.hs +++ b/src/Futhark/CodeGen/ImpGen/Sequential.hs @@ -19,4 +19,4 @@ ops = ImpGen.defaultOperations opCompiler opCompiler dest (Alloc e space) = ImpGen.compileAlloc dest e space - opCompiler _ (Inner ()) = pure () + opCompiler _ (Inner NoOp) = pure () diff --git a/src/Futhark/CodeGen/RTS/C.hs b/src/Futhark/CodeGen/RTS/C.hs --- a/src/Futhark/CodeGen/RTS/C.hs +++ b/src/Futhark/CodeGen/RTS/C.hs @@ -5,11 +5,9 @@ ( atomicsH, contextH, contextPrototypesH, - cudaH, freeListH, halfH, lockH, - openclH, scalarF16H, scalarH, schedulerH, @@ -22,6 +20,10 @@ cacheH, uniformH, ispcUtilH, + backendsOpenclH, + backendsCudaH, + backendsCH, + backendsMulticoreH, ) where @@ -41,11 +43,6 @@ uniformH = $(embedStringFile "rts/c/uniform.h") {-# NOINLINE uniformH #-} --- | @rts/c/cuda.h@ -cudaH :: T.Text -cudaH = $(embedStringFile "rts/c/cuda.h") -{-# NOINLINE cudaH #-} - -- | @rts/c/free_list.h@ freeListH :: T.Text freeListH = $(embedStringFile "rts/c/free_list.h") @@ -61,11 +58,6 @@ lockH = $(embedStringFile "rts/c/lock.h") {-# NOINLINE lockH #-} --- | @rts/c/opencl.h@ -openclH :: T.Text -openclH = $(embedStringFile "rts/c/opencl.h") -{-# NOINLINE openclH #-} - -- | @rts/c/scalar_f16.h@ scalarF16H :: T.Text scalarF16H = $(embedStringFile "rts/c/scalar_f16.h") @@ -130,3 +122,23 @@ contextPrototypesH :: T.Text contextPrototypesH = $(embedStringFile "rts/c/context_prototypes.h") {-# NOINLINE contextPrototypesH #-} + +-- | @rts/c/backends/opencl.h@ +backendsOpenclH :: T.Text +backendsOpenclH = $(embedStringFile "rts/c/backends/opencl.h") +{-# NOINLINE backendsOpenclH #-} + +-- | @rts/c/backends/cuda.h@ +backendsCudaH :: T.Text +backendsCudaH = $(embedStringFile "rts/c/backends/cuda.h") +{-# NOINLINE backendsCudaH #-} + +-- | @rts/c/backends/c.h@ +backendsCH :: T.Text +backendsCH = $(embedStringFile "rts/c/backends/c.h") +{-# NOINLINE backendsCH #-} + +-- | @rts/c/backends/multicore.h@ +backendsMulticoreH :: T.Text +backendsMulticoreH = $(embedStringFile "rts/c/backends/multicore.h") +{-# NOINLINE backendsMulticoreH #-} diff --git a/src/Futhark/CodeGen/SetDefaultSpace.hs b/src/Futhark/CodeGen/SetDefaultSpace.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/SetDefaultSpace.hs +++ /dev/null @@ -1,112 +0,0 @@ --- | Change 'DefaultSpace' in a program to some other memory space. --- This is needed because the GPU backends use 'DefaultSpace' to refer --- to GPU memory for most of the pipeline, but final code generation --- assumes that 'DefaultSpace' is CPU memory. -module Futhark.CodeGen.SetDefaultSpace - ( setDefaultSpace, - setDefaultCodeSpace, - ) -where - -import Futhark.CodeGen.ImpCode - --- | Set all uses of 'DefaultSpace' in the given definitions to another --- memory space. -setDefaultSpace :: Space -> Definitions op -> Definitions op -setDefaultSpace space (Definitions types (Constants ps consts) (Functions fundecs)) = - Definitions - types - (Constants (map (setParamSpace space) ps) (setCodeSpace space consts)) - ( Functions - [ (fname, setFunctionSpace space func) - | (fname, func) <- fundecs - ] - ) - --- | Like 'setDefaultSpace', but for 'Code'. -setDefaultCodeSpace :: Space -> Code op -> Code op -setDefaultCodeSpace = setCodeSpace - -setFunctionSpace :: Space -> Function op -> Function op -setFunctionSpace space (Function entry outputs inputs body) = - Function - (setEntrySpace space <$> entry) - (map (setParamSpace space) outputs) - (map (setParamSpace space) inputs) - (setCodeSpace space body) - -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 -setParamSpace space (MemParam name DefaultSpace) = - MemParam name space -setParamSpace _ param = - param - -setExtValueSpace :: Space -> ExternalValue -> ExternalValue -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) = - ArrayValue mem space bt ept shape -setValueSpace _ (ScalarValue bt ept v) = - ScalarValue bt ept v - -setCodeSpace :: Space -> Code op -> Code op -setCodeSpace space (Allocate v e old_space) = - Allocate v e $ setSpace space old_space -setCodeSpace space (Free v old_space) = - Free v $ setSpace space old_space -setCodeSpace space (DeclareMem name old_space) = - DeclareMem name $ setSpace space old_space -setCodeSpace space (DeclareArray name _ t vs) = - DeclareArray name space t vs -setCodeSpace space (Copy t dest dest_offset dest_space src src_offset src_space n) = - Copy t dest dest_offset dest_space' src src_offset src_space' n - where - dest_space' = setSpace space dest_space - src_space' = setSpace space src_space -setCodeSpace space (Write dest dest_offset bt dest_space vol e) = - Write dest dest_offset bt (setSpace space dest_space) vol e -setCodeSpace space (Read x dest dest_offset bt dest_space vol) = - Read x dest dest_offset bt (setSpace space dest_space) vol -setCodeSpace space (c1 :>>: c2) = - setCodeSpace space c1 :>>: setCodeSpace space c2 -setCodeSpace space (For i e body) = - For i e $ setCodeSpace space body -setCodeSpace space (While e body) = - While e $ setCodeSpace space body -setCodeSpace space (If e c1 c2) = - If e (setCodeSpace space c1) (setCodeSpace space c2) -setCodeSpace space (Comment s c) = - Comment s $ setCodeSpace space c -setCodeSpace _ Skip = - Skip -setCodeSpace _ (DeclareScalar name vol bt) = - DeclareScalar name vol bt -setCodeSpace _ (SetScalar name e) = - SetScalar name e -setCodeSpace space (SetMem to from old_space) = - SetMem to from $ setSpace space old_space -setCodeSpace _ (Call dests fname args) = - Call dests fname args -setCodeSpace _ (Assert e msg loc) = - Assert e msg loc -setCodeSpace _ (DebugPrint s v) = - DebugPrint s v -setCodeSpace _ (TracePrint msg) = - TracePrint msg -setCodeSpace _ (Op op) = - Op op - -setSpace :: Space -> Space -> Space -setSpace space DefaultSpace = space -setSpace _ space = space 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 @@ -113,7 +113,7 @@ vnameToFileMap :: Imports -> FileMap vnameToFileMap = mconcat . map forFile where - forFile (file, FileModule abs file_env _prog) = + forFile (file, FileModule abs file_env _prog _) = mconcat (map (vname Type) (M.keys abs)) <> forEnv file_env where @@ -436,7 +436,7 @@ ps' <- modParamHtml ps pure $ specRow (keyword "module " <> name') ": " (ps' <> sig') - FileModule _abs Env {envModTable = modtable} _ = fm + FileModule _abs Env {envModTable = modtable} _ _ = fm envSig (ModEnv e) = renderEnv e envSig (ModFun (FunSig _ _ (MTy _ m))) = envSig m 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 @@ -28,6 +28,8 @@ mkAliasedBody, mkAliasedPat, mkBodyAliasing, + CanBeAliased (..), + AliasableRep, -- * Removing aliases removeProgAliases, @@ -49,9 +51,9 @@ import Control.Monad.Identity import Control.Monad.Reader +import Data.Kind qualified import Data.Map.Strict qualified as M import Data.Maybe -import Futhark.Analysis.Rephrase import Futhark.Builder import Futhark.IR.Pretty import Futhark.IR.Prop @@ -63,7 +65,7 @@ import Futhark.Util.Pretty qualified as PP -- | The rep for the basic representation. -data Aliases rep +data Aliases (rep :: Data.Kind.Type) -- | A wrapper around 'AliasDec' to get around the fact that we need an -- 'Ord' instance, which 'AliasDec does not have. @@ -104,7 +106,7 @@ -- consumed inside of it. type BodyAliasing = ([VarAliases], ConsumedInExp) -instance (RepTypes rep, CanBeAliased (Op rep)) => RepTypes (Aliases rep) where +instance (RepTypes rep, ASTConstraints (OpC rep (Aliases rep))) => RepTypes (Aliases rep) where type LetDec (Aliases rep) = (VarAliases, LetDec rep) type ExpDec (Aliases rep) = (ConsumedInExp, ExpDec rep) type BodyDec (Aliases rep) = (BodyAliasing, BodyDec rep) @@ -112,7 +114,7 @@ type LParamInfo (Aliases rep) = LParamInfo rep type RetType (Aliases rep) = RetType rep type BranchType (Aliases rep) = BranchType rep - type Op (Aliases rep) = OpWithAliases (Op rep) + type OpC (Aliases rep) = OpC rep instance AliasesOf (VarAliases, dec) where aliasesOf = unAliases . fst @@ -127,15 +129,15 @@ scope <- asksScope removeScopeAliases runReaderT m scope -instance (ASTRep rep, CanBeAliased (Op rep)) => ASTRep (Aliases rep) where +instance (ASTRep rep, AliasedOp (OpC rep (Aliases rep))) => ASTRep (Aliases rep) where expTypesFromPat = withoutAliases . expTypesFromPat . removePatAliases -instance (ASTRep rep, CanBeAliased (Op rep)) => Aliased (Aliases rep) where +instance (ASTRep rep, AliasedOp (OpC rep (Aliases rep))) => Aliased (Aliases rep) where bodyAliases = map unAliases . fst . fst . bodyDec consumedInBody = unAliases . snd . fst . bodyDec -instance (ASTRep rep, CanBeAliased (Op rep)) => PrettyRep (Aliases rep) where +instance (ASTRep rep, AliasedOp (OpC rep (Aliases rep))) => PrettyRep (Aliases rep) where ppExpDec (consumed, inner) e = maybeComment . catMaybes $ [exp_dec, merge_dec, ppExpDec inner $ removeExpAliases e] @@ -176,7 +178,7 @@ <> " aliases " <> PP.commasep (map PP.pretty als') -removeAliases :: CanBeAliased (Op rep) => Rephraser Identity (Aliases rep) rep +removeAliases :: RephraseOp (OpC rep) => Rephraser Identity (Aliases rep) rep removeAliases = Rephraser { rephraseExpDec = pure . snd, @@ -186,7 +188,7 @@ rephraseLParamDec = pure, rephraseRetType = pure, rephraseBranchType = pure, - rephraseOp = pure . removeOpAliases + rephraseOp = rephraseInOp removeAliases } -- | Remove alias information from an aliased scope. @@ -200,42 +202,42 @@ -- | Remove alias information from a program. removeProgAliases :: - CanBeAliased (Op rep) => + RephraseOp (OpC rep) => Prog (Aliases rep) -> Prog rep removeProgAliases = runIdentity . rephraseProg removeAliases -- | Remove alias information from a function. removeFunDefAliases :: - CanBeAliased (Op rep) => + RephraseOp (OpC rep) => FunDef (Aliases rep) -> FunDef rep removeFunDefAliases = runIdentity . rephraseFunDef removeAliases -- | Remove alias information from an expression. removeExpAliases :: - CanBeAliased (Op rep) => + RephraseOp (OpC rep) => Exp (Aliases rep) -> Exp rep removeExpAliases = runIdentity . rephraseExp removeAliases -- | Remove alias information from statements. removeStmAliases :: - CanBeAliased (Op rep) => + RephraseOp (OpC rep) => Stm (Aliases rep) -> Stm rep removeStmAliases = runIdentity . rephraseStm removeAliases -- | Remove alias information from body. removeBodyAliases :: - CanBeAliased (Op rep) => + RephraseOp (OpC rep) => Body (Aliases rep) -> Body rep removeBodyAliases = runIdentity . rephraseBody removeAliases -- | Remove alias information from lambda. removeLambdaAliases :: - CanBeAliased (Op rep) => + RephraseOp (OpC rep) => Lambda (Aliases rep) -> Lambda rep removeLambdaAliases = runIdentity . rephraseLambda removeAliases @@ -249,7 +251,7 @@ -- | Augment a body decoration with aliasing information provided by -- the statements and result of that body. mkAliasedBody :: - (ASTRep rep, CanBeAliased (Op rep)) => + (ASTRep rep, AliasedOp (OpC rep (Aliases rep))) => BodyDec rep -> Stms (Aliases rep) -> Result -> @@ -264,26 +266,22 @@ Pat dec -> Exp rep -> Pat (VarAliases, dec) -mkAliasedPat pat e = Pat $ zipWith annotatePatElem (patElems pat) als +mkAliasedPat (Pat pes) e = + Pat $ zipWith annotate pes $ expAliases pes e where - -- Repeat mempty in case the pattern has more elements (this - -- implies a type error). - als = expAliases e ++ repeat mempty - annotatePatElem bindee names = - bindee `setPatElemDec` (AliasDec names', patElemDec bindee) + annotate (PatElem v dec) names = PatElem v (AliasDec names', dec) where names' = - case patElemType bindee of + case typeOf dec of Array {} -> names Mem _ -> names _ -> mempty -- | Given statements (with aliasing information) and a body result, -- produce aliasing information for the corresponding body as a whole. --- This is basically just looking up the aliasing of each element of --- the result, and removing the names that are no longer in scope. --- Note that this does *not* include aliases of results that are not --- bound in the statements! +-- The aliasing includes names bound in the body, i.e. which are not +-- in scope outside of it. Note that this does *not* include aliases +-- of results that are not bound in the statements! mkBodyAliasing :: Aliased rep => Stms rep -> @@ -296,9 +294,8 @@ -- bound in stms. let (aliases, consumed) = mkStmsAliases stms res boundNames = foldMap (namesFromList . patNames . stmPat) stms - aliases' = map (`namesSubtract` boundNames) aliases consumed' = consumed `namesSubtract` boundNames - in (map AliasDec aliases', AliasDec consumed') + in (map AliasDec aliases, AliasDec consumed') -- | The aliases of the result and everything consumed in the given -- statements. @@ -360,7 +357,7 @@ look k = M.findWithDefault mempty k aliasmap mkAliasedStm :: - (ASTRep rep, CanBeAliased (Op rep)) => + (ASTRep rep, AliasedOp (OpC rep (Aliases rep))) => Pat (LetDec rep) -> StmAux (ExpDec rep) -> Exp (Aliases rep) -> @@ -371,7 +368,7 @@ (StmAux cs attrs (AliasDec $ consumedInExp e, dec)) e -instance (Buildable rep, CanBeAliased (Op rep)) => Buildable (Aliases rep) where +instance (Buildable rep, AliasedOp (OpC rep (Aliases rep))) => Buildable (Aliases rep) where mkExpDec pat e = let dec = mkExpDec (removePatAliases pat) $ removeExpAliases e in (AliasDec $ consumedInExp e, dec) @@ -391,7 +388,26 @@ instance ( ASTRep rep, - CanBeAliased (Op rep), + AliasedOp (OpC rep (Aliases rep)), Buildable (Aliases rep) ) => BuilderOps (Aliases rep) + +-- | What we require of an aliasable representation. +type AliasableRep rep = + ( ASTRep rep, + RephraseOp (OpC rep), + CanBeAliased (OpC rep), + AliasedOp (OpC rep (Aliases rep)) + ) + +-- | The class of operations that can be given aliasing information. +-- This is a somewhat subtle concept that is only used in the +-- simplifier and when using "rep adapters". +class CanBeAliased op where + -- | Add aliases to this op. + addOpAliases :: + AliasableRep rep => AliasTable -> op rep -> op (Aliases rep) + +instance CanBeAliased NoOp where + addOpAliases _ NoOp = NoOp diff --git a/src/Futhark/IR/GPU.hs b/src/Futhark/IR/GPU.hs --- a/src/Futhark/IR/GPU.hs +++ b/src/Futhark/IR/GPU.hs @@ -17,6 +17,7 @@ import Futhark.Builder import Futhark.Construct +import Futhark.IR.Aliases (Aliases) import Futhark.IR.GPU.Op import Futhark.IR.GPU.Sizes import Futhark.IR.Pretty @@ -30,18 +31,21 @@ data GPU instance RepTypes GPU where - type Op GPU = HostOp GPU (SOAC GPU) + type OpC GPU = HostOp SOAC instance ASTRep GPU where expTypesFromPat = pure . expExtTypesFromPat -instance TC.CheckableOp GPU where +instance TC.Checkable GPU where checkOp = typeCheckGPUOp Nothing where + -- GHC 9.2 goes into an infinite loop without the type annotation. + typeCheckGPUOp :: + Maybe SegLevel -> + HostOp SOAC (Aliases GPU) -> + TC.TypeM GPU () typeCheckGPUOp lvl = typeCheckHostOp (typeCheckGPUOp . Just) lvl typeCheckSOAC - -instance TC.Checkable GPU instance Buildable GPU where mkBody = Body () 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 @@ -30,7 +30,7 @@ import Futhark.Analysis.Metrics import Futhark.Analysis.SymbolTable qualified as ST import Futhark.IR -import Futhark.IR.Aliases (Aliases, removeBodyAliases) +import Futhark.IR.Aliases (Aliases, CanBeAliased (..)) import Futhark.IR.GPU.Sizes import Futhark.IR.Prop.Aliases import Futhark.IR.SegOp @@ -239,11 +239,11 @@ TC.require [Prim int64] group_size -- | A host-level operation; parameterised by what else it can do. -data HostOp rep op +data HostOp op rep = -- | A segmented operation. SegOp (SegOp SegLevel rep) | SizeOp SizeOp - | OtherOp op + | OtherOp (op rep) | -- | Code to run sequentially on the GPU, -- in a single thread. GPUBody [Type] (Body rep) @@ -252,8 +252,8 @@ -- | A helper for defining 'TraverseOpStms'. traverseHostOpStms :: Monad m => - OpStmsTraverser m op rep -> - OpStmsTraverser m (HostOp rep op) rep + OpStmsTraverser m (op rep) rep -> + OpStmsTraverser m (HostOp op rep) rep traverseHostOpStms _ f (SegOp segop) = SegOp <$> traverseSegOpStms f segop traverseHostOpStms _ _ (SizeOp sizeop) = pure $ SizeOp sizeop traverseHostOpStms onOtherOp f (OtherOp other) = OtherOp <$> onOtherOp f other @@ -261,7 +261,7 @@ stms <- f mempty $ bodyStms body pure $ GPUBody ts $ body {bodyStms = stms} -instance (ASTRep rep, Substitute op) => Substitute (HostOp rep op) where +instance (ASTRep rep, Substitute (op rep)) => Substitute (HostOp op rep) where substituteNames substs (SegOp op) = SegOp $ substituteNames substs op substituteNames substs (OtherOp op) = @@ -271,13 +271,13 @@ substituteNames substs (GPUBody ts body) = GPUBody (substituteNames substs ts) (substituteNames substs body) -instance (ASTRep rep, Rename op) => Rename (HostOp rep op) where +instance (ASTRep rep, Rename (op rep)) => Rename (HostOp op rep) where rename (SegOp op) = SegOp <$> rename op rename (OtherOp op) = OtherOp <$> rename op rename (SizeOp op) = SizeOp <$> rename op rename (GPUBody ts body) = GPUBody <$> rename ts <*> rename body -instance (ASTRep rep, IsOp op) => IsOp (HostOp rep op) where +instance (ASTRep rep, IsOp (op rep)) => IsOp (HostOp op rep) where safeOp (SegOp op) = safeOp op safeOp (OtherOp op) = safeOp op safeOp (SizeOp op) = safeOp op @@ -291,14 +291,14 @@ -- transfer scalars to device. SQ.null (bodyStms body) && all ((== 0) . arrayRank) types -instance TypedOp op => TypedOp (HostOp rep op) where +instance TypedOp (op rep) => TypedOp (HostOp op rep) where opType (SegOp op) = opType op opType (OtherOp op) = opType op opType (SizeOp op) = opType op opType (GPUBody ts _) = pure $ staticShapes $ map (`arrayOfRow` intConst Int64 1) ts -instance (Aliased rep, AliasedOp op, ASTRep rep) => AliasedOp (HostOp rep op) where +instance (Aliased rep, AliasedOp (op rep)) => AliasedOp (HostOp op rep) where opAliases (SegOp op) = opAliases op opAliases (OtherOp op) = opAliases op opAliases (SizeOp op) = opAliases op @@ -309,56 +309,48 @@ consumedInOp (SizeOp op) = consumedInOp op consumedInOp (GPUBody _ body) = consumedInBody body -instance (ASTRep rep, FreeIn op) => FreeIn (HostOp rep op) where +instance (ASTRep rep, FreeIn (op rep)) => FreeIn (HostOp op rep) where freeIn' (SegOp op) = freeIn' op freeIn' (OtherOp op) = freeIn' op freeIn' (SizeOp op) = freeIn' op freeIn' (GPUBody ts body) = freeIn' ts <> freeIn' body -instance (CanBeAliased (Op rep), CanBeAliased op, ASTRep rep) => CanBeAliased (HostOp rep op) where - type OpWithAliases (HostOp rep op) = HostOp (Aliases rep) (OpWithAliases op) - +instance CanBeAliased op => CanBeAliased (HostOp op) where addOpAliases aliases (SegOp op) = SegOp $ addOpAliases aliases op addOpAliases aliases (GPUBody ts body) = GPUBody ts $ Alias.analyseBody aliases body addOpAliases aliases (OtherOp op) = OtherOp $ addOpAliases aliases op addOpAliases _ (SizeOp op) = SizeOp op - removeOpAliases (SegOp op) = SegOp $ removeOpAliases op - removeOpAliases (OtherOp op) = OtherOp $ removeOpAliases op - removeOpAliases (SizeOp op) = SizeOp op - removeOpAliases (GPUBody ts body) = GPUBody ts $ removeBodyAliases body - -instance (CanBeWise (Op rep), CanBeWise op, ASTRep rep) => CanBeWise (HostOp rep op) where - type OpWithWisdom (HostOp rep op) = HostOp (Wise rep) (OpWithWisdom op) - - removeOpWisdom (SegOp op) = SegOp $ removeOpWisdom op - removeOpWisdom (OtherOp op) = OtherOp $ removeOpWisdom op - removeOpWisdom (SizeOp op) = SizeOp op - removeOpWisdom (GPUBody ts body) = GPUBody ts $ removeBodyWisdom body - +instance CanBeWise op => CanBeWise (HostOp op) where addOpWisdom (SegOp op) = SegOp $ addOpWisdom op addOpWisdom (OtherOp op) = OtherOp $ addOpWisdom op addOpWisdom (SizeOp op) = SizeOp op addOpWisdom (GPUBody ts body) = GPUBody ts $ informBody body -instance (ASTRep rep, ST.IndexOp op) => ST.IndexOp (HostOp rep op) where +instance (ASTRep rep, ST.IndexOp (op rep)) => ST.IndexOp (HostOp op rep) where indexOp vtable k (SegOp op) is = ST.indexOp vtable k op is indexOp vtable k (OtherOp op) is = ST.indexOp vtable k op is indexOp _ _ _ _ = Nothing -instance (PrettyRep rep, PP.Pretty op) => PP.Pretty (HostOp rep op) where +instance (PrettyRep rep, PP.Pretty (op rep)) => PP.Pretty (HostOp op rep) where pretty (SegOp op) = pretty op pretty (OtherOp op) = pretty op pretty (SizeOp op) = pretty op pretty (GPUBody ts body) = "gpu" <+> PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body) -instance (OpMetrics (Op rep), OpMetrics op) => OpMetrics (HostOp rep op) where +instance (OpMetrics (Op rep), OpMetrics (op rep)) => OpMetrics (HostOp op rep) where opMetrics (SegOp op) = opMetrics op opMetrics (OtherOp op) = opMetrics op opMetrics (SizeOp op) = opMetrics op opMetrics (GPUBody _ body) = inside "GPUBody" $ bodyMetrics body +instance RephraseOp op => RephraseOp (HostOp op) where + rephraseInOp r (SegOp op) = SegOp <$> rephraseInOp r op + rephraseInOp r (OtherOp op) = OtherOp <$> rephraseInOp r op + rephraseInOp _ (SizeOp op) = pure $ SizeOp op + rephraseInOp r (GPUBody ts body) = GPUBody ts <$> rephraseBody r body + checkGrid :: TC.Checkable rep => KernelGrid -> TC.TypeM rep () checkGrid grid = do TC.require [Prim int64] $ unCount $ gridNumGroups grid @@ -390,10 +382,10 @@ typeCheckHostOp :: TC.Checkable rep => - (SegLevel -> OpWithAliases (Op rep) -> TC.TypeM rep ()) -> + (SegLevel -> Op (Aliases rep) -> TC.TypeM rep ()) -> Maybe SegLevel -> - (op -> TC.TypeM rep ()) -> - HostOp (Aliases rep) op -> + (op (Aliases rep) -> TC.TypeM rep ()) -> + HostOp op (Aliases rep) -> TC.TypeM rep () typeCheckHostOp checker lvl _ (SegOp op) = TC.checkOpWith (checker $ segLevel op) $ diff --git a/src/Futhark/IR/GPU/Simplify.hs b/src/Futhark/IR/GPU/Simplify.hs --- a/src/Futhark/IR/GPU/Simplify.hs +++ b/src/Futhark/IR/GPU/Simplify.hs @@ -43,9 +43,9 @@ ( Engine.SimplifiableRep rep, BodyDec rep ~ () ) => - Simplify.SimplifyOp rep op -> - HostOp (Wise rep) op -> - Engine.SimpleM rep (HostOp (Wise rep) op, Stms (Wise rep)) + Simplify.SimplifyOp rep (op (Wise rep)) -> + HostOp op (Wise rep) -> + Engine.SimpleM rep (HostOp op (Wise rep), Stms (Wise rep)) simplifyKernelOp f (OtherOp op) = do (op', stms) <- f op pure (OtherOp op', stms) diff --git a/src/Futhark/IR/GPUMem.hs b/src/Futhark/IR/GPUMem.hs --- a/src/Futhark/IR/GPUMem.hs +++ b/src/Futhark/IR/GPUMem.hs @@ -16,6 +16,7 @@ import Futhark.Analysis.PrimExp.Convert import Futhark.Analysis.UsageTable qualified as UT +import Futhark.IR.Aliases (Aliases) import Futhark.IR.GPU.Op import Futhark.IR.GPU.Simplify (simplifyKernelOp) import Futhark.IR.Mem @@ -34,30 +35,33 @@ type LParamInfo GPUMem = LParamMem type RetType GPUMem = RetTypeMem type BranchType GPUMem = BranchTypeMem - type Op GPUMem = MemOp (HostOp GPUMem ()) + type OpC GPUMem = MemOp (HostOp NoOp) instance ASTRep GPUMem where expTypesFromPat = pure . map snd . bodyReturnsFromPat -instance OpReturns (HostOp GPUMem ()) where +instance OpReturns (HostOp NoOp GPUMem) where opReturns (SegOp op) = segOpReturns op opReturns k = extReturns <$> opType k -instance OpReturns (HostOp (Engine.Wise GPUMem) ()) where +instance OpReturns (HostOp NoOp (Engine.Wise GPUMem)) where opReturns (SegOp op) = segOpReturns op opReturns k = extReturns <$> opType k instance PrettyRep GPUMem -instance TC.CheckableOp GPUMem where +instance TC.Checkable GPUMem where checkOp = typeCheckMemoryOp Nothing where + -- GHC 9.2 goes into an infinite loop without the type annotation. + typeCheckMemoryOp :: + Maybe SegLevel -> + MemOp (HostOp NoOp) (Aliases GPUMem) -> + TC.TypeM GPUMem () typeCheckMemoryOp _ (Alloc size _) = TC.require [Prim int64] size typeCheckMemoryOp lvl (Inner op) = typeCheckHostOp (typeCheckMemoryOp . Just) lvl (const $ pure ()) op - -instance TC.Checkable GPUMem where checkFParamDec = checkMemInfo checkLParamDec = checkMemInfo checkLetBoundDec = checkMemInfo @@ -71,12 +75,12 @@ instance BuilderOps GPUMem where mkExpDecB _ _ = pure () mkBodyB stms res = pure $ Body () stms res - mkLetNamesB = mkLetNamesB' () + mkLetNamesB = mkLetNamesB' (Space "device") () instance BuilderOps (Engine.Wise GPUMem) where mkExpDecB pat e = pure $ Engine.mkWiseExpDec pat () e mkBodyB stms res = pure $ Engine.mkWiseBody () stms res - mkLetNamesB = mkLetNamesB'' + mkLetNamesB = mkLetNamesB'' (Space "device") instance TraverseOpStms (Engine.Wise GPUMem) where traverseOpStms = traverseMemOpStms (traverseHostOpStms (const pure)) @@ -90,7 +94,7 @@ simpleGPUMem :: Engine.SimpleOps GPUMem simpleGPUMem = - simpleGeneric usage $ simplifyKernelOp $ const $ pure ((), mempty) + simpleGeneric usage $ simplifyKernelOp $ const $ pure (NoOp, mempty) where -- Slightly hackily and very inefficiently, we look at the inside -- of SegOps to figure out the sizes of local memory allocations, diff --git a/src/Futhark/IR/MC.hs b/src/Futhark/IR/MC.hs --- a/src/Futhark/IR/MC.hs +++ b/src/Futhark/IR/MC.hs @@ -37,15 +37,13 @@ data MC instance RepTypes MC where - type Op MC = MCOp MC (SOAC MC) + type OpC MC = MCOp SOAC instance ASTRep MC where expTypesFromPat = pure . expExtTypesFromPat -instance TypeCheck.CheckableOp MC where +instance TypeCheck.Checkable MC where checkOp = typeCheckMCOp typeCheckSOAC - -instance TypeCheck.Checkable MC instance Buildable MC where mkBody = Body () 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 @@ -18,7 +18,7 @@ import Futhark.Analysis.Metrics import Futhark.Analysis.SymbolTable qualified as ST import Futhark.IR -import Futhark.IR.Aliases (Aliases) +import Futhark.IR.Aliases (Aliases, CanBeAliased (..)) import Futhark.IR.Prop.Aliases import Futhark.IR.SegOp import Futhark.IR.TypeCheck qualified as TC @@ -38,7 +38,7 @@ -- | An operation for the multicore representation. Feel free to -- extend this on an ad hoc basis as needed. Parameterised with some -- other operation. -data MCOp rep op +data MCOp op rep = -- | The first 'SegOp' (if it exists) contains nested parallelism, -- while the second one has a fully sequential body. They are -- semantically fully equivalent. @@ -46,86 +46,66 @@ (Maybe (SegOp () rep)) (SegOp () rep) | -- | Something else (in practice often a SOAC). - OtherOp op + OtherOp (op rep) deriving (Eq, Ord, Show) -traverseMCOpStms :: Monad m => OpStmsTraverser m op rep -> OpStmsTraverser m (MCOp rep op) rep +traverseMCOpStms :: + Monad m => + OpStmsTraverser m (op rep) rep -> + OpStmsTraverser m (MCOp op rep) rep traverseMCOpStms _ f (ParOp par_op op) = ParOp <$> traverse (traverseSegOpStms f) par_op <*> traverseSegOpStms f op traverseMCOpStms onInner f (OtherOp op) = OtherOp <$> onInner f op -instance (ASTRep rep, Substitute op) => Substitute (MCOp rep op) where +instance (ASTRep rep, Substitute (op rep)) => Substitute (MCOp op rep) where substituteNames substs (ParOp par_op op) = ParOp (substituteNames substs <$> par_op) (substituteNames substs op) substituteNames substs (OtherOp op) = OtherOp $ substituteNames substs op -instance (ASTRep rep, Rename op) => Rename (MCOp rep op) where +instance (ASTRep rep, Rename (op rep)) => Rename (MCOp op rep) where rename (ParOp par_op op) = ParOp <$> rename par_op <*> rename op rename (OtherOp op) = OtherOp <$> rename op -instance (ASTRep rep, FreeIn op) => FreeIn (MCOp rep op) where +instance (ASTRep rep, FreeIn (op rep)) => FreeIn (MCOp op rep) where freeIn' (ParOp par_op op) = freeIn' par_op <> freeIn' op freeIn' (OtherOp op) = freeIn' op -instance (ASTRep rep, IsOp op) => IsOp (MCOp rep op) where +instance (ASTRep rep, IsOp (op rep)) => IsOp (MCOp op rep) where safeOp (ParOp _ op) = safeOp op safeOp (OtherOp op) = safeOp op cheapOp (ParOp _ op) = cheapOp op cheapOp (OtherOp op) = cheapOp op -instance TypedOp op => TypedOp (MCOp rep op) where +instance TypedOp (op rep) => TypedOp (MCOp op rep) where opType (ParOp _ op) = opType op opType (OtherOp op) = opType op -instance - (Aliased rep, AliasedOp op, ASTRep rep) => - AliasedOp (MCOp rep op) - where +instance (Aliased rep, AliasedOp (op rep)) => AliasedOp (MCOp op rep) where opAliases (ParOp _ op) = opAliases op opAliases (OtherOp op) = opAliases op consumedInOp (ParOp _ op) = consumedInOp op consumedInOp (OtherOp op) = consumedInOp op -instance - (CanBeAliased (Op rep), CanBeAliased op, ASTRep rep) => - CanBeAliased (MCOp rep op) - where - type OpWithAliases (MCOp rep op) = MCOp (Aliases rep) (OpWithAliases op) - +instance CanBeAliased op => CanBeAliased (MCOp op) where addOpAliases aliases (ParOp par_op op) = ParOp (addOpAliases aliases <$> par_op) (addOpAliases aliases op) addOpAliases aliases (OtherOp op) = OtherOp $ addOpAliases aliases op - removeOpAliases (ParOp par_op op) = - ParOp (removeOpAliases <$> par_op) (removeOpAliases op) - removeOpAliases (OtherOp op) = - OtherOp $ removeOpAliases op - -instance - (CanBeWise (Op rep), CanBeWise op, ASTRep rep) => - CanBeWise (MCOp rep op) - where - type OpWithWisdom (MCOp rep op) = MCOp (Wise rep) (OpWithWisdom op) - - removeOpWisdom (ParOp par_op op) = - ParOp (removeOpWisdom <$> par_op) (removeOpWisdom op) - removeOpWisdom (OtherOp op) = - OtherOp $ removeOpWisdom op - +instance CanBeWise op => CanBeWise (MCOp op) where addOpWisdom (ParOp par_op op) = ParOp (addOpWisdom <$> par_op) (addOpWisdom op) addOpWisdom (OtherOp op) = OtherOp $ addOpWisdom op -instance (ASTRep rep, ST.IndexOp op) => ST.IndexOp (MCOp rep op) where +instance (ASTRep rep, ST.IndexOp (op rep)) => ST.IndexOp (MCOp op rep) where indexOp vtable k (ParOp _ op) is = ST.indexOp vtable k op is indexOp vtable k (OtherOp op) is = ST.indexOp vtable k op is -instance (PrettyRep rep, Pretty op) => Pretty (MCOp rep op) where +instance (PrettyRep rep, Pretty (op rep)) => Pretty (MCOp op rep) where pretty (ParOp Nothing op) = pretty op pretty (ParOp (Just par_op) op) = "par" @@ -134,14 +114,19 @@ <+> nestedBlock "{" "}" (pretty op) pretty (OtherOp op) = pretty op -instance (OpMetrics (Op rep), OpMetrics op) => OpMetrics (MCOp rep op) where +instance (OpMetrics (Op rep), OpMetrics (op rep)) => OpMetrics (MCOp op rep) where opMetrics (ParOp par_op op) = opMetrics par_op >> opMetrics op opMetrics (OtherOp op) = opMetrics op +instance RephraseOp op => RephraseOp (MCOp op) where + rephraseInOp r (ParOp par_op op) = + ParOp <$> traverse (rephraseInOp r) par_op <*> rephraseInOp r op + rephraseInOp r (OtherOp op) = OtherOp <$> rephraseInOp r op + typeCheckMCOp :: TC.Checkable rep => - (op -> TC.TypeM rep ()) -> - MCOp (Aliases rep) op -> + (op (Aliases rep) -> TC.TypeM rep ()) -> + MCOp op (Aliases rep) -> TC.TypeM rep () typeCheckMCOp _ (ParOp (Just par_op) op) = do -- It is valid for the same array to be consumed in both par_op and op. @@ -155,9 +140,9 @@ ( Engine.SimplifiableRep rep, BodyDec rep ~ () ) => - Simplify.SimplifyOp rep op -> - MCOp (Wise rep) op -> - Engine.SimpleM rep (MCOp (Wise rep) op, Stms (Wise rep)) + Simplify.SimplifyOp rep (op (Wise rep)) -> + MCOp op (Wise rep) -> + Engine.SimpleM rep (MCOp op (Wise rep), Stms (Wise rep)) simplifyMCOp f (OtherOp op) = do (op', stms) <- f op pure (OtherOp op', stms) diff --git a/src/Futhark/IR/MCMem.hs b/src/Futhark/IR/MCMem.hs --- a/src/Futhark/IR/MCMem.hs +++ b/src/Futhark/IR/MCMem.hs @@ -31,30 +31,28 @@ type LParamInfo MCMem = LParamMem type RetType MCMem = RetTypeMem type BranchType MCMem = BranchTypeMem - type Op MCMem = MemOp (MCOp MCMem ()) + type OpC MCMem = MemOp (MCOp NoOp) instance ASTRep MCMem where expTypesFromPat = pure . map snd . bodyReturnsFromPat -instance OpReturns (MCOp MCMem ()) where +instance OpReturns (MCOp NoOp MCMem) where opReturns (ParOp _ op) = segOpReturns op - opReturns (OtherOp ()) = pure [] + opReturns (OtherOp NoOp) = pure [] -instance OpReturns (MCOp (Engine.Wise MCMem) ()) where +instance OpReturns (MCOp NoOp (Engine.Wise MCMem)) where opReturns (ParOp _ op) = segOpReturns op opReturns k = extReturns <$> opType k instance PrettyRep MCMem -instance TC.CheckableOp MCMem where +instance TC.Checkable MCMem where checkOp = typeCheckMemoryOp where typeCheckMemoryOp (Alloc size _) = TC.require [Prim int64] size typeCheckMemoryOp (Inner op) = - typeCheckMCOp pure op - -instance TC.Checkable MCMem where + typeCheckMCOp (const $ pure ()) op checkFParamDec = checkMemInfo checkLParamDec = checkMemInfo checkLetBoundDec = checkMemInfo @@ -68,12 +66,12 @@ instance BuilderOps MCMem where mkExpDecB _ _ = pure () mkBodyB stms res = pure $ Body () stms res - mkLetNamesB = mkLetNamesB' () + mkLetNamesB = mkLetNamesB' DefaultSpace () instance BuilderOps (Engine.Wise MCMem) where mkExpDecB pat e = pure $ Engine.mkWiseExpDec pat () e mkBodyB stms res = pure $ Engine.mkWiseBody () stms res - mkLetNamesB = mkLetNamesB'' + mkLetNamesB = mkLetNamesB'' DefaultSpace instance TraverseOpStms (Engine.Wise MCMem) where traverseOpStms = traverseMemOpStms (traverseMCOpStms (const pure)) @@ -83,4 +81,4 @@ simpleMCMem :: Engine.SimpleOps MCMem simpleMCMem = - simpleGeneric (const mempty) $ simplifyMCOp $ const $ pure ((), mempty) + simpleGeneric (const mempty) $ simplifyMCOp $ const $ pure (NoOp, mempty) 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 @@ -105,6 +105,7 @@ import Control.Monad.State import Data.Foldable (traverse_) import Data.Function ((&)) +import Data.Kind qualified import Data.List (elemIndex, find) import Data.Map.Strict qualified as M import Data.Maybe @@ -115,6 +116,7 @@ import Futhark.Analysis.SymbolTable qualified as ST import Futhark.IR.Aliases ( Aliases, + CanBeAliased (..), removeExpAliases, removePatAliases, removeScopeAliases, @@ -163,8 +165,9 @@ RetType rep ~ RetTypeMem, BranchType rep ~ BranchTypeMem, ASTRep rep, - OpReturns inner, - Op rep ~ MemOp inner + OpReturns (inner rep), + RephraseOp inner, + Op rep ~ MemOp inner rep ) instance IsRetType FunReturns where @@ -174,29 +177,33 @@ instance IsBodyType BodyReturns where primBodyType = MemPrim -data MemOp inner +data MemOp (inner :: Data.Kind.Type -> Data.Kind.Type) (rep :: Data.Kind.Type) = -- | Allocate a memory block. Alloc SubExp Space - | Inner inner + | Inner (inner rep) deriving (Eq, Ord, Show) -- | A helper for defining 'TraverseOpStms'. traverseMemOpStms :: Monad m => - OpStmsTraverser m inner rep -> - OpStmsTraverser m (MemOp inner) rep + OpStmsTraverser m (inner rep) rep -> + OpStmsTraverser m (MemOp inner rep) rep traverseMemOpStms _ _ op@Alloc {} = pure op traverseMemOpStms onInner f (Inner inner) = Inner <$> onInner f inner -instance FreeIn inner => FreeIn (MemOp inner) where +instance RephraseOp inner => RephraseOp (MemOp inner) where + rephraseInOp _ (Alloc e space) = pure (Alloc e space) + rephraseInOp r (Inner x) = Inner <$> rephraseInOp r x + +instance FreeIn (inner rep) => FreeIn (MemOp inner rep) where freeIn' (Alloc size _) = freeIn' size freeIn' (Inner k) = freeIn' k -instance TypedOp inner => TypedOp (MemOp inner) where +instance TypedOp (inner rep) => TypedOp (MemOp inner rep) where opType (Alloc _ space) = pure [Mem space] opType (Inner k) = opType k -instance AliasedOp inner => AliasedOp (MemOp inner) where +instance AliasedOp (inner rep) => AliasedOp (MemOp inner rep) where opAliases Alloc {} = [mempty] opAliases (Inner k) = opAliases k @@ -204,31 +211,27 @@ consumedInOp (Inner k) = consumedInOp k instance CanBeAliased inner => CanBeAliased (MemOp inner) where - type OpWithAliases (MemOp inner) = MemOp (OpWithAliases inner) - removeOpAliases (Alloc se space) = Alloc se space - removeOpAliases (Inner k) = Inner $ removeOpAliases k - addOpAliases _ (Alloc se space) = Alloc se space addOpAliases aliases (Inner k) = Inner $ addOpAliases aliases k -instance Rename inner => Rename (MemOp inner) where +instance Rename (inner rep) => Rename (MemOp inner rep) where rename (Alloc size space) = Alloc <$> rename size <*> pure space rename (Inner k) = Inner <$> rename k -instance Substitute inner => Substitute (MemOp inner) where +instance Substitute (inner rep) => Substitute (MemOp inner rep) where substituteNames subst (Alloc size space) = Alloc (substituteNames subst size) space substituteNames subst (Inner k) = Inner $ substituteNames subst k -instance PP.Pretty inner => PP.Pretty (MemOp inner) where +instance PP.Pretty (inner rep) => PP.Pretty (MemOp inner rep) where pretty (Alloc e DefaultSpace) = "alloc" <> PP.apply [PP.pretty e] pretty (Alloc e s) = "alloc" <> PP.apply [PP.pretty e, PP.pretty s] pretty (Inner k) = PP.pretty k -instance OpMetrics inner => OpMetrics (MemOp inner) where +instance OpMetrics (inner rep) => OpMetrics (MemOp inner rep) where opMetrics Alloc {} = seen "Alloc" opMetrics (Inner k) = opMetrics k -instance IsOp inner => IsOp (MemOp inner) where +instance IsOp (inner rep) => IsOp (MemOp inner rep) where safeOp (Alloc (Constant (IntValue (Int64Value k))) _) = k >= 0 safeOp Alloc {} = False safeOp (Inner k) = safeOp k @@ -236,13 +239,10 @@ cheapOp Alloc {} = True instance CanBeWise inner => CanBeWise (MemOp inner) where - type OpWithWisdom (MemOp inner) = MemOp (OpWithWisdom inner) - removeOpWisdom (Alloc size space) = Alloc size space - removeOpWisdom (Inner k) = Inner $ removeOpWisdom k addOpWisdom (Alloc size space) = Alloc size space addOpWisdom (Inner k) = Inner $ addOpWisdom k -instance ST.IndexOp inner => ST.IndexOp (MemOp inner) where +instance ST.IndexOp (inner rep) => ST.IndexOp (MemOp inner rep) where indexOp vtable k (Inner op) is = ST.indexOp vtable k op is indexOp _ _ _ _ = Nothing @@ -473,7 +473,7 @@ instance PP.Pretty MemReturn where pretty (ReturnsInBlock v ixfun) = - PP.parens $ pretty v <+> "->" PP. PP.pretty ixfun + pretty v <+> "->" PP. PP.pretty ixfun pretty (ReturnsNewBlock space i ixfun) = "?" <> pretty i <> PP.pretty space <+> "->" PP. PP.pretty ixfun @@ -1117,12 +1117,12 @@ opReturns :: (Mem rep inner, Monad m, HasScope rep m) => op -> m [ExpReturns] opReturns op = extReturns <$> opType op -instance OpReturns inner => OpReturns (MemOp inner) where +instance OpReturns (inner rep) => OpReturns (MemOp inner rep) where opReturns (Alloc _ space) = pure [MemMem space] opReturns (Inner op) = opReturns op -instance OpReturns () where - opReturns () = pure [] +instance OpReturns (NoOp rep) where + opReturns NoOp = pure [] applyFunReturns :: Typed dec => 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 @@ -31,18 +31,20 @@ LetDec rep ~ LetDecMem, ExpDec rep ~ (), BodyDec rep ~ (), - CanBeWise (Op rep), + CanBeWise (OpC rep), BuilderOps (Wise rep), - OpReturns (OpWithWisdom inner), - ST.IndexOp (OpWithWisdom inner), - AliasedOp (OpWithWisdom inner), - Mem rep inner + OpReturns (inner (Wise rep)), + ST.IndexOp (inner (Wise rep)), + AliasedOp (inner (Wise rep)), + Mem rep inner, + CanBeWise inner, + RephraseOp inner ) simpleGeneric :: (SimplifyMemory rep inner) => - (OpWithWisdom inner -> UT.UsageTable) -> - Simplify.SimplifyOp rep (OpWithWisdom inner) -> + (inner (Wise rep) -> UT.UsageTable) -> + Simplify.SimplifyOp rep (inner (Wise rep)) -> Simplify.SimpleOps rep simpleGeneric = simplifiable @@ -85,17 +87,17 @@ scope stms -isResultAlloc :: Op rep ~ MemOp op => Engine.BlockPred rep +isResultAlloc :: OpC rep ~ MemOp op => Engine.BlockPred rep isResultAlloc _ usage (Let (Pat [pe]) _ (Op Alloc {})) = UT.isInResult (patElemName pe) usage isResultAlloc _ _ _ = False -isAlloc :: Op rep ~ MemOp op => Engine.BlockPred rep +isAlloc :: OpC rep ~ MemOp op => Engine.BlockPred rep isAlloc _ _ (Let _ _ (Op Alloc {})) = True isAlloc _ _ _ = False blockers :: - (Op rep ~ MemOp inner) => + (OpC rep ~ MemOp inner) => Simplify.HoistBlockers rep blockers = Engine.noExtraHoistBlockers 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 @@ -941,7 +941,7 @@ <$> (lexeme "groups=" $> GPU.Count <*> pSubExp <* pSemi) <*> (lexeme "groupsize=" $> GPU.Count <*> pSubExp) -pHostOp :: PR rep -> Parser op -> Parser (GPU.HostOp rep op) +pHostOp :: PR rep -> Parser (op rep) -> Parser (GPU.HostOp op rep) pHostOp pr pOther = choice [ GPU.SegOp <$> pSegOp pr pSegLevel, @@ -950,7 +950,7 @@ keyword "gpu" $> GPU.GPUBody <*> (pColon *> pTypes) <*> braces (pBody pr) ] -pMCOp :: PR rep -> Parser op -> Parser (MC.MCOp rep op) +pMCOp :: PR rep -> Parser (op rep) -> Parser (MC.MCOp op rep) pMCOp pr pOther = choice [ MC.ParOp . Just @@ -1038,7 +1038,7 @@ pMemReturn :: Parser MemReturn pMemReturn = choice - [ parens $ ReturnsInBlock <$> pVName <* lexeme "->" <*> pExtIxFun, + [ ReturnsInBlock <$> pVName <* lexeme "->" <*> pExtIxFun, do i <- "?" *> pInt space <- choice [pSpace, pure DefaultSpace] <* lexeme "->" @@ -1060,7 +1060,7 @@ pLetDecMem :: Parser LetDecMem pLetDecMem = pMemInfo pSubExp (pure NoUniqueness) pMemBind -pMemOp :: Parser inner -> Parser (MemOp inner) +pMemOp :: Parser (inner rep) -> Parser (MemOp inner rep) pMemOp pInner = choice [ keyword "alloc" 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Futhark prettyprinter. This module defines 'Pretty' instances @@ -33,6 +32,9 @@ where ppExpDec :: ExpDec rep -> Exp rep -> Maybe (Doc a) ppExpDec _ _ = Nothing + +instance Pretty (NoOp rep) where + pretty NoOp = "noop" instance Pretty VName where pretty (VName vn i) = pretty vn <> "_" <> pretty (show i) 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 @@ -13,6 +13,7 @@ module Futhark.IR.Prop.Patterns, module Futhark.IR.Prop.Names, module Futhark.IR.RetType, + module Futhark.IR.Rephrase, -- * Built-in functions isBuiltInFunction, @@ -49,6 +50,7 @@ import Futhark.IR.Prop.Reshape import Futhark.IR.Prop.TypeOf import Futhark.IR.Prop.Types +import Futhark.IR.Rephrase import Futhark.IR.RetType import Futhark.IR.Syntax import Futhark.Transform.Rename (Rename, Renameable) @@ -177,7 +179,7 @@ certify cs1 (Let pat (StmAux cs2 attrs dec) e) = Let pat (StmAux (cs2 <> cs1) attrs dec) e --- | A handy shorthand for properties that we usually want to things +-- | A handy shorthand for properties that we usually want for things -- we stuff into ASTs. type ASTConstraints a = (Eq a, Ord a, Show a, Rename a, Substitute a, FreeIn a, Pretty a) @@ -190,9 +192,9 @@ -- | Should we try to hoist this out of branches? cheapOp :: op -> Bool -instance IsOp () where - safeOp () = True - cheapOp () = True +instance IsOp (NoOp rep) where + safeOp NoOp = True + cheapOp NoOp = True -- | Representation-specific attributes; also means the rep supports -- some basic facilities. @@ -208,7 +210,8 @@ FreeIn (LParamInfo rep), FreeIn (RetType rep), FreeIn (BranchType rep), - IsOp (Op rep) + IsOp (Op rep), + RephraseOp (OpC rep) ) => ASTRep rep where diff --git a/src/Futhark/IR/Prop/Aliases.hs b/src/Futhark/IR/Prop/Aliases.hs --- a/src/Futhark/IR/Prop/Aliases.hs +++ b/src/Futhark/IR/Prop/Aliases.hs @@ -25,23 +25,22 @@ -- * Extensibility AliasTable, AliasedOp (..), - CanBeAliased (..), ) where import Data.Bifunctor (first, second) -import Data.Kind qualified import Data.List (find, transpose) import Data.Map qualified as M -import Futhark.IR.Prop (IsOp, NameInfo (..), Scope) +import Futhark.IR.Prop (ASTRep, IsOp, NameInfo (..), Scope) import Futhark.IR.Prop.Names import Futhark.IR.Prop.Patterns import Futhark.IR.Prop.Types import Futhark.IR.Syntax -- | The class of representations that contain aliasing information. -class (RepTypes rep, AliasedOp (Op rep), AliasesOf (LetDec rep)) => Aliased rep where - -- | The aliases of the body results. +class (ASTRep rep, AliasedOp (Op rep), AliasesOf (LetDec rep)) => Aliased rep where + -- | The aliases of the body results. Note that this includes names + -- bound in the body! bodyAliases :: Body rep -> [Names] -- | The variables consumed in the body. @@ -85,25 +84,56 @@ where (alses, conses) = unzip l +returnAliases :: [TypeBase shape Uniqueness] -> [(Names, Diet)] -> [Names] +returnAliases rts args = map returnType' rts + where + returnType' (Array _ _ Nonunique) = + mconcat $ map (uncurry maskAliases) args + returnType' (Array _ _ Unique) = + mempty + returnType' (Prim _) = + mempty + returnType' Acc {} = + error "returnAliases Acc" + returnType' Mem {} = + mconcat $ map (uncurry maskAliases) args + funcallAliases :: [(SubExp, Diet)] -> [TypeBase shape Uniqueness] -> [Names] funcallAliases args t = returnAliases t [(subExpAliases se, d) | (se, d) <- args] --- | The aliases of an expression, one per non-context value returned. -expAliases :: (Aliased rep) => Exp rep -> [Names] -expAliases (Match _ cases defbody _) = - matchAliases $ onBody defbody : map (onBody . caseBody) cases +-- | The aliases of an expression, one for each pattern element. +-- +-- The pattern is important because some aliasing might be through +-- variables that are no longer in scope (consider the aliases for a +-- body that returns the same value multiple times). +expAliases :: (Aliased rep) => [PatElem dec] -> Exp rep -> [Names] +expAliases pes (Match _ cases defbody _) = + -- Repeat mempty in case the pattern has more elements (this + -- implies a type error). + zipWith grow (map patElemName pes) $ als ++ repeat mempty where + als = matchAliases $ onBody defbody : map (onBody . caseBody) cases onBody body = (bodyAliases body, consumedInBody body) -expAliases (BasicOp op) = basicOpAliases op -expAliases (DoLoop merge _ loopbody) = do + bound = foldMap boundInBody $ defbody : map caseBody cases + grow v names = (names <> pe_names) `namesSubtract` bound + where + pe_names = + namesFromList + . filter (/= v) + . map (patElemName . fst) + . filter (namesIntersect names . snd) + $ zip pes als +expAliases _ (BasicOp op) = basicOpAliases op +expAliases _ (DoLoop merge _ loopbody) = do (p, als) <- transitive . zip params $ zipWith mappend arg_aliases (bodyAliases loopbody) let als' = als `namesSubtract` param_names if unique $ paramDeclType p then pure mempty - else pure als' + else pure $ als' `namesSubtract` bound where + bound = boundInBody loopbody arg_aliases = map (subExpAliases . snd) merge params = map fst merge param_names = namesFromList $ map paramName params @@ -115,28 +145,16 @@ where look v = maybe mempty snd $ find ((== v) . paramName . fst) merge_and_als expand als = als <> foldMap look (namesToList als) -expAliases (Apply _ args t _) = +expAliases _ (Apply _ args t _) = funcallAliases args $ map declExtTypeOf t -expAliases (WithAcc inputs lam) = - concatMap inputAliases inputs ++ drop num_accs (bodyAliases (lambdaBody lam)) +expAliases _ (WithAcc inputs lam) = + concatMap inputAliases inputs + ++ drop num_accs (map (`namesSubtract` boundInBody body) $ bodyAliases body) where + body = lambdaBody lam inputAliases (_, arrs, _) = replicate (length arrs) mempty num_accs = length inputs -expAliases (Op op) = opAliases op - -returnAliases :: [TypeBase shape Uniqueness] -> [(Names, Diet)] -> [Names] -returnAliases rts args = map returnType' rts - where - returnType' (Array _ _ Nonunique) = - mconcat $ map (uncurry maskAliases) args - returnType' (Array _ _ Unique) = - mempty - returnType' (Prim _) = - mempty - returnType' Acc {} = - error "returnAliases Acc" - returnType' Mem {} = - mconcat $ map (uncurry maskAliases) args +expAliases _ (Op op) = opAliases op maskAliases :: Names -> Diet -> Names maskAliases _ Consume = mempty @@ -186,9 +204,9 @@ consumedByLambda :: Aliased rep => Lambda rep -> Names consumedByLambda = consumedInBody . lambdaBody --- | The aliases of each pattern element (including the context). +-- | The aliases of each pattern element. patAliases :: AliasesOf dec => Pat dec -> [Names] -patAliases = map (aliasesOf . patElemDec) . patElems +patAliases = map aliasesOf . patElems -- | Something that contains alias information. class AliasesOf a where @@ -215,28 +233,10 @@ opAliases :: op -> [Names] consumedInOp :: op -> Names -instance AliasedOp () where - opAliases () = [] - consumedInOp () = mempty +instance AliasedOp (NoOp rep) where + opAliases NoOp = [] + consumedInOp NoOp = mempty -- | Pre-existing aliases for variables. Used to add transitive -- aliases. type AliasTable = M.Map VName Names - --- | The class of operations that can be given aliasing information. --- This is a somewhat subtle concept that is only used in the --- simplifier and when using "rep adapters". -class AliasedOp (OpWithAliases op) => CanBeAliased op where - -- | The op that results when we add aliases to this op. - type OpWithAliases op :: Data.Kind.Type - - -- | Remove aliases from this op. - removeOpAliases :: OpWithAliases op -> op - - -- | Add aliases to this op. - addOpAliases :: AliasTable -> op -> OpWithAliases op - -instance CanBeAliased () where - type OpWithAliases () = () - removeOpAliases = id - addOpAliases = const id 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 @@ -222,6 +222,9 @@ instance FreeIn a => FreeIn (S.Set a) where freeIn' = foldMap freeIn' +instance FreeIn (NoOp rep) where + freeIn' NoOp = mempty + instance ( FreeDec (ExpDec rep), FreeDec (BodyDec rep), diff --git a/src/Futhark/IR/Prop/TypeOf.hs b/src/Futhark/IR/Prop/TypeOf.hs --- a/src/Futhark/IR/Prop/TypeOf.hs +++ b/src/Futhark/IR/Prop/TypeOf.hs @@ -15,7 +15,6 @@ -- also obtaining information about the storage location of results. module Futhark.IR.Prop.TypeOf ( expExtType, - expExtTypeSize, subExpType, subExpResType, basicOpType, @@ -145,27 +144,6 @@ num_accs = length inputs expExtType (Op op) = opType op --- | The number of values returned by an expression. -expExtTypeSize :: - (RepTypes rep, TypedOp (Op rep)) => - Exp rep -> - Int -expExtTypeSize = length . feelBad . expExtType - --- FIXME, this is a horrible quick hack. -newtype FeelBad rep a = FeelBad {feelBad :: a} - -instance Functor (FeelBad rep) where - fmap f = FeelBad . f . feelBad - -instance Applicative (FeelBad rep) where - pure = FeelBad - f <*> x = FeelBad $ feelBad f $ feelBad x - -instance RepTypes rep => HasScope rep (FeelBad rep) where - lookupType = const $ pure $ Prim $ IntType Int64 - askScope = pure mempty - -- | Given the parameters of a loop, produce the return type. loopExtType :: Typed dec => [Param dec] -> [ExtType] loopExtType params = @@ -178,5 +156,5 @@ class TypedOp op where opType :: HasScope t m => op -> m [ExtType] -instance TypedOp () where - opType () = pure [] +instance TypedOp (NoOp rep) where + opType NoOp = pure [] 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 @@ -4,6 +4,8 @@ -- which is then used to invoke the type families defined here. module Futhark.IR.Rep ( RepTypes (..), + Op, + NoOp (..), module Futhark.IR.RetType, ) where @@ -13,6 +15,11 @@ import Futhark.IR.RetType import Futhark.IR.Syntax.Core (DeclExtType, DeclType, ExtType, Type) +-- | Returns nothing and does nothing. Placeholder for when we don't +-- really want an operation. +data NoOp rep = NoOp + deriving (Eq, Ord, Show) + -- | A collection of type families giving various common types for a -- representation, along with constraints specifying that the types -- they map to should satisfy some minimal requirements. @@ -85,7 +92,14 @@ type BranchType l = ExtType - -- | Extensible operation. - type Op l :: Data.Kind.Type + -- | Type constructor for the extensible operation. The somewhat + -- funky definition is to ensure that we can change the "inner" + -- representation in a generic way (e.g. add aliasing information) + -- In most code, you will use the 'Op' alias instead. + type OpC l :: Data.Kind.Type -> Data.Kind.Type - type Op l = () + type OpC l = NoOp + +-- | Apply the 'OpC' constructor of a representation to that +-- representation. +type Op l = OpC l l diff --git a/src/Futhark/IR/Rephrase.hs b/src/Futhark/IR/Rephrase.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Rephrase.hs @@ -0,0 +1,114 @@ +-- | Facilities for changing the representation of some fragment, +-- within a monadic context. We call this "rephrasing", for no deep +-- reason. +module Futhark.IR.Rephrase + ( rephraseProg, + rephraseFunDef, + rephraseExp, + rephraseBody, + rephraseStm, + rephraseLambda, + rephrasePat, + rephrasePatElem, + Rephraser (..), + RephraseOp (..), + ) +where + +import Futhark.IR.Syntax +import Futhark.IR.Traversals + +-- | A collection of functions that together allow us to rephrase some +-- IR fragment, in some monad @m@. If we let @m@ be the 'Maybe' +-- monad, we can conveniently do rephrasing that might fail. This is +-- useful if you want to see if some IR in e.g. the @Kernels@ rep +-- actually uses any @Kernels@-specific operations. +data Rephraser m from to = Rephraser + { rephraseExpDec :: ExpDec from -> m (ExpDec to), + rephraseLetBoundDec :: LetDec from -> m (LetDec to), + rephraseFParamDec :: FParamInfo from -> m (FParamInfo to), + rephraseLParamDec :: LParamInfo from -> m (LParamInfo to), + rephraseBodyDec :: BodyDec from -> m (BodyDec to), + rephraseRetType :: RetType from -> m (RetType to), + rephraseBranchType :: BranchType from -> m (BranchType to), + rephraseOp :: Op from -> m (Op to) + } + +-- | Rephrase an entire program. +rephraseProg :: Monad m => Rephraser m from to -> Prog from -> m (Prog to) +rephraseProg rephraser prog = do + consts <- mapM (rephraseStm rephraser) (progConsts prog) + funs <- mapM (rephraseFunDef rephraser) (progFuns prog) + pure $ prog {progConsts = consts, progFuns = funs} + +-- | Rephrase a function definition. +rephraseFunDef :: Monad m => Rephraser m from to -> FunDef from -> m (FunDef to) +rephraseFunDef rephraser fundec = do + body' <- rephraseBody rephraser $ funDefBody fundec + params' <- mapM (rephraseParam $ rephraseFParamDec rephraser) $ funDefParams fundec + rettype' <- mapM (rephraseRetType rephraser) $ funDefRetType fundec + pure fundec {funDefBody = body', funDefParams = params', funDefRetType = rettype'} + +-- | Rephrase an expression. +rephraseExp :: Monad m => Rephraser m from to -> Exp from -> m (Exp to) +rephraseExp = mapExpM . mapper + +-- | Rephrase a statement. +rephraseStm :: Monad m => Rephraser m from to -> Stm from -> m (Stm to) +rephraseStm rephraser (Let pat (StmAux cs attrs dec) e) = + Let + <$> rephrasePat (rephraseLetBoundDec rephraser) pat + <*> (StmAux cs attrs <$> rephraseExpDec rephraser dec) + <*> rephraseExp rephraser e + +-- | Rephrase a pattern. +rephrasePat :: + Monad m => + (from -> m to) -> + Pat from -> + m (Pat to) +rephrasePat = traverse + +-- | Rephrase a pattern element. +rephrasePatElem :: Monad m => (from -> m to) -> PatElem from -> m (PatElem to) +rephrasePatElem rephraser (PatElem ident from) = + PatElem ident <$> rephraser from + +-- | Rephrase a parameter. +rephraseParam :: Monad m => (from -> m to) -> Param from -> m (Param to) +rephraseParam rephraser (Param attrs name from) = + Param attrs name <$> rephraser from + +-- | Rephrase a body. +rephraseBody :: Monad m => Rephraser m from to -> Body from -> m (Body to) +rephraseBody rephraser (Body rep stms res) = + Body + <$> rephraseBodyDec rephraser rep + <*> (stmsFromList <$> mapM (rephraseStm rephraser) (stmsToList stms)) + <*> pure res + +-- | Rephrase a lambda. +rephraseLambda :: Monad m => Rephraser m from to -> Lambda from -> m (Lambda to) +rephraseLambda rephraser lam = do + body' <- rephraseBody rephraser $ lambdaBody lam + params' <- mapM (rephraseParam $ rephraseLParamDec rephraser) $ lambdaParams lam + pure lam {lambdaBody = body', lambdaParams = params'} + +mapper :: Monad m => Rephraser m from to -> Mapper from to m +mapper rephraser = + identityMapper + { mapOnBody = const $ rephraseBody rephraser, + mapOnRetType = rephraseRetType rephraser, + mapOnBranchType = rephraseBranchType rephraser, + mapOnFParam = rephraseParam (rephraseFParamDec rephraser), + mapOnLParam = rephraseParam (rephraseLParamDec rephraser), + mapOnOp = rephraseOp rephraser + } + +-- | Rephrasing any fragments inside an Op from one representation to +-- another. +class RephraseOp op where + rephraseInOp :: Monad m => Rephraser m from to -> op from -> m (op to) + +instance RephraseOp NoOp where + rephraseInOp _ NoOp = pure NoOp diff --git a/src/Futhark/IR/SOACS.hs b/src/Futhark/IR/SOACS.hs --- a/src/Futhark/IR/SOACS.hs +++ b/src/Futhark/IR/SOACS.hs @@ -27,15 +27,13 @@ data SOACS instance RepTypes SOACS where - type Op SOACS = SOAC SOACS + type OpC SOACS = SOAC instance ASTRep SOACS where expTypesFromPat = pure . expExtTypesFromPat -instance TC.CheckableOp SOACS where +instance TC.Checkable SOACS where checkOp = typeCheckSOAC - -instance TC.Checkable SOACS instance Buildable SOACS where mkBody = Body () 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 @@ -62,7 +62,7 @@ import Futhark.Analysis.SymbolTable qualified as ST import Futhark.Construct import Futhark.IR -import Futhark.IR.Aliases (Aliases, removeLambdaAliases) +import Futhark.IR.Aliases (Aliases, CanBeAliased (..)) import Futhark.IR.Prop.Aliases import Futhark.IR.TypeCheck qualified as TC import Futhark.Optimise.Simplify.Rep @@ -529,7 +529,7 @@ instance ASTRep rep => TypedOp (SOAC rep) where opType = pure . staticShapes . soacType -instance (ASTRep rep, Aliased rep) => AliasedOp (SOAC rep) where +instance Aliased rep => AliasedOp (SOAC rep) where opAliases = map (const mempty) . soacType consumedInOp JVP {} = mempty @@ -560,15 +560,7 @@ mapHistOp f (HistOp w rf dests nes lam) = HistOp w rf dests nes $ f lam -instance - ( ASTRep rep, - ASTRep (Aliases rep), - CanBeAliased (Op rep) - ) => - CanBeAliased (SOAC rep) - where - type OpWithAliases (SOAC rep) = SOAC (Aliases rep) - +instance CanBeAliased SOAC where addOpAliases aliases (JVP lam args vec) = JVP (Alias.analyseLambda aliases lam) args vec addOpAliases aliases (VJP lam args vec) = @@ -593,10 +585,6 @@ onRed red = red {redLambda = Alias.analyseLambda aliases $ redLambda red} onScan scan = scan {scanLambda = Alias.analyseLambda aliases $ scanLambda scan} - removeOpAliases = runIdentity . mapSOACM remove - where - remove = SOACMapper pure (pure . removeLambdaAliases) pure - instance ASTRep rep => IsOp (SOAC rep) where safeOp _ = False cheapOp _ = False @@ -614,10 +602,7 @@ substNamesInSubExp subs (Var idd) = M.findWithDefault (Var idd) idd subs -instance (ASTRep rep, CanBeWise (Op rep)) => CanBeWise (SOAC rep) where - type OpWithWisdom (SOAC rep) = SOAC (Wise rep) - - removeOpWisdom = runIdentity . mapSOACM (SOACMapper pure (pure . removeLambdaWisdom) pure) +instance CanBeWise SOAC where addOpWisdom = runIdentity . mapSOACM (SOACMapper pure (pure . informLambda) pure) instance RepTypes rep => ST.IndexOp (SOAC rep) where @@ -836,6 +821,31 @@ $ "Map function return type " <> prettyTuple map_lam_ts <> " wrong for given scan and reduction functions." + +instance RephraseOp SOAC where + rephraseInOp r (VJP lam args vec) = + VJP <$> rephraseLambda r lam <*> pure args <*> pure vec + rephraseInOp r (JVP lam args vec) = + JVP <$> rephraseLambda r lam <*> pure args <*> pure vec + rephraseInOp r (Stream w arrs acc lam) = + Stream w arrs acc <$> rephraseLambda r lam + rephraseInOp r (Scatter w arrs lam dests) = + Scatter w arrs <$> rephraseLambda r lam <*> pure dests + rephraseInOp r (Hist w arrs ops lam) = + Hist w arrs <$> mapM onOp ops <*> rephraseLambda r lam + where + onOp (HistOp dest_shape rf dests nes op) = + HistOp dest_shape rf dests nes <$> rephraseLambda r op + rephraseInOp r (Screma w arrs (ScremaForm scans red lam)) = + Screma w arrs + <$> ( ScremaForm + <$> mapM onScan scans + <*> mapM onRed red + <*> rephraseLambda r lam + ) + where + onScan (Scan op nes) = Scan <$> rephraseLambda r op <*> pure nes + onRed (Reduce comm op nes) = Reduce comm <$> rephraseLambda r op <*> pure nes instance OpMetrics (Op rep) => OpMetrics (SOAC rep) where opMetrics (VJP lam _ _) = 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 @@ -71,8 +71,7 @@ import Futhark.IR import Futhark.IR.Aliases ( Aliases, - removeLambdaAliases, - removeStmAliases, + CanBeAliased (..), ) import Futhark.IR.Mem import Futhark.IR.Prop.Aliases @@ -280,9 +279,7 @@ -- | Perform alias analysis on a 'KernelBody'. aliasAnalyseKernelBody :: - ( ASTRep rep, - CanBeAliased (Op rep) - ) => + Alias.AliasableRep rep => AliasTable -> KernelBody rep -> KernelBody (Aliases rep) @@ -290,21 +287,6 @@ let Body dec' stms' _ = Alias.analyseBody aliases $ Body dec stms [] in KernelBody dec' stms' res -removeKernelBodyAliases :: - CanBeAliased (Op rep) => - KernelBody (Aliases rep) -> - KernelBody rep -removeKernelBodyAliases (KernelBody (_, dec) stms res) = - KernelBody dec (fmap removeStmAliases stms) res - -removeKernelBodyWisdom :: - CanBeWise (Op rep) => - KernelBody (Wise rep) -> - KernelBody rep -removeKernelBodyWisdom (KernelBody dec stms res) = - let Body dec' stms' _ = removeBodyWisdom $ Body dec stms [] - in KernelBody dec' stms' res - -- | The variables consumed in the kernel body. consumedInKernelBody :: Aliased rep => @@ -549,10 +531,7 @@ instance TypedOp (SegOp lvl rep) where opType = pure . staticShapes . segOpType -instance - (ASTRep rep, Aliased rep, ASTConstraints lvl) => - AliasedOp (SegOp lvl rep) - where +instance (ASTConstraints lvl, Aliased rep) => AliasedOp (SegOp lvl rep) where opAliases = map (const mempty) . segOpType consumedInOp (SegMap _ _ _ kbody) = @@ -776,6 +755,44 @@ Array et <$> traverse (mapOnSegOpSubExp tv) shape <*> pure u mapOnSegOpType _tv (Mem s) = pure $ Mem s +rephraseBinOp :: + Monad f => + Rephraser f from rep -> + SegBinOp from -> + f (SegBinOp rep) +rephraseBinOp r (SegBinOp comm lam nes shape) = + SegBinOp comm <$> rephraseLambda r lam <*> pure nes <*> pure shape + +rephraseKernelBody :: + Monad f => + Rephraser f from rep -> + KernelBody from -> + f (KernelBody rep) +rephraseKernelBody r (KernelBody dec stms res) = + KernelBody <$> rephraseBodyDec r dec <*> traverse (rephraseStm r) stms <*> pure res + +instance RephraseOp (SegOp lvl) where + rephraseInOp r (SegMap lvl space ts body) = + SegMap lvl space ts <$> rephraseKernelBody r body + rephraseInOp r (SegRed lvl space reds ts body) = + SegRed lvl space + <$> mapM (rephraseBinOp r) reds + <*> pure ts + <*> rephraseKernelBody r body + rephraseInOp r (SegScan lvl space scans ts body) = + SegScan lvl space + <$> mapM (rephraseBinOp r) scans + <*> pure ts + <*> rephraseKernelBody r body + rephraseInOp r (SegHist lvl space hists ts body) = + SegHist lvl space + <$> mapM onOp hists + <*> pure ts + <*> rephraseKernelBody r body + where + onOp (HistOp w rf arrs nes shape op) = + HistOp w rf arrs nes shape <$> rephraseLambda r op + -- | A helper for defining 'TraverseOpStms'. traverseSegOpStms :: Monad m => OpStmsTraverser m (SegOp lvl rep) rep traverseSegOpStms f segop = mapSegOpM mapper segop @@ -899,16 +916,7 @@ pretty shape <> PP.comma pretty op -instance - ( ASTRep rep, - ASTRep (Aliases rep), - CanBeAliased (Op rep), - ASTConstraints lvl - ) => - CanBeAliased (SegOp lvl rep) - where - type OpWithAliases (SegOp lvl rep) = SegOp lvl (Aliases rep) - +instance CanBeAliased (SegOp lvl) where addOpAliases aliases = runIdentity . mapSegOpM alias where alias = @@ -919,36 +927,11 @@ pure pure - removeOpAliases = runIdentity . mapSegOpM remove - where - remove = - SegOpMapper - pure - (pure . removeLambdaAliases) - (pure . removeKernelBodyAliases) - pure - pure - informKernelBody :: Informing rep => KernelBody rep -> KernelBody (Wise rep) informKernelBody (KernelBody dec stms res) = mkWiseKernelBody dec (informStms stms) res -instance - (CanBeWise (Op rep), ASTRep rep, ASTConstraints lvl) => - CanBeWise (SegOp lvl rep) - where - type OpWithWisdom (SegOp lvl rep) = SegOp lvl (Wise rep) - - removeOpWisdom = runIdentity . mapSegOpM remove - where - remove = - SegOpMapper - pure - (pure . removeLambdaWisdom) - (pure . removeKernelBodyWisdom) - pure - pure - +instance CanBeWise (SegOp lvl) where addOpWisdom = runIdentity . mapSegOpM add where add = @@ -1034,7 +1017,7 @@ <*> Engine.simplify what mkWiseKernelBody :: - (ASTRep rep, CanBeWise (Op rep)) => + Informing rep => BodyDec rep -> Stms (Wise rep) -> [KernelResult] -> diff --git a/src/Futhark/IR/Seq.hs b/src/Futhark/IR/Seq.hs --- a/src/Futhark/IR/Seq.hs +++ b/src/Futhark/IR/Seq.hs @@ -30,16 +30,13 @@ -- | The phantom type for the Seq representation. data Seq -instance RepTypes Seq where - type Op Seq = () +instance RepTypes Seq instance ASTRep Seq where expTypesFromPat = pure . expExtTypesFromPat -instance TC.CheckableOp Seq where - checkOp = pure - -instance TC.Checkable Seq +instance TC.Checkable Seq where + checkOp NoOp = pure () instance Buildable Seq where mkBody = Body () @@ -60,7 +57,7 @@ traverseOpStms _ = pure simpleSeq :: Simplify.SimpleOps Seq -simpleSeq = Simplify.bindableSimpleOps (const $ pure ((), mempty)) +simpleSeq = Simplify.bindableSimpleOps (const $ pure (NoOp, mempty)) -- | Simplify a sequential program. simplifyProg :: Prog Seq -> PassM (Prog Seq) diff --git a/src/Futhark/IR/SeqMem.hs b/src/Futhark/IR/SeqMem.hs --- a/src/Futhark/IR/SeqMem.hs +++ b/src/Futhark/IR/SeqMem.hs @@ -28,20 +28,16 @@ type LParamInfo SeqMem = LParamMem type RetType SeqMem = RetTypeMem type BranchType SeqMem = BranchTypeMem - type Op SeqMem = MemOp () + type OpC SeqMem = MemOp NoOp instance ASTRep SeqMem where expTypesFromPat = pure . map snd . bodyReturnsFromPat instance PrettyRep SeqMem -instance TC.CheckableOp SeqMem where - checkOp (Alloc size _) = - TC.require [Prim int64] size - checkOp (Inner ()) = - pure () - instance TC.Checkable SeqMem where + checkOp (Alloc size _) = TC.require [Prim int64] size + checkOp (Inner NoOp) = pure () checkFParamDec = checkMemInfo checkLParamDec = checkMemInfo checkLetBoundDec = checkMemInfo @@ -55,7 +51,7 @@ instance BuilderOps SeqMem where mkExpDecB _ _ = pure () mkBodyB stms res = pure $ Body () stms res - mkLetNamesB = mkLetNamesB' () + mkLetNamesB = mkLetNamesB' DefaultSpace () instance TraverseOpStms SeqMem where traverseOpStms _ = pure @@ -63,7 +59,7 @@ instance BuilderOps (Engine.Wise SeqMem) where mkExpDecB pat e = pure $ Engine.mkWiseExpDec pat () e mkBodyB stms res = pure $ Engine.mkWiseBody () stms res - mkLetNamesB = mkLetNamesB'' + mkLetNamesB = mkLetNamesB'' DefaultSpace instance TraverseOpStms (Engine.Wise SeqMem) where traverseOpStms _ = pure @@ -73,4 +69,4 @@ simpleSeqMem :: Engine.SimpleOps SeqMem simpleSeqMem = - simpleGeneric (const mempty) $ const $ pure ((), mempty) + simpleGeneric (const mempty) $ const $ pure (NoOp, mempty) 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 @@ -306,9 +306,9 @@ -- | Which kind of reshape is this? data ReshapeKind - = -- | Any kind of reshaping. + = -- | New shape is dynamically same as original. ReshapeCoerce - | -- | New shape is dynamically same as original. + | -- | Any kind of reshaping. ReshapeArbitrary deriving (Eq, Ord, Show) 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 @@ -1,5 +1,4 @@ {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE Strict #-} {-# LANGUAGE TypeFamilies #-} -- | The type checker checks whether the program is type-consistent. @@ -14,7 +13,6 @@ bad, context, Checkable (..), - CheckableOp (..), lookupVar, lookupAliases, checkOpWith, @@ -53,6 +51,7 @@ import Data.Maybe import Data.Set qualified as S import Data.Text qualified as T +import Futhark.Analysis.Alias import Futhark.Analysis.PrimExp import Futhark.Construct (instantiateShapes) import Futhark.IR.Aliases hiding (lookupAliases) @@ -276,7 +275,7 @@ data Env rep = Env { envVtable :: M.Map VName (VarBinding rep), envFtable :: M.Map Name (FunBinding rep), - envCheckOp :: OpWithAliases (Op rep) -> TypeM rep (), + envCheckOp :: Op (Aliases rep) -> TypeM rep (), envContext :: [T.Text] } @@ -375,7 +374,7 @@ pure (x, o) checkOpWith :: - (OpWithAliases (Op rep) -> TypeM rep ()) -> + (Op (Aliases rep) -> TypeM rep ()) -> TypeM rep a -> TypeM rep a checkOpWith checker = local $ \env -> env {envCheckOp = checker} @@ -1485,12 +1484,8 @@ unless (primExpType e == t) . bad . TypeError $ prettyText e <> " must have type " <> prettyText t -class ASTRep rep => CheckableOp rep where - checkOp :: OpWithAliases (Op rep) -> TypeM rep () - -- ^ Used at top level; can be locally changed with 'checkOpWith'. - -- | The class of representations that can be type-checked. -class (ASTRep rep, CanBeAliased (Op rep), CheckableOp rep) => Checkable rep where +class (AliasableRep rep, TypedOp (OpC rep (Aliases rep))) => Checkable rep where checkExpDec :: ExpDec rep -> TypeM rep () checkBodyDec :: BodyDec rep -> TypeM rep () checkFParamDec :: VName -> FParamInfo rep -> TypeM rep () @@ -1502,6 +1497,9 @@ matchReturnType :: [RetType rep] -> Result -> TypeM rep () matchBranchType :: [BranchType rep] -> Body (Aliases rep) -> TypeM rep () matchLoopResult :: [FParam (Aliases rep)] -> Result -> TypeM rep () + + -- | Used at top level; can be locally changed with 'checkOpWith'. + checkOp :: Op (Aliases rep) -> TypeM rep () default checkExpDec :: ExpDec rep ~ () => ExpDec rep -> TypeM rep () checkExpDec = pure 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 @@ -632,13 +632,14 @@ (e1', _) <- defuncExp e1 (e2', sv) <- defuncExp e2 pure (Assert e1' e2' desc loc, sv) -defuncExp (Constr name es (Info (Scalar (Sum all_fs))) loc) = do +defuncExp (Constr name es (Info sum_t@(Scalar (Sum all_fs))) loc) = do (es', svs) <- unzip <$> mapM defuncExp es let sv = SumSV name svs $ M.toList $ name `M.delete` M.map (map defuncType) all_fs - pure (Constr name es' (Info (typeFromSV sv)) loc, sv) + sum_t' = combineTypeShapes sum_t (typeFromSV sv) + pure (Constr name es' (Info sum_t') loc, sv) where defuncType :: Monoid als => diff --git a/src/Futhark/Optimise/ArrayShortCircuiting.hs b/src/Futhark/Optimise/ArrayShortCircuiting.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting.hs @@ -46,15 +46,12 @@ replaceInParams :: CoalsTab -> [Param FParamMem] -> (Names, [Param FParamMem]) replaceInParams coalstab fparams = let (mem_allocs_to_remove, fparams') = - foldl - replaceInParam - (mempty, mempty) - fparams + foldl replaceInParam (mempty, mempty) fparams in (mem_allocs_to_remove, reverse fparams') where replaceInParam (to_remove, acc) (Param attrs name dec) = case dec of - MemMem DefaultSpace + MemMem _ | Just entry <- M.lookup name coalstab -> (oneName (dstmem entry) <> to_remove, Param attrs (dstmem entry) dec : acc) MemArray pt shp u (ArrayIn m ixf) @@ -71,11 +68,11 @@ & pure pass :: - (Mem rep inner, LetDec rep ~ LetDecMem, CanBeAliased inner) => + (Mem rep inner, LetDec rep ~ LetDecMem, AliasableRep rep) => String -> String -> (Prog (Aliases rep) -> Pass.PassM (M.Map Name CoalsTab)) -> - (inner -> UpdateM inner inner) -> + (inner rep -> UpdateM (inner rep) (inner rep)) -> (CoalsTab -> [FParam (Aliases rep)] -> (Names, [FParam (Aliases rep)])) -> Pass rep rep pass flag desc mk on_inner on_fparams = @@ -107,12 +104,18 @@ Just entry -> res {resSubExp = Var $ dstmem entry} Nothing -> res -updateStms :: (Mem rep inner, LetDec rep ~ LetDecMem) => Stms rep -> UpdateM inner (Stms rep) +updateStms :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + Stms rep -> + UpdateM (inner rep) (Stms rep) updateStms stms = do stms' <- mapM replaceInStm stms removeAllocsInStms stms' -replaceInStm :: (Mem rep inner, LetDec rep ~ LetDecMem) => Stm rep -> UpdateM inner (Stm rep) +replaceInStm :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + Stm rep -> + UpdateM (inner rep) (Stm rep) replaceInStm (Let (Pat elems) d e) = do elems' <- mapM replaceInPatElem elems e' <- replaceInExp elems' e @@ -123,7 +126,11 @@ fromMaybe p <$> lookupAndReplace vname PatElem u replaceInPatElem p = pure p -replaceInExp :: (Mem rep inner, LetDec rep ~ LetDecMem) => [PatElem LetDecMem] -> Exp rep -> UpdateM inner (Exp rep) +replaceInExp :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + [PatElem LetDecMem] -> + Exp rep -> + UpdateM (inner rep) (Exp rep) replaceInExp _ e@(BasicOp _) = pure e replaceInExp pat_elems (Match cond_ses cases defbody dec) = do defbody' <- replaceInIfBody defbody @@ -149,7 +156,7 @@ replaceInSegOp :: (Mem rep inner, LetDec rep ~ LetDecMem) => SegOp lvl rep -> - UpdateM inner (SegOp lvl rep) + UpdateM (inner rep) (SegOp lvl rep) replaceInSegOp (SegMap lvl sp tps body) = do stms <- updateStms $ kernelBodyStms body pure $ SegMap lvl sp tps $ body {kernelBodyStms = stms} @@ -163,11 +170,11 @@ stms <- updateStms $ kernelBodyStms body pure $ SegHist lvl sp hist_ops tps $ body {kernelBodyStms = stms} -replaceInHostOp :: HostOp GPUMem () -> UpdateM (HostOp GPUMem ()) (HostOp GPUMem ()) +replaceInHostOp :: HostOp NoOp GPUMem -> UpdateM (HostOp NoOp GPUMem) (HostOp NoOp GPUMem) replaceInHostOp (SegOp op) = SegOp <$> replaceInSegOp op replaceInHostOp op = pure op -replaceInMCOp :: MCOp MCMem () -> UpdateM (MCOp MCMem ()) (MCOp MCMem ()) +replaceInMCOp :: MCOp NoOp MCMem -> UpdateM (MCOp NoOp MCMem) (MCOp NoOp MCMem) replaceInMCOp (ParOp par_op op) = ParOp <$> traverse replaceInSegOp par_op <*> replaceInSegOp op replaceInMCOp op = pure op @@ -187,7 +194,7 @@ else pure m generalizeIxfun _ _ m = pure m -replaceInIfBody :: (Mem rep inner, LetDec rep ~ LetDecMem) => Body rep -> UpdateM inner (Body rep) +replaceInIfBody :: (Mem rep inner, LetDec rep ~ LetDecMem) => Body rep -> UpdateM (inner rep) (Body rep) replaceInIfBody b@(Body _ stms res) = do coaltab <- asks envCoalesceTab stms' <- updateStms stms diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs b/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs @@ -21,6 +21,7 @@ import Data.Maybe import Data.Sequence (Seq (..)) import Data.Set qualified as S +import Futhark.Analysis.LastUse import Futhark.Analysis.PrimExp.Convert import Futhark.IR.Aliases import Futhark.IR.GPUMem as GPU @@ -29,7 +30,6 @@ import Futhark.IR.SeqMem import Futhark.MonadFreshNames import Futhark.Optimise.ArrayShortCircuiting.DataStructs -import Futhark.Optimise.ArrayShortCircuiting.LastUse import Futhark.Optimise.ArrayShortCircuiting.MemRefAggreg import Futhark.Optimise.ArrayShortCircuiting.TopdownAnalysis import Futhark.Util @@ -39,15 +39,19 @@ ( Mem rep inner, ASTRep rep, CanBeAliased inner, - Op rep ~ MemOp inner, + AliasableRep rep, + Op rep ~ MemOp inner rep, HasMemBlock (Aliases rep), LetDec rep ~ LetDecMem, - TopDownHelper (OpWithAliases inner) + TopDownHelper (inner (Aliases rep)) ) +type ComputeScalarTable rep op = + ScopeTab rep -> op -> ScalarTableM rep (M.Map VName (PrimExp VName)) + -- Helper type for computing scalar tables on ops. newtype ComputeScalarTableOnOp rep = ComputeScalarTableOnOp - { scalarTableOnOp :: ScopeTab rep -> Op (Aliases rep) -> ScalarTableM rep (M.Map VName (PrimExp VName)) + { scalarTableOnOp :: ComputeScalarTable rep (Op (Aliases rep)) } type ScalarTableM rep a = Reader (ComputeScalarTableOnOp rep) a @@ -109,7 +113,7 @@ -- | Given a 'Prog' in 'GPUMem' representation, compute the coalescing table -- by folding over each function. -mkCoalsTabGPU :: (MonadFreshNames m) => Prog (Aliases GPUMem) -> m (M.Map Name CoalsTab) +mkCoalsTabGPU :: MonadFreshNames m => Prog (Aliases GPUMem) -> m (M.Map Name CoalsTab) mkCoalsTabGPU prog = mkCoalsTabProg (lastUseGPUMem prog) @@ -267,7 +271,7 @@ td_env bu_env shortCircuitGPUMem _ _ (Inner (GPU.SizeOp _)) _ bu_env = pure bu_env -shortCircuitGPUMem _ _ (Inner (GPU.OtherOp ())) _ bu_env = pure bu_env +shortCircuitGPUMem _ _ (Inner (GPU.OtherOp NoOp)) _ bu_env = pure bu_env shortCircuitMCMem :: LUTabFun -> @@ -277,7 +281,7 @@ BotUpEnv -> ShortCircuitM MCMem BotUpEnv shortCircuitMCMem _ _ (Alloc _ _) _ bu_env = pure bu_env -shortCircuitMCMem _ _ (Inner (MC.OtherOp ())) _ bu_env = pure bu_env +shortCircuitMCMem _ _ (Inner (MC.OtherOp NoOp)) _ bu_env = pure bu_env shortCircuitMCMem lutab pat (Inner (MC.ParOp (Just par_op) op)) td_env bu_env = shortCircuitSegOp (const True) lutab pat par_op td_env bu_env >>= shortCircuitSegOp (const True) lutab pat op td_env @@ -771,8 +775,7 @@ ) pure bu_env - { activeCoals = - actv_res, + { activeCoals = actv_res, successCoals = succ_res, inhibit = inhibit_res } @@ -1262,10 +1265,10 @@ TopdownEnv rep -> [PatElem (VarAliases, LetDecMem)] -> (CoalsTab, InhibitTab) -filterSafetyCond2and5 act_coal inhb_coal scals_env td_env = - foldl helper (act_coal, inhb_coal) +filterSafetyCond2and5 act_coal inhb_coal scals_env td_env pes = + foldl helper (act_coal, inhb_coal) pes where - helper (acc, inhb) patel = + helper (acc, inhb) patel = do -- For each pattern element in the input list case (patElemName patel, patElemDec patel) of (b, (_, MemArray tp0 shp0 _ (ArrayIn m_b _idxfn_b))) -> @@ -1275,27 +1278,33 @@ Just info@(CoalsEntry x_mem _ _ vtab _ _) -> -- And m_b we're trying to coalesce m_b let failed = markFailedCoal (acc, inhb) m_b - in case M.lookup b vtab of - Nothing -> - case getDirAliasedIxfn td_env acc b of - Nothing -> failed - Just (_, _, b_indfun') -> - -- And we have the index function of b - case freeVarSubstitutions (scope td_env) scals_env b_indfun' of - Nothing -> failed - Just fv_subst -> - let mem_info = Coalesced TransitiveCoal (MemBlock tp0 shp0 x_mem b_indfun') fv_subst - info' = info {vartab = M.insert b mem_info vtab} - in (M.insert m_b info' acc, inhb) - Just (Coalesced k (MemBlock pt shp _ new_indfun) _) -> - let safe_2 = isInScope td_env x_mem - in case freeVarSubstitutions (scope td_env) scals_env new_indfun of - Just fv_subst - | safe_2 -> - let mem_info = Coalesced k (MemBlock pt shp x_mem new_indfun) fv_subst - info' = info {vartab = M.insert b mem_info vtab} - in (M.insert m_b info' acc, inhb) - _ -> failed + in -- It is not safe to short circuit if some other pattern + -- element is aliased to this one, as this indicates the + -- two pattern elements reference the same physical + -- value somehow. + if any ((`nameIn` aliasesOf patel) . patElemName) pes + then failed + else case M.lookup b vtab of + Nothing -> + case getDirAliasedIxfn td_env acc b of + Nothing -> failed + Just (_, _, b_indfun') -> + -- And we have the index function of b + case freeVarSubstitutions (scope td_env) scals_env b_indfun' of + Nothing -> failed + Just fv_subst -> + let mem_info = Coalesced TransitiveCoal (MemBlock tp0 shp0 x_mem b_indfun') fv_subst + info' = info {vartab = M.insert b mem_info vtab} + in (M.insert m_b info' acc, inhb) + Just (Coalesced k (MemBlock pt shp _ new_indfun) _) -> + let safe_2 = isInScope td_env x_mem + in case freeVarSubstitutions (scope td_env) scals_env new_indfun of + Just fv_subst + | safe_2 -> + let mem_info = Coalesced k (MemBlock pt shp x_mem new_indfun) fv_subst + info' = info {vartab = M.insert b mem_info vtab} + in (M.insert m_b info' acc, inhb) + _ -> failed _ -> (acc, inhb) -- | Pattern matches a potentially coalesced statement and @@ -1469,8 +1478,8 @@ Nothing genSSPointInfoMemOp :: - GenSSPoint rep inner -> - GenSSPoint rep (MemOp inner) + GenSSPoint rep (inner (Aliases rep)) -> + GenSSPoint rep (MemOp inner (Aliases rep)) genSSPointInfoMemOp onOp lutab td_end scopetab pat (Inner op) = onOp lutab td_end scopetab pat op genSSPointInfoMemOp _ _ _ _ _ _ = Nothing @@ -1700,11 +1709,8 @@ on_op scope_table op computeScalarTable _ _ = pure mempty -type ComputeScalarTable rep op = - ScopeTab rep -> op -> ScalarTableM rep (M.Map VName (PrimExp VName)) - computeScalarTableMemOp :: - ComputeScalarTable rep inner -> ComputeScalarTable rep (MemOp inner) + ComputeScalarTable rep (inner (Aliases rep)) -> ComputeScalarTable rep (MemOp inner (Aliases rep)) computeScalarTableMemOp _ _ (Alloc _ _) = pure mempty computeScalarTableMemOp onInner scope_table (Inner op) = onInner scope_table op @@ -1721,19 +1727,19 @@ (stmsToList $ kernelBodyStms $ segBody segop) computeScalarTableGPUMem :: - ComputeScalarTable GPUMem (GPU.HostOp (Aliases GPUMem) ()) + ComputeScalarTable GPUMem (GPU.HostOp NoOp (Aliases GPUMem)) computeScalarTableGPUMem scope_table (GPU.SegOp segop) = computeScalarTableSegOp scope_table segop computeScalarTableGPUMem _ (GPU.SizeOp _) = pure mempty -computeScalarTableGPUMem _ (GPU.OtherOp ()) = pure mempty +computeScalarTableGPUMem _ (GPU.OtherOp NoOp) = pure mempty computeScalarTableGPUMem scope_table (GPU.GPUBody _ body) = concatMapM (computeScalarTable $ scope_table <> scopeOf (bodyStms body)) (stmsToList $ bodyStms body) computeScalarTableMCMem :: - ComputeScalarTable MCMem (MC.MCOp (Aliases MCMem) ()) -computeScalarTableMCMem _ (MC.OtherOp ()) = pure mempty + ComputeScalarTable MCMem (MC.MCOp NoOp (Aliases MCMem)) +computeScalarTableMCMem _ (MC.OtherOp NoOp) = pure mempty computeScalarTableMCMem scope_table (MC.ParOp par_op segop) = (<>) <$> maybe (pure mempty) (computeScalarTableSegOp scope_table) par_op diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/DataStructs.hs b/src/Futhark/Optimise/ArrayShortCircuiting/DataStructs.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting/DataStructs.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting/DataStructs.hs @@ -379,7 +379,7 @@ -- argument. Otherwise look up the type of the argument and return a 'LeafExp' -- if it is a 'PrimType'. vnameToPrimExp :: - (CanBeAliased (Op rep), RepTypes rep) => + (AliasableRep rep) => ScopeTab rep -> ScalarTab -> VName -> diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/LastUse.hs b/src/Futhark/Optimise/ArrayShortCircuiting/LastUse.hs deleted file mode 100644 --- a/src/Futhark/Optimise/ArrayShortCircuiting/LastUse.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Last use analysis for array short circuiting --- --- Last-Use analysis of a Futhark program in aliased explicit-memory lore form. --- Takes as input such a program or a function and produces a 'M.Map VName --- Names', in which the key identified the let stmt, and the list argument --- identifies the variables that were lastly used in that stmt. Note that the --- results of a body do not have a last use, and neither do a function --- parameters if it happens to not be used inside function's body. Such cases --- are supposed to be treated separately. --- --- This pass is different from "Futhark.Analysis.LastUse" in that memory blocks --- are used to alias arrays. For instance, an 'Update' will not result in a last --- use of the array being updated, because the result lives in the same memory. -module Futhark.Optimise.ArrayShortCircuiting.LastUse - ( lastUseSeqMem, - lastUseGPUMem, - lastUseMCMem, - LUTabFun, - LUTabProg, - ) -where - -import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.Bifunctor (bimap) -import Data.Function ((&)) -import Data.Map.Strict qualified as M -import Data.Maybe -import Data.Sequence (Seq (..)) -import Futhark.IR.Aliases -import Futhark.IR.GPUMem -import Futhark.IR.GPUMem qualified as GPU -import Futhark.IR.MCMem -import Futhark.IR.MCMem qualified as MC -import Futhark.IR.SeqMem -import Futhark.Optimise.ArrayShortCircuiting.DataStructs -import Futhark.Util - --- | Maps a name indentifying a Stm to the last uses in that Stm. -type LUTabFun = M.Map VName Names - --- | LU-table for the constants, and for each function. -type LUTabProg = (LUTabFun, M.Map Name LUTabFun) - -type LastUseOp rep = Op (Aliases rep) -> Names -> LastUseM rep (LUTabFun, Names, Names) - --- | 'LastUseReader' allows us to abstract over representations by supplying the --- 'onOp' function. -data LastUseReader rep = LastUseReader - { onOp :: LastUseOp rep, - scope :: Scope (Aliases rep) - } - --- | Maps a variable or memory block to its aliases. -type AliasTab = M.Map VName Names - -newtype LastUseM rep a = LastUseM (StateT AliasTab (Reader (LastUseReader rep)) a) - deriving - ( Monad, - Functor, - Applicative, - MonadReader (LastUseReader rep), - MonadState AliasTab - ) - -instance - (RepTypes rep, CanBeAliased (Op rep)) => - HasScope (Aliases rep) (LastUseM rep) - where - askScope = asks scope - -instance - (RepTypes rep, CanBeAliased (Op rep)) => - LocalScope (Aliases rep) (LastUseM rep) - where - localScope sc (LastUseM m) = LastUseM $ do - local (\rd -> rd {scope = scope rd <> sc}) m - -type Constraints rep = - ( LocalScope (Aliases rep) (LastUseM rep), - ASTRep rep, - FreeIn (OpWithAliases (Op rep)), - HasMemBlock (Aliases rep), - CanBeAliased (Op rep) - ) - -runLastUseM :: LastUseOp rep -> LastUseM rep a -> a -runLastUseM onOp (LastUseM m) = - runReader (evalStateT m mempty) (LastUseReader onOp mempty) - -aliasLookup :: VName -> LastUseM rep Names -aliasLookup vname = - gets $ fromMaybe mempty . M.lookup vname - -lastUseProg :: - Constraints rep => - Prog (Aliases rep) -> - LastUseM rep LUTabProg -lastUseProg prog = - let bound_in_consts = - progConsts prog - & concatMap (patNames . stmPat) - & namesFromList - consts = progConsts prog - funs = progFuns prog - in inScopeOf consts $ do - (consts_lu, _) <- lastUseStms consts mempty mempty - lus <- mapM (lastUseFun bound_in_consts) funs - pure (consts_lu, M.fromList $ zip (map funDefName funs) lus) - -lastUseFun :: - Constraints rep => - Names -> - FunDef (Aliases rep) -> - LastUseM rep LUTabFun -lastUseFun bound_in_consts f = - inScopeOf f $ fst <$> lastUseBody (funDefBody f) (mempty, bound_in_consts) - --- | Perform last-use analysis on a 'Prog' in 'SeqMem' -lastUseSeqMem :: Prog (Aliases SeqMem) -> LUTabProg -lastUseSeqMem = runLastUseM lastUseSeqOp . lastUseProg - --- | Perform last-use analysis on a 'Prog' in 'GPUMem' -lastUseGPUMem :: Prog (Aliases GPUMem) -> LUTabProg -lastUseGPUMem = runLastUseM (lastUseMemOp lastUseGPUOp) . lastUseProg - --- | Perform last-use analysis on a 'Prog' in 'MCMem' -lastUseMCMem :: Prog (Aliases MCMem) -> LUTabProg -lastUseMCMem = runLastUseM (lastUseMemOp lastUseMCOp) . lastUseProg - --- | Performing the last-use analysis on a body. --- --- The implementation consists of a bottom-up traversal of the body's statements --- in which the the variables lastly used in a statement are computed as the --- difference between the free-variables in that stmt and the set of variables --- known to be used after that statement. -lastUseBody :: - Constraints rep => - -- | The body of statements - Body (Aliases rep) -> - -- | The current last-use table, tupled with the known set of already used names - (LUTabFun, Names) -> - -- | The result is: - -- (i) an updated last-use table, - -- (ii) an updated set of used names (including the binding). - LastUseM rep (LUTabFun, Names) -lastUseBody bdy@(Body _ stms result) (lutab, used_nms) = - -- perform analysis bottom-up in bindings: results are known to be used, - -- hence they are added to the used_nms set. - inScopeOf stms $ do - (lutab', _) <- - lastUseStms stms (lutab, used_nms) $ - namesToList $ - freeIn $ - map resSubExp result - -- Clean up the used names by recomputing the aliasing transitive-closure - -- of the free names in body based on the current alias table @alstab@. - used_in_body <- aliasTransitiveClosure $ freeIn bdy - pure (lutab', used_nms <> used_in_body) - --- | Performing the last-use analysis on a body. --- --- The implementation consists of a bottom-up traversal of the body's statements --- in which the the variables lastly used in a statement are computed as the --- difference between the free-variables in that stmt and the set of variables --- known to be used after that statement. -lastUseKernelBody :: - Constraints rep => - -- | The body of statements - KernelBody (Aliases rep) -> - -- | The current last-use table, tupled with the known set of already used names - (LUTabFun, Names) -> - -- | The result is: - -- (i) an updated last-use table, - -- (ii) an updated set of used names (including the binding). - LastUseM rep (LUTabFun, Names) -lastUseKernelBody bdy@(KernelBody _ stms result) (lutab, used_nms) = - inScopeOf stms $ do - -- perform analysis bottom-up in bindings: results are known to be used, - -- hence they are added to the used_nms set. - (lutab', _) <- - lastUseStms stms (lutab, used_nms) $ namesToList $ freeIn result - -- Clean up the used names by recomputing the aliasing transitive-closure - -- of the free names in body based on the current alias table @alstab@. - used_in_body <- aliasTransitiveClosure $ freeIn bdy - pure (lutab', used_nms <> used_in_body) - -lastUseStms :: - Constraints rep => - Stms (Aliases rep) -> - (LUTabFun, Names) -> - [VName] -> - LastUseM rep (LUTabFun, Names) -lastUseStms Empty (lutab, nms) res_nms = do - aliases <- concatMapM aliasLookup res_nms - pure (lutab, nms <> aliases <> namesFromList res_nms) -lastUseStms (stm@(Let pat _ e) :<| stms) (lutab, nms) res_nms = - inScopeOf stm $ do - let extra_alias = case e of - BasicOp (Update _ old _ _) -> oneName old - BasicOp (FlatUpdate old _ _) -> oneName old - _ -> mempty - -- We build up aliases top-down - updateAliasing extra_alias pat - -- But compute last use bottom-up - (lutab', nms') <- lastUseStms stms (lutab, nms) res_nms - (lutab'', nms'') <- lastUseStm stm (lutab', nms') - pure (lutab'', nms'') - -lastUseStm :: - Constraints rep => - Stm (Aliases rep) -> - (LUTabFun, Names) -> - LastUseM rep (LUTabFun, Names) -lastUseStm (Let pat _ e) (lutab, used_nms) = do - -- analyse the expression and get the - -- (i) a new last-use table (in case the @e@ contains bodies of stmts) - -- (ii) the set of variables lastly used in the current binding. - -- (iii) aliased transitive-closure of used names, and - (lutab', last_uses, used_nms') <- lastUseExp e used_nms - sc <- asks scope - let lu_mems = - namesToList last_uses - & mapMaybe (`getScopeMemInfo` sc) - & map memName - & namesFromList - & flip namesSubtract used_nms - - -- filter-out the binded names from the set of used variables, - -- since they go out of scope, and update the last-use table. - let patnms = patNames pat - used_nms'' = used_nms' `namesSubtract` namesFromList patnms - lutab'' = - M.union lutab' $ M.insert (head patnms) (last_uses <> lu_mems) lutab - pure (lutab'', used_nms'') - --------------------------------- - --- | Last-Use Analysis for an expression. -lastUseExp :: - Constraints rep => - -- | The expression to analyse - Exp (Aliases rep) -> - -- | The set of used names "after" this expression - Names -> - -- | Result: - -- 1. an extra LUTab recording the last use for expression's inner bodies, - -- 2. the set of last-used vars in the expression at this level, - -- 3. the updated used names, now including expression's free vars. - LastUseM rep (LUTabFun, Names, Names) -lastUseExp (Match _ cases body _) used_nms = do - -- For an if-then-else, we duplicate the last use at each body level, meaning - -- we record the last use of the outer statement, and also the last use in the - -- statement in the inner bodies. We can safely ignore the if-condition as it is - -- a boolean scalar. - (lutab_cases, used_cases) <- - bimap mconcat mconcat . unzip - <$> mapM (flip lastUseBody (M.empty, used_nms) . caseBody) cases - (lutab', body_used_nms) <- lastUseBody body (M.empty, used_nms) - let free_in_body = freeIn body - let free_in_cases = freeIn cases - let used_nms' = used_cases <> body_used_nms - (_, last_used_arrs) <- lastUsedInNames used_nms $ free_in_body <> free_in_cases - pure (lutab_cases <> lutab', last_used_arrs, used_nms') -lastUseExp (DoLoop var_ses lf body) used_nms0 = inScopeOf lf $ do - free_in_body <- aliasTransitiveClosure $ freeIn body - -- compute the aliasing transitive closure of initializers that are not last-uses - var_inis <- catMaybes <$> mapM (initHelper (free_in_body <> used_nms0)) var_ses - let -- To record last-uses inside the loop body, we call 'lastUseBody' with used-names - -- being: (free_in_body - loop-variants-a) + used_nms0. As such we disable cases b) - -- and c) to produce loop-variant last uses inside the loop, and also we prevent - -- the free-loop-variables to having last uses inside the loop. - free_in_body' = free_in_body `namesSubtract` namesFromList (map fst var_inis) - used_nms = used_nms0 <> free_in_body' <> freeIn (bodyResult body) - (body_lutab, _) <- lastUseBody body (mempty, used_nms) - - -- add var_inis_a to the body_lutab, i.e., record the last-use of - -- initializer in the corresponding loop variant. - let lutab_res = body_lutab <> M.fromList var_inis - - -- the result used names are: - fpar_nms = namesFromList $ map (identName . paramIdent . fst) var_ses - used_nms' = (free_in_body <> freeIn (map snd var_ses)) `namesSubtract` fpar_nms - used_nms_res = used_nms0 <> used_nms' <> freeIn (bodyResult body) - - -- the last-uses at loop-statement level are the loop free variables that - -- do not belong to @used_nms0@; this includes the initializers of b), @lu_ini_b@ - lu_arrs = used_nms' `namesSubtract` used_nms0 - pure (lutab_res, lu_arrs, used_nms_res) - where - initHelper free_and_used (fp, se) = do - names <- aliasTransitiveClosure $ maybe mempty oneName $ subExpVar se - if names `namesIntersect` free_and_used - then pure Nothing - else pure $ Just (identName $ paramIdent fp, names) -lastUseExp (Op op) used_nms = do - on_op <- reader onOp - on_op op used_nms -lastUseExp e used_nms = do - let free_in_e = freeIn e - (used_nms', lu_vars) <- lastUsedInNames used_nms free_in_e - pure (M.empty, lu_vars, used_nms') - -lastUseMemOp :: - (inner -> Names -> LastUseM rep (LUTabFun, Names, Names)) -> - MemOp inner -> - Names -> - LastUseM rep (LUTabFun, Names, Names) -lastUseMemOp _ (Alloc se sp) used_nms = do - let free_in_e = freeIn se <> freeIn sp - (used_nms', lu_vars) <- lastUsedInNames used_nms free_in_e - pure (M.empty, lu_vars, used_nms') -lastUseMemOp onInner (Inner op) used_nms = onInner op used_nms - -lastUseSegOp :: - Constraints rep => - SegOp lvl (Aliases rep) -> - Names -> - LastUseM rep (LUTabFun, Names, Names) -lastUseSegOp (SegMap _ _ tps kbody) used_nms = do - (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn tps - (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') - pure (body_lutab, lu_vars, used_nms' <> used_nms'') -lastUseSegOp (SegRed _ _ sbos tps kbody) used_nms = do - (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseSegBinOp sbos used_nms - (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps - (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') - pure (M.union lutab_sbo body_lutab, lu_vars <> lu_vars_sbo, used_nms_sbo <> used_nms' <> used_nms'') -lastUseSegOp (SegScan _ _ sbos tps kbody) used_nms = do - (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseSegBinOp sbos used_nms - (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps - (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') - pure (M.union lutab_sbo body_lutab, lu_vars <> lu_vars_sbo, used_nms_sbo <> used_nms' <> used_nms'') -lastUseSegOp (SegHist _ _ hos tps kbody) used_nms = do - (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseHistOp hos used_nms - (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps - (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') - pure (M.union lutab_sbo body_lutab, lu_vars <> lu_vars_sbo, used_nms_sbo <> used_nms' <> used_nms'') - -lastUseGPUOp :: HostOp (Aliases GPUMem) () -> Names -> LastUseM GPUMem (LUTabFun, Names, Names) -lastUseGPUOp (GPU.OtherOp ()) used_nms = - pure (mempty, mempty, used_nms) -lastUseGPUOp (SizeOp sop) used_nms = do - (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn sop - pure (mempty, lu_vars, used_nms') -lastUseGPUOp (GPUBody tps body) used_nms = do - (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn tps - (body_lutab, used_nms'') <- lastUseBody body (mempty, used_nms') - pure (body_lutab, lu_vars, used_nms' <> used_nms'') -lastUseGPUOp (SegOp op) used_nms = - lastUseSegOp op used_nms - -lastUseMCOp :: MCOp (Aliases MCMem) () -> Names -> LastUseM MCMem (LUTabFun, Names, Names) -lastUseMCOp (MC.OtherOp ()) used_nms = - pure (mempty, mempty, used_nms) -lastUseMCOp (MC.ParOp par_op op) used_nms = do - (lutab_par_op, lu_vars_par_op, used_names_par_op) <- - maybe (pure mempty) (`lastUseSegOp` used_nms) par_op - (lutab_op, lu_vars_op, used_names_op) <- - lastUseSegOp op used_nms - pure - ( lutab_par_op <> lutab_op, - lu_vars_par_op <> lu_vars_op, - used_names_par_op <> used_names_op - ) - -lastUseSegBinOp :: - Constraints rep => - [SegBinOp (Aliases rep)] -> - Names -> - LastUseM rep (LUTabFun, Names, Names) -lastUseSegBinOp sbos used_nms = do - (lutab, lu_vars, used_nms') <- unzip3 <$> mapM helper sbos - pure (mconcat lutab, mconcat lu_vars, mconcat used_nms') - where - helper (SegBinOp _ l@(Lambda _ body _) neutral shp) = inScopeOf l $ do - (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn neutral <> freeIn shp - (body_lutab, used_nms'') <- lastUseBody body (mempty, used_nms') - pure (body_lutab, lu_vars, used_nms'') - -lastUseHistOp :: - Constraints rep => - [HistOp (Aliases rep)] -> - Names -> - LastUseM rep (LUTabFun, Names, Names) -lastUseHistOp hos used_nms = do - (lutab, lu_vars, used_nms') <- unzip3 <$> mapM helper hos - pure (mconcat lutab, mconcat lu_vars, mconcat used_nms') - where - helper (HistOp shp rf dest neutral shp' l@(Lambda _ body _)) = inScopeOf l $ do - (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn shp <> freeIn rf <> freeIn dest <> freeIn neutral <> freeIn shp' - (body_lutab, used_nms'') <- lastUseBody body (mempty, used_nms') - pure (body_lutab, lu_vars, used_nms'') - -lastUseSeqOp :: Op (Aliases SeqMem) -> Names -> LastUseM SeqMem (LUTabFun, Names, Names) -lastUseSeqOp (Alloc se sp) used_nms = do - let free_in_e = freeIn se <> freeIn sp - (used_nms', lu_vars) <- lastUsedInNames used_nms free_in_e - pure (mempty, lu_vars, used_nms') -lastUseSeqOp (Inner ()) used_nms = do - pure (mempty, mempty, used_nms) - ------------------------------------------------------- - --- | Given already used names and newly encountered 'Names', return an updated --- set used names and the set of names that were last used here. --- --- For a given name @x@ in the new uses, if neither @x@ nor any of its aliases --- are present in the set of used names, this is a last use of @x@. -lastUsedInNames :: - -- | Used names - Names -> - -- | New uses - Names -> - LastUseM rep (Names, Names) -lastUsedInNames used_nms new_uses = do - -- a use of an argument x is also a use of any variable in x alias set - -- so we update the alias-based transitive-closure of used names. - new_uses_with_aliases <- aliasTransitiveClosure new_uses - -- if neither a variable x, nor any of its alias set have been used before (in - -- the backward traversal), then it is a last use of both that variable and - -- all other variables in its alias set - last_uses <- filterM isLastUse $ namesToList new_uses - last_uses' <- aliasTransitiveClosure $ namesFromList last_uses - pure (used_nms <> new_uses_with_aliases, last_uses') - where - isLastUse x = do - with_aliases <- aliasTransitiveClosure $ oneName x - pure $ not $ with_aliases `namesIntersect` used_nms - --- | Compute the transitive closure of the aliases of a set of 'Names'. -aliasTransitiveClosure :: Names -> LastUseM rep Names -aliasTransitiveClosure args = do - res <- foldl (<>) args <$> mapM aliasLookup (namesToList args) - if res == args - then pure res - else aliasTransitiveClosure res - --- | For each 'PatElem' in the 'Pat', add its aliases to the 'AliasTab' in --- 'LastUseM'. Additionally, 'Names' are added as aliases of all the 'PatElemT'. -updateAliasing :: - AliasesOf dec => - -- | Extra names that all 'PatElem' should alias. - Names -> - -- | Pattern to process - Pat dec -> - LastUseM rep () -updateAliasing extra_aliases = - mapM_ update . patElems - where - update :: AliasesOf dec => PatElem dec -> LastUseM rep () - update (PatElem name dec) = do - let aliases = aliasesOf dec - aliases' <- aliasTransitiveClosure $ extra_aliases <> aliases - modify $ M.insert name aliases' diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs b/src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs @@ -75,7 +75,7 @@ -- | This function computes the written and read memory references for the current statement getUseSumFromStm :: - (Op rep ~ MemOp inner, HasMemBlock (Aliases rep)) => + (Op rep ~ MemOp inner rep, HasMemBlock (Aliases rep)) => TopdownEnv rep -> CoalsTab -> Stm (Aliases rep) -> @@ -152,7 +152,7 @@ -- 2. fails the entries in active coalesced table for which the write set -- overlaps the uses of the destination (to that point) recordMemRefUses :: - (CanBeAliased (Op rep), RepTypes rep, Op rep ~ MemOp inner, HasMemBlock (Aliases rep)) => + (AliasableRep rep, Op rep ~ MemOp inner rep, HasMemBlock (Aliases rep)) => TopdownEnv rep -> BotUpEnv -> Stm (Aliases rep) -> @@ -254,7 +254,7 @@ -- -- This check is conservative, so unless we can guarantee that there is no -- overlap, we return 'False'. -noMemOverlap :: (CanBeAliased (Op rep), RepTypes rep) => TopdownEnv rep -> AccessSummary -> AccessSummary -> Bool +noMemOverlap :: (AliasableRep rep) => TopdownEnv rep -> AccessSummary -> AccessSummary -> Bool noMemOverlap _ _ (Set mr) | mr == mempty = True noMemOverlap _ (Set mr) _ diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs b/src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs @@ -141,7 +141,7 @@ scopeHelper op = scopeOfSegSpace $ segSpace op -instance TopDownHelper (HostOp (Aliases GPUMem) ()) where +instance TopDownHelper (HostOp NoOp (Aliases GPUMem)) where innerNonNegatives vs (SegOp op) = innerNonNegatives vs op innerNonNegatives [vname] (SizeOp (GetSize _ _)) = oneName vname innerNonNegatives [vname] (SizeOp (GetSizeMax _)) = oneName vname @@ -153,7 +153,7 @@ scopeHelper (SegOp op) = scopeHelper op scopeHelper _ = mempty -instance TopDownHelper inner => TopDownHelper (MC.MCOp (Aliases MCMem) inner) where +instance TopDownHelper (inner (Aliases MCMem)) => TopDownHelper (MC.MCOp inner (Aliases MCMem)) where innerNonNegatives vs (ParOp par_op op) = maybe mempty (innerNonNegatives vs) par_op <> innerNonNegatives vs op @@ -167,14 +167,14 @@ maybe mempty scopeHelper par_op <> scopeHelper op scopeHelper MC.OtherOp {} = mempty -instance TopDownHelper () where - innerNonNegatives _ () = mempty - innerKnownLessThan () = mempty - scopeHelper () = mempty +instance TopDownHelper (NoOp rep) where + innerNonNegatives _ NoOp = mempty + innerKnownLessThan NoOp = mempty + scopeHelper NoOp = mempty -- | fills in the TopdownEnv table updateTopdownEnv :: - (ASTRep rep, Op rep ~ MemOp inner, TopDownHelper (OpWithAliases inner)) => + (ASTRep rep, Op rep ~ MemOp inner rep, TopDownHelper (inner (Aliases rep))) => TopdownEnv rep -> Stm (Aliases rep) -> TopdownEnv rep 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 @@ -60,10 +60,7 @@ -- memory information, since at that point arrays have identity beyond their -- value. performCSE :: - ( ASTRep rep, - CanBeAliased (Op rep), - CSEInOp (OpWithAliases (Op rep)) - ) => + (AliasableRep rep, CSEInOp (Op (Aliases rep))) => Bool -> Pass rep rep performCSE cse_arrays = @@ -87,10 +84,7 @@ -- memory information, since at that point arrays have identity beyond their -- value. performCSEOnFunDef :: - ( ASTRep rep, - CanBeAliased (Op rep), - CSEInOp (OpWithAliases (Op rep)) - ) => + (AliasableRep rep, CSEInOp (Op (Aliases rep))) => Bool -> FunDef rep -> FunDef rep @@ -104,10 +98,7 @@ -- memory information, since at that point arrays have identity beyond their -- value. performCSEOnStms :: - ( ASTRep rep, - CanBeAliased (Op rep), - CSEInOp (OpWithAliases (Op rep)) - ) => + (AliasableRep rep, CSEInOp (Op (Aliases rep))) => Bool -> Stms rep -> Stms rep @@ -125,7 +116,7 @@ (newCSEState cse_arrays) cseInFunDef :: - (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => + (Aliased rep, CSEInOp (Op rep)) => Bool -> FunDef rep -> FunDef rep @@ -151,7 +142,7 @@ type CSEM rep = Reader (CSEState rep) cseInBody :: - (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => + (Aliased rep, CSEInOp (Op rep)) => [Diet] -> Body rep -> CSEM rep (Body rep) @@ -168,7 +159,7 @@ consumeResult _ _ = mempty cseInLambda :: - (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => + (Aliased rep, CSEInOp (Op rep)) => Lambda rep -> CSEM rep (Lambda rep) cseInLambda lam = do @@ -176,7 +167,7 @@ pure lam {lambdaBody = body'} cseInStms :: - (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => + (Aliased rep, CSEInOp (Op rep)) => Names -> [Stm rep] -> CSEM rep a -> @@ -288,8 +279,8 @@ -- | Perform CSE within any nested expressions. cseInOp :: op -> CSEM rep op -instance CSEInOp () where - cseInOp () = pure () +instance CSEInOp (NoOp rep) where + cseInOp NoOp = pure NoOp subCSE :: CSEM rep r -> CSEM otherrep r subCSE m = do @@ -297,12 +288,11 @@ pure $ runReader m $ newCSEState cse_arrays instance - ( ASTRep rep, - Aliased rep, + ( Aliased rep, CSEInOp (Op rep), - CSEInOp op + CSEInOp (op rep) ) => - CSEInOp (GPU.HostOp rep op) + CSEInOp (GPU.HostOp op rep) where cseInOp (GPU.SegOp op) = GPU.SegOp <$> cseInOp op cseInOp (GPU.OtherOp op) = GPU.OtherOp <$> cseInOp op @@ -311,12 +301,11 @@ cseInOp x = pure x instance - ( ASTRep rep, - Aliased rep, + ( Aliased rep, CSEInOp (Op rep), - CSEInOp op + CSEInOp (op rep) ) => - CSEInOp (MC.MCOp rep op) + CSEInOp (MC.MCOp op rep) where cseInOp (MC.ParOp par_op op) = MC.ParOp <$> traverse cseInOp par_op <*> cseInOp op @@ -324,7 +313,7 @@ MC.OtherOp <$> cseInOp op instance - (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => + (Aliased rep, CSEInOp (Op rep)) => CSEInOp (GPU.SegOp lvl rep) where cseInOp = @@ -333,22 +322,19 @@ (GPU.SegOpMapper pure cseInLambda cseInKernelBody pure pure) cseInKernelBody :: - (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => + (Aliased rep, CSEInOp (Op rep)) => GPU.KernelBody rep -> CSEM rep (GPU.KernelBody rep) cseInKernelBody (GPU.KernelBody bodydec stms res) = do Body _ stms' _ <- cseInBody (map (const Observe) res) $ Body bodydec stms [] pure $ GPU.KernelBody bodydec stms' res -instance CSEInOp op => CSEInOp (Memory.MemOp op) where +instance CSEInOp (op rep) => CSEInOp (Memory.MemOp op rep) where cseInOp o@Memory.Alloc {} = pure o cseInOp (Memory.Inner k) = Memory.Inner <$> subCSE (cseInOp k) instance - ( ASTRep rep, - CanBeAliased (Op rep), - CSEInOp (OpWithAliases (Op rep)) - ) => + (AliasableRep rep, CSEInOp (Op (Aliases rep))) => CSEInOp (SOAC.SOAC (Aliases rep)) where cseInOp = subCSE . SOAC.mapSOACM (SOAC.SOACMapper pure cseInLambda pure) 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,3 +1,5 @@ +{-# LANGUAGE Strict #-} + -- | 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 @@ -91,6 +93,9 @@ forM_ (zip (patNames outputs) untransformed_outputs) $ \(output, v) -> letBindNames [output] . BasicOp . SubExp . Var =<< H.applyTransforms ots v ResNode _ -> pure mempty + TransNode output tr ia -> do + (cs, e) <- H.transformToExp tr ia + runBuilder_ $ certifying cs $ letBindNames [output] e FreeNode _ -> pure mempty DoNode stm lst -> do lst' <- mapM (finalizeNode . fst) lst @@ -98,9 +103,6 @@ MatchNode 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 = @@ -111,16 +113,6 @@ 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)) @@ -129,15 +121,6 @@ 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} @@ -252,11 +235,8 @@ | isRealNode s1, null infusible = pure $ Just $ MatchNode 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 +vFuseNodeT _ infusible (TransNode stm1_out tr stm1_in, _, _) (SoacNode ots2 pats2 soac2 aux2, _) + | null infusible = do stm1_in_t <- lookupType stm1_in let onInput inp | H.inputArray inp == stm1_out = @@ -359,11 +339,42 @@ removeUnusedOutputs :: DepGraphAug FusionM removeUnusedOutputs = mapAcross removeUnusedOutputsFromContext +tryFuseNodeInGraph :: DepNode -> DepGraphAug FusionM +tryFuseNodeInGraph node_to_fuse dg@DepGraph {dgGraph = g} = do + if G.gelem node_to_fuse_id g -- Node might have been fused away since. + 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 + doVerticalFusion :: DepGraphAug FusionM -doVerticalFusion dg = applyAugs (map tryFuseNodeInGraph $ reverse $ G.labNodes (dgGraph dg)) dg +doVerticalFusion dg = applyAugs (map tryFuseNodeInGraph $ reverse $ filter relevant $ G.labNodes (dgGraph dg)) dg + where + relevant (_, StmNode {}) = False + relevant (_, ResNode {}) = False + relevant _ = True +-- | For each pair of SOAC nodes that share an input, attempt to fuse +-- them horizontally. doHorizontalFusion :: DepGraphAug FusionM -doHorizontalFusion dg = applyAugs (map horizontalFusionOnNode (G.nodes (dgGraph dg))) dg +doHorizontalFusion dg = applyAugs pairs dg + where + pairs :: [DepGraphAug FusionM] + pairs = do + (x, SoacNode _ _ soac_x _) <- G.labNodes $ dgGraph dg + (y, SoacNode _ _ soac_y _) <- G.labNodes $ dgGraph dg + guard $ x < y + -- Must share an input. + guard $ + any + ((`elem` map H.inputArray (H.inputs soac_x)) . H.inputArray) + (H.inputs soac_y) + pure $ \dg' -> do + -- Nodes might have been fused away by now. + if G.gelem x (dgGraph dg') && G.gelem y (dgGraph dg') + then hTryFuseNodesInGraph x y dg' + else pure dg' doInnerFusion :: DepGraphAug FusionM doInnerFusion = mapAcross runInnerFusionOnContext diff --git a/src/Futhark/Optimise/Fusion/GraphRep.hs b/src/Futhark/Optimise/Fusion/GraphRep.hs --- a/src/Futhark/Optimise/Fusion/GraphRep.hs +++ b/src/Futhark/Optimise/Fusion/GraphRep.hs @@ -53,6 +53,7 @@ import Data.Graph.Inductive.Tree qualified as G import Data.List qualified as L import Data.Map.Strict qualified as M +import Data.Maybe (mapMaybe) import Data.Set qualified as S import Futhark.Analysis.Alias qualified as Alias import Futhark.Analysis.HORep.SOAC qualified as H @@ -75,15 +76,17 @@ data NodeT = StmNode (Stm SOACS) | SoacNode H.ArrayTransforms (Pat Type) (H.SOAC SOACS) (StmAux (ExpDec SOACS)) + | -- | First 'VName' is result; last is input. + TransNode VName H.ArrayTransform VName | -- | 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. + | -- | Node corresponding to a free variable. These are used to + -- safely handle consumption, which also means we don't have to + -- create a node for every free single variable. FreeNode VName - | FinalNode (Stms SOACS) NodeT (Stms SOACS) | MatchNode (Stm SOACS) [(NodeT, [EdgeT])] | DoNode (Stm SOACS) [(NodeT, [EdgeT])] deriving (Eq) @@ -99,7 +102,7 @@ instance Show NodeT where show (StmNode (Let pat _ _)) = L.intercalate ", " $ map prettyString $ patNames pat show (SoacNode _ pat _ _) = prettyString pat - show (FinalNode _ nt _) = show nt + show (TransNode _ tr _) = prettyString (show tr) show (ResNode name) = prettyString $ "Res: " ++ prettyString name show (FreeNode name) = prettyString $ "Input: " ++ prettyString name show (MatchNode stm _) = "Match: " ++ L.intercalate ", " (map prettyString $ stmNames stm) @@ -166,12 +169,6 @@ 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 @@ -243,18 +240,19 @@ addConsAndAliases :: Monad m => DepGraphAug m addConsAndAliases = augWithFun edges where - edges (StmNode s) = consEdges e <> aliasEdges e + edges (StmNode s) = consEdges s' <> aliasEdges s' where - e = Alias.analyseExp mempty $ stmExp s + s' = Alias.analyseStm mempty s edges _ = mempty - consEdges e = zip names (map Cons names) + consEdges s = zip names (map Cons names) where - names = namesToList $ consumedInExp e + names = namesToList $ consumedInStm s aliasEdges = map (\vname -> (vname, Alias vname)) . namesToList . mconcat - . expAliases + . patAliases + . stmPat -- 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 @@ -268,7 +266,7 @@ mapping = dgProducerMapping dg makeEdge (from, to, Cons cname) = do let aliases = namesToList $ M.findWithDefault mempty cname alias_table - to' = map (mapping M.!) aliases + to' = mapMaybe (`M.lookup` mapping) aliases p (tonode, toedge) = tonode /= from && getName toedge `elem` (cname : aliases) (to2, _) <- filter p $ concatMap (G.lpre g) to' <> G.lpre g to @@ -293,44 +291,46 @@ pure $ DoNode s [] Match {} -> pure $ MatchNode s [] + e + | [output] <- patNames pat, + Just (ia, tr) <- H.transformFromExp (stmAuxCerts aux) e -> + pure $ TransNode output tr ia _ -> 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 + dgAliasTable = aliases } where labelNodes = zip [0 ..] stmnodes = map StmNode $ stmsToList $ bodyStms body resnodes = map ResNode $ namesToList $ freeIn $ bodyResult body - inputnodes = map FreeNode $ namesToList $ freeIn body + inputnodes = map FreeNode $ namesToList consumed + (_, (aliases, consumed)) = Alias.analyseStms mempty $ bodyStms body +getStmRes :: EdgeGenerator +getStmRes (ResNode name) = [(name, Res name)] +getStmRes _ = [] + +addResEdges :: Monad m => DepGraphAug m +addResEdges = augWithFun getStmRes + -- | 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 + addDeps, + addConsAndAliases, + addExtraCons, + addResEdges, + mapAcrossNodeTs nodeToSoacNode -- Must be done after adding edges ] -- | Make a dependency graph corresponding to a function. @@ -354,9 +354,6 @@ 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 @@ -407,18 +404,14 @@ 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 + (TransNode v _ _) -> [v] (ResNode _) -> [] (FreeNode name) -> [name] (MatchNode stm _) -> stmNames stm (DoNode stm _) -> stmNames stm - FinalNode {} -> error "Final nodes cannot generate edges" (SoacNode _ pat _ _) -> patNames pat -- | Is there a possibility of fusion? diff --git a/src/Futhark/Optimise/Fusion/TryFusion.hs b/src/Futhark/Optimise/Fusion/TryFusion.hs --- a/src/Futhark/Optimise/Fusion/TryFusion.hs +++ b/src/Futhark/Optimise/Fusion/TryFusion.hs @@ -231,10 +231,10 @@ 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 + -- exclusively without any transformations. + let ker_inputs = map SOAC.inputArray (inputs ker) + okInput v inp = v /= SOAC.inputArray inp || isJust (SOAC.isVarishInput inp) + inputOrUnfus v = all (okInput v) (inputs ker) || v `notElem` ker_inputs guard $ all inputOrUnfus outVars @@ -258,6 +258,10 @@ (_, _, Horizontal) | not (SOAC.nullTransforms $ fsOutputTransform ker) -> fail "Horizontal fusion is invalid in the presence of output transforms." + (_, _, Vertical) + | unfus_set /= mempty, + not (SOAC.nullTransforms $ fsOutputTransform ker) -> + fail "Cannot perform diagonal fusion in the presence of output transforms." ( SOAC.Screma _ (ScremaForm scans_c reds_c _) _, SOAC.Screma _ (ScremaForm scans_p reds_p _) _, _ 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 @@ -118,7 +118,7 @@ descend [] m = m descend (stm : stms) m = bindingStm stm $ descend stms m -type Constraints rep = (Buildable rep, CanBeAliased (Op rep)) +type Constraints rep = (Buildable rep, AliasableRep rep) optimiseBody :: Constraints rep => @@ -198,7 +198,7 @@ } onSegOp :: - (Buildable rep, CanBeAliased (Op rep)) => + Constraints rep => SegOp lvl (Aliases rep) -> ForwardingM rep (SegOp lvl (Aliases rep)) onSegOp 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 @@ -47,7 +47,7 @@ ( MonadFreshNames m, Buildable rep, LetDec rep ~ Type, - CanBeAliased (Op rep) + AliasableRep rep ) => LowerUpdate rep m lowerUpdate scope (Let pat aux (DoLoop merge form body)) updates = do 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 @@ -111,10 +111,8 @@ 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 @@ -126,6 +124,7 @@ where cg = buildCallGraph prog +-- Inline everything that is not #[noinline]. aggInlineFunctions :: MonadFreshNames m => Prog SOACS -> m (Prog SOACS) aggInlineFunctions prog = inlineFunctions 3 cg (S.fromList $ map funDefName $ progFuns prog) prog diff --git a/src/Futhark/Optimise/MergeGPUBodies.hs b/src/Futhark/Optimise/MergeGPUBodies.hs --- a/src/Futhark/Optimise/MergeGPUBodies.hs +++ b/src/Futhark/Optimise/MergeGPUBodies.hs @@ -138,7 +138,7 @@ -- To move X before Y then the dependencies of X must also not overlap with -- the variables bound by Y. - let observed = namesToSet $ rootAliasesOf (fold $ expAliases e) aliases + let observed = namesToSet $ rootAliasesOf (fold $ patAliases pat) aliases let consumed = namesToSet $ rootAliasesOf (consumedInExp e) aliases let usage = Usage 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 @@ -351,7 +351,7 @@ -- | Optimize a host operation. 'Index' statements are added to kernel code -- that depends on migrated scalars. -optimizeHostOp :: HostOp GPU op -> ReduceM (HostOp GPU op) +optimizeHostOp :: HostOp op GPU -> ReduceM (HostOp op GPU) optimizeHostOp (SegOp (SegMap lvl space types kbody)) = SegOp . SegMap lvl space types <$> addReadsToKernelBody kbody optimizeHostOp (SegOp (SegRed lvl space ops types kbody)) = do 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 @@ -557,7 +557,7 @@ provides = patNames . stmPat expandUsage :: - (ASTRep rep, Aliased rep) => + Aliased rep => (Stm rep -> UT.UsageTable) -> ST.SymbolTable rep -> UT.UsageTable -> @@ -666,7 +666,7 @@ all (`nameIn` ST.availableAtClosestLoop vtable) . namesToList . freeIn matchBlocker :: - (ASTRep rep, CanBeWise (Op rep)) => + SimplifiableRep rep => [SubExp] -> MatchDec rt -> SimpleM rep (BlockPred (Wise rep)) @@ -966,8 +966,10 @@ Simplifiable (RetType rep), Simplifiable (BranchType rep), TraverseOpStms (Wise rep), - CanBeWise (Op rep), - ST.IndexOp (OpWithWisdom (Op rep)), + CanBeWise (OpC rep), + ST.IndexOp (Op (Wise rep)), + AliasedOp (Op (Wise rep)), + RephraseOp (OpC rep), BuilderOps (Wise rep), IsOp (Op rep) ) diff --git a/src/Futhark/Optimise/Simplify/Rep.hs b/src/Futhark/Optimise/Simplify/Rep.hs --- a/src/Futhark/Optimise/Simplify/Rep.hs +++ b/src/Futhark/Optimise/Simplify/Rep.hs @@ -35,9 +35,7 @@ import Control.Category import Control.Monad.Identity import Control.Monad.Reader -import Data.Kind qualified import Data.Map.Strict qualified as M -import Futhark.Analysis.Rephrase import Futhark.Builder import Futhark.IR import Futhark.IR.Aliases @@ -118,7 +116,7 @@ instance FreeDec BodyWisdom where precomputed = const . fvNames . unAliases . bodyWisdomFree -instance (RepTypes rep, CanBeWise (Op rep)) => RepTypes (Wise rep) where +instance Informing rep => RepTypes (Wise rep) where type LetDec (Wise rep) = (VarWisdom, LetDec rep) type ExpDec (Wise rep) = (ExpWisdom, ExpDec rep) type BodyDec (Wise rep) = (BodyWisdom, BodyDec rep) @@ -126,7 +124,7 @@ type LParamInfo (Wise rep) = LParamInfo rep type RetType (Wise rep) = RetType rep type BranchType (Wise rep) = BranchType rep - type Op (Wise rep) = OpWithWisdom (Op rep) + type OpC (Wise rep) = OpC rep withoutWisdom :: (HasScope (Wise rep) m, Monad m) => @@ -136,24 +134,24 @@ scope <- asksScope removeScopeWisdom runReaderT m scope -instance (ASTRep rep, CanBeWise (Op rep)) => ASTRep (Wise rep) where +instance Informing rep => ASTRep (Wise rep) where expTypesFromPat = withoutWisdom . expTypesFromPat . removePatWisdom instance Pretty VarWisdom where pretty _ = pretty () -instance (PrettyRep rep, CanBeWise (Op rep)) => PrettyRep (Wise rep) where +instance Informing rep => PrettyRep (Wise rep) where ppExpDec (_, dec) = ppExpDec dec . removeExpWisdom instance AliasesOf (VarWisdom, dec) where aliasesOf = unAliases . varWisdomAliases . fst -instance (ASTRep rep, CanBeWise (Op rep)) => Aliased (Wise rep) where +instance Informing rep => Aliased (Wise rep) where bodyAliases = map unAliases . bodyWisdomAliases . fst . bodyDec consumedInBody = unAliases . bodyWisdomConsumed . fst . bodyDec -removeWisdom :: CanBeWise (Op rep) => Rephraser Identity (Wise rep) rep +removeWisdom :: RephraseOp (OpC rep) => Rephraser Identity (Wise rep) rep removeWisdom = Rephraser { rephraseExpDec = pure . snd, @@ -163,7 +161,7 @@ rephraseLParamDec = pure, rephraseRetType = pure, rephraseBranchType = pure, - rephraseOp = pure . removeOpWisdom + rephraseOp = rephraseInOp removeWisdom } -- | Remove simplifier information from scope. @@ -186,23 +184,23 @@ alias (IndexName it) = IndexName it -- | Remove simplifier information from function. -removeFunDefWisdom :: CanBeWise (Op rep) => FunDef (Wise rep) -> FunDef rep +removeFunDefWisdom :: RephraseOp (OpC rep) => FunDef (Wise rep) -> FunDef rep removeFunDefWisdom = runIdentity . rephraseFunDef removeWisdom -- | Remove simplifier information from statement. -removeStmWisdom :: CanBeWise (Op rep) => Stm (Wise rep) -> Stm rep +removeStmWisdom :: RephraseOp (OpC rep) => Stm (Wise rep) -> Stm rep removeStmWisdom = runIdentity . rephraseStm removeWisdom -- | Remove simplifier information from lambda. -removeLambdaWisdom :: CanBeWise (Op rep) => Lambda (Wise rep) -> Lambda rep +removeLambdaWisdom :: RephraseOp (OpC rep) => Lambda (Wise rep) -> Lambda rep removeLambdaWisdom = runIdentity . rephraseLambda removeWisdom -- | Remove simplifier information from body. -removeBodyWisdom :: CanBeWise (Op rep) => Body (Wise rep) -> Body rep +removeBodyWisdom :: RephraseOp (OpC rep) => Body (Wise rep) -> Body rep removeBodyWisdom = runIdentity . rephraseBody removeWisdom -- | Remove simplifier information from expression. -removeExpWisdom :: CanBeWise (Op rep) => Exp (Wise rep) -> Exp rep +removeExpWisdom :: RephraseOp (OpC rep) => Exp (Wise rep) -> Exp rep removeExpWisdom = runIdentity . rephraseExp removeWisdom -- | Remove simplifier information from pattern. @@ -211,7 +209,7 @@ -- | Add simplifier information to pattern. addWisdomToPat :: - (ASTRep rep, CanBeWise (Op rep)) => + Informing rep => Pat (LetDec rep) -> Exp (Wise rep) -> Pat (LetDec (Wise rep)) @@ -222,7 +220,7 @@ -- | Produce a body with simplifier information. mkWiseBody :: - (ASTRep rep, CanBeWise (Op rep)) => + Informing rep => BodyDec rep -> Stms (Wise rep) -> Result -> @@ -239,7 +237,7 @@ -- | Produce a statement with simplifier information. mkWiseStm :: - (ASTRep rep, CanBeWise (Op rep)) => + Informing rep => Pat (LetDec rep) -> StmAux (ExpDec rep) -> Exp (Wise rep) -> @@ -250,7 +248,7 @@ -- | Produce simplifier information for an expression. mkWiseExpDec :: - (ASTRep rep, CanBeWise (Op rep)) => + Informing rep => Pat (LetDec (Wise rep)) -> ExpDec rep -> Exp (Wise rep) -> @@ -262,7 +260,7 @@ expdec ) -instance (Buildable rep, CanBeWise (Op rep)) => Buildable (Wise rep) where +instance (Buildable rep, Informing rep) => Buildable (Wise rep) where mkExpPat ids e = addWisdomToPat (mkExpPat ids $ removeExpWisdom e) e @@ -281,18 +279,20 @@ -- | Constraints that let us transform a representation into a 'Wise' -- representation. -type Informing rep = (ASTRep rep, CanBeWise (Op rep)) +type Informing rep = + ( ASTRep rep, + AliasedOp (OpC rep (Wise rep)), + RephraseOp (OpC rep), + CanBeWise (OpC rep), + FreeIn (OpC rep (Wise rep)) + ) -- | A type class for indicating that this operation can be lifted into the simplifier representation. -class (AliasedOp (OpWithWisdom op), IsOp (OpWithWisdom op)) => CanBeWise op where - type OpWithWisdom op :: Data.Kind.Type - removeOpWisdom :: OpWithWisdom op -> op - addOpWisdom :: op -> OpWithWisdom op +class CanBeWise op where + addOpWisdom :: Informing rep => op rep -> op (Wise rep) -instance CanBeWise () where - type OpWithWisdom () = () - removeOpWisdom () = () - addOpWisdom () = () +instance CanBeWise NoOp where + addOpWisdom _ = undefined -- | Construct a 'Wise' statement. informStm :: Informing rep => Stm rep -> Stm (Wise rep) 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 @@ -38,8 +38,8 @@ case ST.lookupBasicOp v vtable of Just (ArrayLit ses _, cs) -> (ArgArrayLit ses, cs) - Just (Replicate shape se, cs) -> - (ArgReplicate [shapeSize 0 shape] se, cs) + Just (Replicate (Shape [d]) se, cs) -> + (ArgReplicate [d] se, cs) _ -> (ArgVar v, mempty) @@ -132,11 +132,8 @@ | -- We produce the to-be-concatenated arrays in reverse order, so -- reverse them back. y : ys <- - forSingleArray $ - reverse $ - foldl' fuseConcatArg mempty $ - map (toConcatArg vtable) $ - x : xs, + forSingleArray . reverse . foldl' fuseConcatArg mempty $ + map (toConcatArg vtable) (x : xs), length xs /= length ys = Simplify $ do elem_type <- lookupType x 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 @@ -210,6 +210,10 @@ [] -> Just $ pure $ SubExpResult cs se _ | Var v2 <- se -> Just $ pure $ IndexResult cs v2 $ Slice inds' _ -> Nothing + Just (Update Unsafe _ (Slice update_inds) se, cs) + | inds == update_inds, + ST.subExpAvailable se vtable -> + Just $ pure $ SubExpResult cs se -- Indexing single-element arrays. We know the index must be 0. _ | Just t <- seType $ Var idd, 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 @@ -264,8 +264,8 @@ sink :: ( Buildable rep, - CanBeAliased (Op rep), - ST.IndexOp (OpWithAliases (Op rep)) + AliasableRep rep, + ST.IndexOp (Op (Aliases rep)) ) => Sinker (SinkRep rep) (Op (SinkRep rep)) -> Pass rep rep 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 @@ -11,7 +11,7 @@ import Data.List (find, foldl') import Data.Map.Strict qualified as M import Data.Maybe -import Futhark.Analysis.Rephrase +import Futhark.Analysis.Alias as Alias import Futhark.Analysis.SymbolTable qualified as ST import Futhark.Error import Futhark.IR @@ -27,6 +27,7 @@ import Futhark.Tools import Futhark.Transform.CopyPropagate (copyPropagateInFun) import Futhark.Transform.Rename (renameStm) +import Futhark.Transform.Substitute import Futhark.Util (mapAccumLM) import Futhark.Util.IntegralExp import Prelude hiding (quot) @@ -246,7 +247,7 @@ then pure (mempty, (lvl, ops, kbody)) else do (lvl_stms, lvl', grid) <- ensureGridKnown lvl - allocsForBody variant_allocs invariant_allocs grid space kbody' $ \alloc_stms kbody'' -> do + allocsForBody variant_allocs invariant_allocs grid space kbody kbody' $ \alloc_stms kbody'' -> do ops'' <- forM ops' $ \op' -> localScope (scopeOf op') $ offsetMemoryInLambda op' pure (lvl_stms <> alloc_stms, (lvl', ops'', kbody'')) @@ -264,14 +265,15 @@ KernelGrid -> SegSpace -> KernelBody GPUMem -> + KernelBody GPUMem -> (Stms GPUMem -> KernelBody GPUMem -> OffsetM b) -> ExpandM b -allocsForBody variant_allocs invariant_allocs grid space kbody' m = do +allocsForBody variant_allocs invariant_allocs grid space kbody kbody' m = do (alloc_offsets, alloc_stms) <- memoryRequirements grid space - (kernelBodyStms kbody') + (kernelBodyStms kbody) variant_allocs invariant_allocs @@ -747,14 +749,18 @@ unAllocKernelBody (KernelBody dec stms res) = KernelBody dec <$> unAllocStms True stms <*> pure res - unAllocStms nested = - fmap (stmsFromList . catMaybes) . mapM (unAllocStm nested) . stmsToList + unAllocStms nested = mapM (unAllocStm nested) - unAllocStm nested stm@(Let _ _ (Op Alloc {})) - | nested = throwError $ "Cannot handle nested allocation: " ++ prettyString stm - | otherwise = pure Nothing + unAllocStm nested stm@(Let pat dec (Op Alloc {})) + | nested = + throwError $ "Cannot handle nested allocation: " <> prettyString stm + | otherwise = + Let + <$> unAllocPat pat + <*> pure dec + <*> pure (BasicOp (SubExp $ Constant UnitValue)) unAllocStm _ (Let pat dec e) = - Just <$> (Let <$> unAllocPat pat <*> pure dec <*> mapExpM unAlloc' e) + Let <$> unAllocPat pat <*> pure dec <*> mapExpM unAlloc' e unAllocLambda (Lambda params body ret) = Lambda (map unParam params) <$> unAllocBody body <*> pure ret @@ -809,6 +815,18 @@ where comb m (mem, (_, size, space)) = M.insertWith (++) size [(mem, space)] m +copyConsumed :: (MonadBuilder m, AliasableRep (Rep m)) => Stms (Rep m) -> m (Stms (Rep m)) +copyConsumed stms = do + let consumed = namesToList $ snd $ snd $ Alias.analyseStms mempty stms + collectStms_ $ do + consumed' <- mapM copy consumed + let substs = M.fromList (zip consumed consumed') + addStms $ substituteNames substs stms + where + copy v = letExp (baseString v <> "_copy") $ BasicOp $ Copy v + +-- Important for edge cases (#1838) that the Stms here still have the +-- Allocs we are actually trying to get rid of. sliceKernelSizes :: SubExp -> [SubExp] -> @@ -834,27 +852,19 @@ flat_gtid_lparam <- newParam "flat_gtid" (Prim (IntType Int64)) - (size_lam', _) <- flip runBuilderT kernels_scope $ do - params <- replicateM num_sizes $ newParam "x" (Prim int64) - (zs, stms) <- localScope - (scopeOfLParams params <> scopeOfLParams [flat_gtid_lparam]) - $ collectStms - $ do - -- Even though this SegRed is one-dimensional, we need to - -- provide indexes corresponding to the original potentially - -- multi-dimensional construct. - let (kspace_gtids, kspace_dims) = unzip $ unSegSpace space - new_inds = - unflattenIndex - (map pe64 kspace_dims) - (pe64 $ Var $ paramName flat_gtid_lparam) - zipWithM_ letBindNames (map pure kspace_gtids) =<< mapM toExp new_inds - - mapM_ addStm kstms' - pure $ subExpsRes sizes - - localScope (scopeOfSegSpace space) $ - GPU.simplifyLambda (Lambda [flat_gtid_lparam] (Body () stms zs) i64s) + size_lam' <- localScope (scopeOfSegSpace space) . fmap fst . flip runBuilderT kernels_scope $ + GPU.simplifyLambda <=< mkLambda [flat_gtid_lparam] $ do + -- Even though this SegRed is one-dimensional, we need to + -- provide indexes corresponding to the original potentially + -- multi-dimensional construct. + let (kspace_gtids, kspace_dims) = unzip $ unSegSpace space + new_inds = + unflattenIndex + (map pe64 kspace_dims) + (pe64 $ Var $ paramName flat_gtid_lparam) + zipWithM_ letBindNames (map pure kspace_gtids) =<< mapM toExp new_inds + mapM_ addStm =<< copyConsumed kstms' + pure $ subExpsRes sizes ((maxes_per_thread, size_sums), slice_stms) <- flip runBuilderT kernels_scope $ do pat <- 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 @@ -10,6 +10,7 @@ explicitAllocationsInStmsGeneric, ExpHint (..), defaultExpHints, + askDefaultSpace, Allocable, AllocM, AllocEnv (..), @@ -70,7 +71,7 @@ BodyDec fromrep ~ (), BodyDec torep ~ (), ExpDec torep ~ (), - SizeSubst inner, + SizeSubst (inner torep), BuilderOps torep ) @@ -123,22 +124,25 @@ f <- asks envExpHints f e +-- | The space in which we allocate memory if we have no other +-- preferences or constraints. askDefaultSpace :: AllocM fromrep torep Space askDefaultSpace = asks allocSpace runAllocM :: MonadFreshNames m => + Space -> (Op fromrep -> AllocM fromrep torep (Op torep)) -> (Exp torep -> AllocM fromrep torep [ExpHint]) -> AllocM fromrep torep a -> m a -runAllocM handleOp hints (AllocM m) = +runAllocM space handleOp hints (AllocM m) = fmap fst $ modifyNameSource $ runState $ runReaderT (runBuilderT m mempty) env where env = AllocEnv { aggressiveReuse = False, - allocSpace = DefaultSpace, + allocSpace = space, envConsts = mempty, allocInOp = handleOp, envExpHints = hints @@ -164,7 +168,7 @@ arraySizeInBytes = letSubExp "bytes" <=< toExp <=< arraySizeInBytesExpM allocForArray' :: - (MonadBuilder m, Op (Rep m) ~ MemOp inner) => + (MonadBuilder m, Op (Rep m) ~ MemOp inner (Rep m)) => Type -> Space -> m VName @@ -216,7 +220,7 @@ f _ Nothing = newIdent "ext" $ Prim int64 allocsForPat :: - (MonadBuilder m, Op (Rep m) ~ MemOp inner) => + (MonadBuilder m, Op (Rep m) ~ MemOp inner (Rep m)) => Space -> [Ident] -> [ExpReturns] -> @@ -270,7 +274,7 @@ inst (Free x) = pure x summaryForBindage :: - (MonadBuilder m, Op (Rep m) ~ MemOp inner) => + (MonadBuilder m, Op (Rep m) ~ MemOp inner (Rep m)) => Space -> Type -> ExpHint -> @@ -425,7 +429,8 @@ then do -- Arrays with loop-variant shape cannot be in scalar -- space, so copy them elsewhere and try again. - (_, v') <- lift $ allocLinearArray DefaultSpace (baseString v) v + space <- lift askDefaultSpace + (_, v') <- lift $ allocLinearArray space (baseString v) v allocInMergeParam (mergeparam, Var v') else do p <- newParam "mem_param" $ MemMem v_mem_space @@ -467,7 +472,7 @@ pure (mergeparam', se, linearFuncallArg (paramType mergeparam) space) arrayWithIxFun :: - (MonadBuilder m, Op (Rep m) ~ MemOp inner, LetDec (Rep m) ~ LetDecMem) => + (MonadBuilder m, Op (Rep m) ~ MemOp inner (Rep m), LetDec (Rep m) ~ LetDecMem) => Space -> IxFun -> Type -> @@ -559,22 +564,23 @@ explicitAllocationsGeneric :: (Allocable fromrep torep inner) => + Space -> (Op fromrep -> AllocM fromrep torep (Op torep)) -> (Exp torep -> AllocM fromrep torep [ExpHint]) -> Pass fromrep torep -explicitAllocationsGeneric handleOp hints = +explicitAllocationsGeneric space handleOp hints = Pass "explicit allocations" "Transform program to explicit memory representation" $ intraproceduralTransformationWithConsts onStms allocInFun where onStms stms = - runAllocM handleOp hints $ collectStms_ $ allocInStms stms $ pure () + runAllocM space handleOp hints $ collectStms_ $ allocInStms stms $ pure () allocInFun consts (FunDef entry attrs fname rettype params fbody) = - runAllocM handleOp hints . inScopeOf consts $ - allocInFParams (zip params $ repeat DefaultSpace) $ \params' -> do + runAllocM space handleOp hints . inScopeOf consts $ + allocInFParams (zip params $ repeat space) $ \params' -> do (fbody', mem_rets) <- - allocInFunBody (map (const $ Just DefaultSpace) rettype) fbody - let rettype' = mem_rets ++ memoryInDeclExtType (length mem_rets) rettype + allocInFunBody (map (const $ Just space) rettype) fbody + let rettype' = mem_rets ++ memoryInDeclExtType space (length mem_rets) rettype pure $ FunDef entry attrs fname rettype' params' fbody' explicitAllocationsInStmsGeneric :: @@ -582,27 +588,28 @@ HasScope torep m, Allocable fromrep torep inner ) => + Space -> (Op fromrep -> AllocM fromrep torep (Op torep)) -> (Exp torep -> AllocM fromrep torep [ExpHint]) -> Stms fromrep -> m (Stms torep) -explicitAllocationsInStmsGeneric handleOp hints stms = do +explicitAllocationsInStmsGeneric space handleOp hints stms = do scope <- askScope - runAllocM handleOp hints $ + runAllocM space handleOp hints $ localScope scope $ collectStms_ $ allocInStms stms $ pure () -memoryInDeclExtType :: Int -> [DeclExtType] -> [FunReturns] -memoryInDeclExtType k dets = evalState (mapM addMem dets) 0 +memoryInDeclExtType :: Space -> Int -> [DeclExtType] -> [FunReturns] +memoryInDeclExtType space k dets = evalState (mapM addMem dets) 0 where addMem (Prim t) = pure $ MemPrim t addMem Mem {} = error "memoryInDeclExtType: too much memory" addMem (Array pt shape u) = do i <- get <* modify (+ 1) let shape' = fmap shift shape - pure . MemArray pt shape' u . ReturnsNewBlock DefaultSpace i $ + pure . MemArray pt shape' u . ReturnsNewBlock space i $ IxFun.iota $ map convert $ shapeDims shape' @@ -891,10 +898,11 @@ pure $ DoLoop merge' form' body' allocInExp (Apply fname args rettype loc) = do args' <- funcallArgs args + space <- askDefaultSpace -- We assume that every array is going to be in its own memory. - pure $ Apply fname args' (mems ++ memoryInDeclExtType num_arrays rettype) loc + pure $ Apply fname args' (mems space ++ memoryInDeclExtType space num_arrays rettype) loc where - mems = replicate num_arrays (MemMem DefaultSpace) + mems space = replicate num_arrays (MemMem space) num_arrays = length $ filter ((> 0) . arrayRank . declExtTypeOf) rettype allocInExp (Match ses cases defbody (MatchDec rets ifsort)) = do (defbody', def_reqs) <- allocInMatchBody rets defbody @@ -954,7 +962,8 @@ pure $ Param attrs p $ MemPrim t onYParam is (Param attrs p (Array pt shape u)) arr = do arr_t <- lookupType arr - mem <- allocForArray arr_t DefaultSpace + space <- askDefaultSpace + mem <- allocForArray arr_t space let base_dims = map pe64 $ arrayDims arr_t ixfun = IxFun.iota base_dims pure $ mkP attrs p pt shape u mem ixfun is @@ -1000,9 +1009,9 @@ opIsConst :: op -> Bool opIsConst = const False -instance SizeSubst () +instance SizeSubst (NoOp rep) -instance SizeSubst op => SizeSubst (MemOp op) where +instance SizeSubst (op rep) => SizeSubst (MemOp op rep) where opIsConst (Inner op) = opIsConst op opIsConst _ = False @@ -1017,12 +1026,13 @@ MonadBuilder m, ExpDec (Rep m) ~ () ) => + Space -> ExpDec (Rep m) -> [VName] -> Exp (Rep m) -> m (Stm (Rep m)) -mkLetNamesB' dec names e = do - pat <- patWithAllocations DefaultSpace names e nohints +mkLetNamesB' space dec names e = do + pat <- patWithAllocations space names e nohints pure $ Let pat (defAux dec) e where nohints = map (const NoHint) names @@ -1030,39 +1040,60 @@ mkLetNamesB'' :: ( Mem rep inner, LetDec rep ~ LetDecMem, - OpReturns (Engine.OpWithWisdom inner), + OpReturns (inner (Engine.Wise rep)), ExpDec rep ~ (), Rep m ~ Engine.Wise rep, HasScope (Engine.Wise rep) m, MonadBuilder m, + AliasedOp (inner (Engine.Wise rep)), + RephraseOp (MemOp inner), Engine.CanBeWise inner ) => + Space -> [VName] -> Exp (Engine.Wise rep) -> m (Stm (Engine.Wise rep)) -mkLetNamesB'' names e = do - pat <- patWithAllocations DefaultSpace names e nohints +mkLetNamesB'' space names e = do + pat <- patWithAllocations space names e nohints let pat' = Engine.addWisdomToPat pat e dec = Engine.mkWiseExpDec pat' () e pure $ Let pat' (defAux dec) e where nohints = map (const NoHint) names +simplifyMemOp :: + Engine.SimplifiableRep rep => + ( inner (Engine.Wise rep) -> + Engine.SimpleM rep (inner (Engine.Wise rep), Stms (Engine.Wise rep)) + ) -> + MemOp inner (Engine.Wise rep) -> + Engine.SimpleM rep (MemOp inner (Engine.Wise rep), Stms (Engine.Wise rep)) +simplifyMemOp _ (Alloc size space) = + (,) <$> (Alloc <$> Engine.simplify size <*> pure space) <*> pure mempty +simplifyMemOp onInner (Inner k) = do + (k', hoisted) <- onInner k + pure (Inner k', hoisted) + simplifiable :: ( Engine.SimplifiableRep rep, LetDec rep ~ LetDecMem, ExpDec rep ~ (), BodyDec rep ~ (), - OpReturns (Engine.OpWithWisdom inner), - AliasedOp (Engine.OpWithWisdom inner), - IndexOp (Engine.OpWithWisdom inner), - Mem rep inner + Mem (Engine.Wise rep) inner, + Engine.CanBeWise inner, + RephraseOp inner, + IsOp (inner rep), + OpReturns (inner (Engine.Wise rep)), + AliasedOp (inner (Engine.Wise rep)), + IndexOp (inner (Engine.Wise rep)) ) => - (Engine.OpWithWisdom inner -> UT.UsageTable) -> - (Engine.OpWithWisdom inner -> Engine.SimpleM rep (Engine.OpWithWisdom inner, Stms (Engine.Wise rep))) -> + (inner (Engine.Wise rep) -> UT.UsageTable) -> + ( inner (Engine.Wise rep) -> + Engine.SimpleM rep (inner (Engine.Wise rep), Stms (Engine.Wise rep)) + ) -> SimpleOps rep simplifiable innerUsage simplifyInnerOp = - SimpleOps mkExpDecS' mkBodyS' protectOp opUsage simplifyPat simplifyOp + SimpleOps mkExpDecS' mkBodyS' protectOp opUsage simplifyPat (simplifyMemOp simplifyInnerOp) where mkExpDecS' _ pat e = pure $ Engine.mkWiseExpDec pat () e @@ -1086,12 +1117,6 @@ opUsage (Inner inner) = innerUsage inner - simplifyOp (Alloc size space) = - (,) <$> (Alloc <$> Engine.simplify size <*> pure space) <*> pure mempty - simplifyOp (Inner k) = do - (k', hoisted) <- simplifyInnerOp k - pure (Inner k', hoisted) - simplifyPat (Pat pes) e = do rets <- expReturns e Pat <$> zipWithM update pes rets @@ -1116,5 +1141,5 @@ = NoHint | Hint IxFun Space -defaultExpHints :: (Monad m, ASTRep rep) => Exp rep -> m [ExpHint] -defaultExpHints e = pure $ replicate (expExtTypeSize e) NoHint +defaultExpHints :: (ASTRep rep, HasScope rep m) => Exp rep -> m [ExpHint] +defaultExpHints e = map (const NoHint) <$> expExtType e 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 @@ -30,8 +30,8 @@ where space = case lvl of SegGroup {} -> Space "local" - SegThread {} -> DefaultSpace - SegThreadInGroup {} -> DefaultSpace + SegThread {} -> Space "device" + SegThreadInGroup {} -> Space "device" handleSegOp :: Maybe SegLevel -> @@ -79,8 +79,8 @@ handleHostOp :: Maybe SegLevel -> - HostOp GPU (SOAC GPU) -> - AllocM GPU GPUMem (MemOp (HostOp GPUMem ())) + HostOp SOAC GPU -> + AllocM GPU GPUMem (MemOp (HostOp NoOp) GPUMem) handleHostOp _ (SizeOp op) = pure $ Inner $ SizeOp op handleHostOp _ (OtherOp op) = @@ -96,7 +96,7 @@ let perm_inv = rearrangeInverse perm dims' = rearrangeShape perm dims ixfun = IxFun.permute (IxFun.iota $ map pe64 dims') perm_inv - pure [Hint ixfun DefaultSpace] + pure [Hint ixfun $ Space "device"] kernelExpHints (Op (Inner (SegOp (SegMap lvl@(SegThread _ _) space ts body)))) = zipWithM (mapResultHint lvl space) ts $ kernelBodyResult body kernelExpHints (Op (Inner (SegOp (SegRed lvl@(SegThread _ _) space reds ts body)))) = @@ -104,8 +104,7 @@ where num_reds = segBinOpResults reds (red_res, map_res) = splitAt num_reds $ kernelBodyResult body -kernelExpHints e = - pure $ replicate (expExtTypeSize e) NoHint +kernelExpHints e = defaultExpHints e mapResultHint :: SegLevel -> @@ -124,7 +123,7 @@ hint t Returns {} | coalesceReturnOfShape (primByteSize (elemType t)) $ arrayDims t = do let space_dims = segSpaceDims space - pure $ Hint (innermost space_dims (arrayDims t)) DefaultSpace + pure $ Hint (innermost space_dims (arrayDims t)) $ Space "device" hint _ _ = pure NoHint innermost :: [SubExp] -> [SubExp] -> IxFun @@ -167,7 +166,7 @@ where private (Returns ResultPrivate _ _) = True private _ = False -inGroupExpHints e = pure $ replicate (expExtTypeSize e) NoHint +inGroupExpHints e = defaultExpHints e inThreadExpHints :: Exp GPUMem -> AllocM GPU GPUMem [ExpHint] inThreadExpHints e = do @@ -184,11 +183,11 @@ -- | The pass from 'GPU' to 'GPUMem'. explicitAllocations :: Pass GPU GPUMem -explicitAllocations = explicitAllocationsGeneric (handleHostOp Nothing) kernelExpHints +explicitAllocations = explicitAllocationsGeneric (Space "device") (handleHostOp Nothing) kernelExpHints -- | Convert some 'GPU' stms to 'GPUMem'. explicitAllocationsInStms :: (MonadFreshNames m, HasScope GPUMem m) => Stms GPU -> m (Stms GPUMem) -explicitAllocationsInStms = explicitAllocationsInStmsGeneric (handleHostOp Nothing) kernelExpHints +explicitAllocationsInStms = explicitAllocationsInStmsGeneric (Space "device") (handleHostOp Nothing) kernelExpHints diff --git a/src/Futhark/Pass/ExplicitAllocations/MC.hs b/src/Futhark/Pass/ExplicitAllocations/MC.hs --- a/src/Futhark/Pass/ExplicitAllocations/MC.hs +++ b/src/Futhark/Pass/ExplicitAllocations/MC.hs @@ -33,4 +33,4 @@ -- | The pass from 'MC' to 'MCMem'. explicitAllocations :: Pass MC MCMem -explicitAllocations = explicitAllocationsGeneric handleMCOp defaultExpHints +explicitAllocations = explicitAllocationsGeneric DefaultSpace handleMCOp defaultExpHints diff --git a/src/Futhark/Pass/ExplicitAllocations/SegOp.hs b/src/Futhark/Pass/ExplicitAllocations/SegOp.hs --- a/src/Futhark/Pass/ExplicitAllocations/SegOp.hs +++ b/src/Futhark/Pass/ExplicitAllocations/SegOp.hs @@ -50,7 +50,7 @@ BinOp (Mul Int64 OverflowUndef) num_threads $ intConst Int64 2 let t = paramType x `arrayOfRow` twice_num_threads - mem <- allocForArray t DefaultSpace + mem <- allocForArray t =<< askDefaultSpace -- XXX: this iota ixfun is a bit inefficient; leading to -- uncoalesced access. let base_dims = map pe64 $ arrayDims t diff --git a/src/Futhark/Pass/ExplicitAllocations/Seq.hs b/src/Futhark/Pass/ExplicitAllocations/Seq.hs --- a/src/Futhark/Pass/ExplicitAllocations/Seq.hs +++ b/src/Futhark/Pass/ExplicitAllocations/Seq.hs @@ -10,4 +10,8 @@ import Futhark.Pass.ExplicitAllocations explicitAllocations :: Pass Seq SeqMem -explicitAllocations = explicitAllocationsGeneric (pure . Inner) defaultExpHints +explicitAllocations = + explicitAllocationsGeneric + DefaultSpace + (const $ pure $ Inner NoOp) + defaultExpHints 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 @@ -823,6 +823,56 @@ -- FIXME: work around bogus targets. acc' {distTargets = singleTarget (mempty, mempty)} + -- GHC 9.2 loops without the type annotation. + generate :: + [Int] -> + KernelNest -> + Pat Type -> + Lambda SOACS -> + DistEnv GPU DistribM -> + Scope GPU -> + DistribM (Stms GPU) + generate perm nest pat' lam' dist_env extra_scope = localScope extra_scope $ do + let maploop' = MapLoop pat' aux w lam' arrs + + exploitInnerParallelism path' = do + let dist_env' = + dist_env + { distOnTopLevelStms = onTopLevelStms path', + distOnInnerMap = onInnerMap path' + } + runDistNestT dist_env' . inNesting nest . localScope extra_scope $ + discardTargets + <$> distributeMap maploop' acc {distStms = mempty} + -- Normally the permutation is for the output pattern, but + -- we can't really change that, so we change the result + -- order instead. + let lam_res' = + rearrangeShape (rearrangeInverse perm) $ + 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 + + -- XXX: we do not construct a new KernelPath when + -- sequentialising. This is only OK as long as further + -- versioning does not take place down that branch (it currently + -- does not). + (sequentialised_kernel, nestw_stms) <- localScope extra_scope $ do + let sequentialised_lam = soacsLambdaToGPU lam'' + constructKernel segThreadCapped nest' $ lambdaBody sequentialised_lam + + let outer_pat = loopNestingPat $ fst nest + (nestw_stms <>) + <$> onMap' + nest' + path + (const $ pure $ oneStm sequentialised_kernel) + exploitInnerParallelism + outer_pat + lam'' + multiVersion perm nest acc' pat' lam' = do -- The kernel can be distributed by itself, so now we can -- decide whether to just sequentialise, or exploit inner @@ -830,48 +880,6 @@ dist_env <- ask let extra_scope = targetsScope $ distTargets acc' - stms <- liftInner $ - localScope extra_scope $ do - let maploop' = MapLoop pat' aux w lam' arrs - - exploitInnerParallelism path' = do - let dist_env' = - dist_env - { distOnTopLevelStms = onTopLevelStms path', - distOnInnerMap = onInnerMap path' - } - runDistNestT dist_env' . inNesting nest . localScope extra_scope $ - discardTargets - <$> distributeMap maploop' acc {distStms = mempty} - - -- Normally the permutation is for the output pattern, but - -- we can't really change that, so we change the result - -- order instead. - let lam_res' = - rearrangeShape (rearrangeInverse perm) $ - 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 - - -- XXX: we do not construct a new KernelPath when - -- sequentialising. This is only OK as long as further - -- versioning does not take place down that branch (it currently - -- does not). - (sequentialised_kernel, nestw_stms) <- localScope extra_scope $ do - let sequentialised_lam = soacsLambdaToGPU lam'' - constructKernel segThreadCapped nest' $ lambdaBody sequentialised_lam - - let outer_pat = loopNestingPat $ fst nest - (nestw_stms <>) - <$> onMap' - nest' - path - (const $ pure $ oneStm sequentialised_kernel) - exploitInnerParallelism - outer_pat - lam'' - + stms <- liftInner $ generate perm nest pat' lam' dist_env extra_scope postStm stms pure acc' 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 @@ -21,8 +21,8 @@ import Control.Monad.Writer import Futhark.Analysis.PrimExp import Futhark.IR +import Futhark.IR.Aliases (AliasableRep) import Futhark.IR.GPU.Op (SegVirt (..)) -import Futhark.IR.Prop.Aliases import Futhark.IR.SegOp import Futhark.MonadFreshNames import Futhark.Tools @@ -37,7 +37,7 @@ LetDec rep ~ Type, ExpDec rep ~ (), BodyDec rep ~ (), - CanBeAliased (Op rep) + AliasableRep rep ) data ThreadRecommendation = ManyThreads | NoRecommendation SegVirt 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 @@ -38,7 +38,7 @@ deriving (Eq, Ord, Show) numberOfGroups :: - (MonadBuilder m, Op (Rep m) ~ HostOp (Rep m) inner) => + (MonadBuilder m, Op (Rep m) ~ HostOp inner (Rep m)) => String -> SubExp -> SubExp -> diff --git a/src/Futhark/Pass/ExtractKernels/ToGPU.hs b/src/Futhark/Pass/ExtractKernels/ToGPU.hs --- a/src/Futhark/Pass/ExtractKernels/ToGPU.hs +++ b/src/Futhark/Pass/ExtractKernels/ToGPU.hs @@ -13,7 +13,6 @@ import Control.Monad.Identity import Data.List () -import Futhark.Analysis.Rephrase import Futhark.IR import Futhark.IR.GPU import Futhark.IR.SOACS (SOACS) @@ -21,7 +20,7 @@ import Futhark.Tools getSize :: - (MonadBuilder m, Op (Rep m) ~ HostOp (Rep m) inner) => + (MonadBuilder m, Op (Rep m) ~ HostOp inner (Rep m)) => String -> SizeClass -> m SubExp @@ -30,7 +29,7 @@ letSubExp desc $ Op $ SizeOp $ GetSize size_key size_class segThread :: - (MonadBuilder m, Op (Rep m) ~ HostOp (Rep m) inner) => + (MonadBuilder m, Op (Rep m) ~ HostOp inner (Rep m)) => String -> m SegLevel segThread desc = diff --git a/src/Futhark/Pass/ExtractMulticore.hs b/src/Futhark/Pass/ExtractMulticore.hs --- a/src/Futhark/Pass/ExtractMulticore.hs +++ b/src/Futhark/Pass/ExtractMulticore.hs @@ -9,7 +9,6 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bitraversable -import Futhark.Analysis.Rephrase import Futhark.IR import Futhark.IR.MC import Futhark.IR.MC qualified as MC diff --git a/src/Futhark/Pass/LiftAllocations.hs b/src/Futhark/Pass/LiftAllocations.hs --- a/src/Futhark/Pass/LiftAllocations.hs +++ b/src/Futhark/Pass/LiftAllocations.hs @@ -64,7 +64,10 @@ type LiftM inner a = Reader (Env inner) a -liftAllocationsInBody :: (Mem rep inner, LetDec rep ~ LetDecMem) => Body rep -> LiftM inner (Body rep) +liftAllocationsInBody :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + Body rep -> + LiftM (inner rep) (Body rep) liftAllocationsInBody body = do stms <- liftAllocationsInStms (bodyStms body) mempty mempty mempty pure $ body {bodyStms = stms} @@ -79,7 +82,7 @@ Stms rep -> -- | Names we need to lift Names -> - LiftM inner (Stms rep) + LiftM (inner rep) (Stms rep) liftAllocationsInStms Empty lifted acc _ = pure $ lifted <> acc liftAllocationsInStms (stms :|> stm@(Let (Pat [PatElem vname _]) _ (Op (Alloc _ _)))) lifted acc to_lift = liftAllocationsInStms stms (stm :<| lifted) acc ((freeIn stm <> to_lift) `namesSubtract` oneName vname) @@ -126,7 +129,7 @@ liftAllocationsInSegOp :: (Mem rep inner, LetDec rep ~ LetDecMem) => SegOp lvl rep -> - LiftM inner (SegOp lvl rep) + LiftM (inner rep) (SegOp lvl rep) liftAllocationsInSegOp (SegMap lvl sp tps body) = do stms <- liftAllocationsInStms (kernelBodyStms body) mempty mempty mempty pure $ SegMap lvl sp tps $ body {kernelBodyStms = stms} @@ -140,11 +143,11 @@ stms <- liftAllocationsInStms (kernelBodyStms body) mempty mempty mempty pure $ SegHist lvl sp histops tps $ body {kernelBodyStms = stms} -liftAllocationsInHostOp :: HostOp GPUMem () -> LiftM (HostOp GPUMem ()) (HostOp GPUMem ()) +liftAllocationsInHostOp :: HostOp NoOp GPUMem -> LiftM (HostOp NoOp GPUMem) (HostOp NoOp GPUMem) liftAllocationsInHostOp (SegOp op) = SegOp <$> liftAllocationsInSegOp op liftAllocationsInHostOp op = pure op -liftAllocationsInMCOp :: MCOp MCMem () -> LiftM (MCOp MCMem ()) (MCOp MCMem ()) +liftAllocationsInMCOp :: MCOp NoOp MCMem -> LiftM (MCOp NoOp MCMem) (MCOp NoOp MCMem) liftAllocationsInMCOp (ParOp par op) = ParOp <$> traverse liftAllocationsInSegOp par <*> liftAllocationsInSegOp op liftAllocationsInMCOp op = pure op diff --git a/src/Futhark/Pass/LowerAllocations.hs b/src/Futhark/Pass/LowerAllocations.hs --- a/src/Futhark/Pass/LowerAllocations.hs +++ b/src/Futhark/Pass/LowerAllocations.hs @@ -66,7 +66,10 @@ type LowerM inner a = Reader (Env inner) a -lowerAllocationsInBody :: (Mem rep inner, LetDec rep ~ LetDecMem) => Body rep -> LowerM inner (Body rep) +lowerAllocationsInBody :: + (Mem rep inner, LetDec rep ~ LetDecMem) => + Body rep -> + LowerM (inner rep) (Body rep) lowerAllocationsInBody body = do stms <- lowerAllocationsInStms (bodyStms body) mempty mempty pure $ body {bodyStms = stms} @@ -79,7 +82,7 @@ M.Map VName (Stm rep) -> -- | The other statements processed so far Stms rep -> - LowerM inner (Stms rep) + LowerM (inner rep) (Stms rep) lowerAllocationsInStms Empty allocs acc = pure $ acc <> Seq.fromList (M.elems allocs) lowerAllocationsInStms (stm@(Let (Pat [PatElem vname _]) _ (Op (Alloc _ _))) :<| stms) allocs acc = lowerAllocationsInStms stms (M.insert vname stm allocs) acc @@ -120,7 +123,7 @@ lowerAllocationsInSegOp :: (Mem rep inner, LetDec rep ~ LetDecMem) => SegOp lvl rep -> - LowerM inner (SegOp lvl rep) + LowerM (inner rep) (SegOp lvl rep) lowerAllocationsInSegOp (SegMap lvl sp tps body) = do stms <- lowerAllocationsInStms (kernelBodyStms body) mempty mempty pure $ SegMap lvl sp tps $ body {kernelBodyStms = stms} @@ -134,11 +137,11 @@ stms <- lowerAllocationsInStms (kernelBodyStms body) mempty mempty pure $ SegHist lvl sp histops tps $ body {kernelBodyStms = stms} -lowerAllocationsInHostOp :: HostOp GPUMem () -> LowerM (HostOp GPUMem ()) (HostOp GPUMem ()) +lowerAllocationsInHostOp :: HostOp NoOp GPUMem -> LowerM (HostOp NoOp GPUMem) (HostOp NoOp GPUMem) lowerAllocationsInHostOp (SegOp op) = SegOp <$> lowerAllocationsInSegOp op lowerAllocationsInHostOp op = pure op -lowerAllocationsInMCOp :: MCOp MCMem () -> LowerM (MCOp MCMem ()) (MCOp MCMem ()) +lowerAllocationsInMCOp :: MCOp NoOp MCMem -> LowerM (MCOp NoOp MCMem) (MCOp NoOp MCMem) lowerAllocationsInMCOp (ParOp par op) = ParOp <$> traverse lowerAllocationsInSegOp par <*> lowerAllocationsInSegOp op lowerAllocationsInMCOp op = pure op diff --git a/src/Futhark/Pipeline.hs b/src/Futhark/Pipeline.hs --- a/src/Futhark/Pipeline.hs +++ b/src/Futhark/Pipeline.hs @@ -23,11 +23,13 @@ where import Control.Category +import Control.Exception (SomeException, catch, throwIO) import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer.Strict hiding (pass) +import Control.Parallel import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Time.Clock @@ -81,14 +83,33 @@ modify $ \s -> s {futharkPrevLog = now} when verb $ liftIO $ T.hPutStrLn stderr $ T.pack prefix <> msg +runFutharkM' :: + FutharkM a -> + FutharkState -> + FutharkEnv -> + IO (Either CompilerError a, FutharkState) +runFutharkM' (FutharkM m) s = + runReaderT (runStateT (runExceptT m) s) + -- | Run a 'FutharkM' action. runFutharkM :: FutharkM a -> Verbosity -> IO (Either CompilerError a) -runFutharkM (FutharkM m) verbose = do +runFutharkM m verbose = do s <- FutharkState <$> getCurrentTime <*> pure blankNameSource - runReaderT (evalStateT (runExceptT m) s) newEnv - where - newEnv = FutharkEnv verbose + fst <$> runFutharkM' m s (FutharkEnv verbose) +catchIO :: FutharkM a -> (SomeException -> FutharkM a) -> FutharkM a +catchIO m f = FutharkM $ do + s <- get + env <- ask + (x, s') <- + liftIO $ + runFutharkM' m s env `catch` \e -> + runFutharkM' (f e) s env + put s' + case x of + Left e -> throwError e + Right x' -> pure x' + -- | A compilation always ends with some kind of action. data Action rep = Action { actionName :: String, @@ -105,14 +126,21 @@ -- | A compiler pipeline is conceptually a function from programs to -- programs, where the actual representation may change. Pipelines -- can be composed using their 'Category' instance. -newtype Pipeline fromrep torep = Pipeline {unPipeline :: PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)} +newtype Pipeline fromrep torep = Pipeline + { unPipeline :: + forall a. + PipelineConfig -> + Prog fromrep -> + FutharkM ((Prog torep -> FutharkM a) -> FutharkM a) + } instance Category Pipeline where - id = Pipeline $ const pure + id = Pipeline $ \_ prog -> pure $ \c -> c prog p2 . p1 = Pipeline perform where - perform cfg prog = - runPipeline p2 cfg =<< runPipeline p1 cfg prog + perform cfg prog = do + rc <- unPipeline p1 cfg prog + rc $ unPipeline p2 cfg -- | Run the pipeline on the given program. runPipeline :: @@ -120,7 +148,9 @@ PipelineConfig -> Prog fromrep -> FutharkM (Prog torep) -runPipeline = unPipeline +runPipeline p cfg prog = do + rc <- unPipeline p cfg prog + rc pure -- | Construct a pipeline from a single compiler pass. onePass :: @@ -130,16 +160,28 @@ onePass pass = Pipeline perform where perform cfg prog = do - when (pipelineVerbose cfg) $ - logMsg $ - "Running pass " <> T.pack (passName pass) + when (pipelineVerbose cfg) . logMsg $ + "Running pass " <> T.pack (passName pass) prog' <- runPass pass prog - let prog'' = Alias.aliasAnalysis prog' - when (pipelineValidate cfg) $ - case checkProg prog'' of - Left err -> validationError pass prog'' $ show err - Right () -> pure () - pure prog' + -- Spark validation in a separate task and speculatively execute + -- next pass. If the next pass throws an exception, we better + -- be ready to catch it and check if it might be because the + -- program was actually ill-typed. + let check = + if pipelineValidate cfg + then validate prog' + else Right () + par check $ pure $ \c -> + (errorOnError check pure =<< c prog') + `catchIO` errorOnError check (liftIO . throwIO) + validate prog = + let prog' = Alias.aliasAnalysis prog + in case checkProg prog' of + Left err -> Left (prog', err) + Right () -> Right () + errorOnError (Left (prog, err)) _ _ = + validationError pass prog $ show err + errorOnError _ c x = c x -- | Conditionally run pipeline if predicate is true. condPipeline :: @@ -148,7 +190,7 @@ Pipeline $ \cfg prog -> if cond prog then f cfg prog - else pure prog + else pure $ \c -> c prog -- | Create a pipeline from a list of passes. passes :: 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 @@ -6,7 +6,8 @@ pkgInfo, PkgRevInfo (..), GetManifest (getManifest), - downloadZipball, + GetFiles (getFiles), + CacheDir (..), -- * Package registry PkgRegistry, @@ -17,42 +18,27 @@ ) where -import Codec.Archive.Zip qualified as Zip +import Control.Monad (unless, void) import Control.Monad.IO.Class import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as LBS import Data.IORef import Data.List (foldl', intersperse) import Data.Map qualified as M import Data.Maybe import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) +import Data.Text.IO qualified as T +import Data.Time (UTCTime, defaultTimeLocale, formatTime) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Data.Time.LocalTime (zonedTimeToUTC) import Futhark.Pkg.Types -import Futhark.Util (maybeHead, showText) +import Futhark.Util (directoryContents, showText, zEncodeText) import Futhark.Util.Log +import System.Directory (doesDirectoryExist) import System.Exit -import System.FilePath.Posix qualified as Posix -import System.IO +import System.FilePath (makeRelative, ()) import System.Process.ByteString (readProcessWithExitCode) --- | Download URL via shelling out to @curl@. -curl :: String -> IO (Either String BS.ByteString) -curl url = do - (code, out, err) <- - -- The -L option follows HTTP redirects. - liftIO $ readProcessWithExitCode "curl" ["-L", url] mempty - case code of - ExitFailure 127 -> - pure $ - Left $ - "'" <> unwords ["curl", "-L", url] <> "' failed (program not found?)." - ExitFailure _ -> do - liftIO $ BS.hPutStr stderr err - pure $ Left $ "'" <> unwords ["curl", "-L", url] <> "' failed." - ExitSuccess -> - pure $ Right out - -- | The manifest is stored as a monadic action, because we want to -- fetch them on-demand. It would be a waste to fetch it information -- for every version of every package if we only actually need a small @@ -60,36 +46,40 @@ newtype GetManifest m = GetManifest {getManifest :: m PkgManifest} instance Show (GetManifest m) where - show _ = "#" + show _ = "#" instance Eq (GetManifest m) where _ == _ = True +-- | Get the absolute path to a package directory on disk, as well as +-- /relative/ paths to files that should be installed from this +-- package. Composing the package directory and one of these paths +-- refers to a local file (pointing into the cache) and is valid at +-- least until the next cache operation. +newtype GetFiles m = GetFiles {getFiles :: m (FilePath, [FilePath])} + +instance Show (GetFiles m) where + show _ = "#" + +instance Eq (GetFiles m) where + _ == _ = True + -- | Information about a version of a single package. The version -- number is stored separately. data PkgRevInfo m = PkgRevInfo - { pkgRevZipballUrl :: T.Text, - -- | The directory inside the zipball - -- containing the @lib@ directory, in - -- which the package files themselves - -- are stored (Based on the package - -- path). - pkgRevZipballDir :: FilePath, - -- | The commit ID can be used for - -- verification ("freezing"), by - -- storing what it was at the time this - -- version was last selected. + { pkgGetFiles :: GetFiles m, + -- | The commit ID can be used for verification ("freezing"), by + -- storing what it was at the time this version was last selected. pkgRevCommit :: T.Text, pkgRevGetManifest :: GetManifest m, - -- | Timestamp for when the revision - -- was made (rarely used). + -- | Timestamp for when the revision was made (rarely used). pkgRevTime :: UTCTime } deriving (Eq, Show) -- | Create memoisation around a 'GetManifest' action to ensure that -- multiple inspections of the same revisions will not result in --- potentially expensive network round trips. +-- potentially expensive IO operations. memoiseGetManifest :: MonadIO m => GetManifest m -> m (GetManifest m) memoiseGetManifest (GetManifest m) = do ref <- liftIO $ newIORef Nothing @@ -103,25 +93,6 @@ liftIO $ writeIORef ref $ Just v' pure v' --- | Download the zip archive corresponding to a specific package --- version. -downloadZipball :: - (MonadLogger m, MonadIO m, MonadFail m) => - PkgRevInfo m -> - m Zip.Archive -downloadZipball info = do - let url = pkgRevZipballUrl info - logMsg $ "Downloading " <> T.unpack url - - let bad = fail . (("When downloading " <> T.unpack url <> ": ") <>) - http <- liftIO $ curl $ T.unpack url - case http of - Left e -> bad e - Right r -> - case Zip.toArchiveOrFail $ LBS.fromStrict r of - Left e -> bad $ show e - Right a -> pure a - -- | Information about a package. The name of the package is stored -- separately. data PkgInfo m = PkgInfo @@ -135,238 +106,144 @@ lookupPkgRev :: SemVer -> PkgInfo m -> Maybe (PkgRevInfo m) lookupPkgRev v = M.lookup v . pkgVersions -majorRevOfPkg :: PkgPath -> (PkgPath, [Word]) +majorRevOfPkg :: PkgPath -> (T.Text, [Word]) majorRevOfPkg p = case T.splitOn "@" p of [p', v] | [(v', "")] <- reads $ T.unpack v -> (p', [v']) _ -> (p, [0, 1]) --- | Retrieve information about a package based on its package path. --- This uses Semantic Import Versioning when interacting with --- repositories. For example, a package @github.com/user/repo@ will --- match version 0.* or 1.* tags only, a package --- @github.com/user/repo/v2@ will match 2.* tags, and so forth.. -pkgInfo :: - (MonadIO m, MonadLogger m, MonadFail m) => - PkgPath -> - m (Either T.Text (PkgInfo m)) -pkgInfo path - | ["github.com", owner, repo] <- T.splitOn "/" path = - let (repo', vs) = majorRevOfPkg repo - in ghPkgInfo owner repo' vs - | "github.com" : owner : repo : _ <- T.splitOn "/" path = - pure $ - Left $ - T.intercalate - "\n" - [nope, "Do you perhaps mean 'github.com/" <> owner <> "/" <> repo <> "'?"] - | ["gitlab.com", owner, repo] <- T.splitOn "/" path = - let (repo', vs) = majorRevOfPkg repo - in glPkgInfo owner repo' vs - | "gitlab.com" : owner : repo : _ <- T.splitOn "/" path = - pure $ - Left $ - T.intercalate - "\n" - [nope, "Do you perhaps mean 'gitlab.com/" <> owner <> "/" <> repo <> "'?"] - | otherwise = - pure $ Left nope - where - nope = "Unable to handle package paths of the form '" <> path <> "'" - --- For GitHub, we unfortunately cannot use the (otherwise very nice) --- GitHub web API, because it is rate-limited to 60 requests per hour --- for non-authenticated users. Instead we fall back to a combination --- of calling 'git' directly and retrieving things from the GitHub --- webserver, which is not rate-limited. This approach is also used --- by other systems (Go most notably), so we should not be stepping on --- any toes. - -gitCmd :: (MonadIO m, MonadFail m) => [String] -> m BS.ByteString +gitCmd :: (MonadIO m, MonadLogger m, MonadFail m) => [String] -> m BS.ByteString gitCmd opts = do + logMsg $ "Running command: " <> T.unwords ("git" : map T.pack opts) (code, out, err) <- liftIO $ readProcessWithExitCode "git" opts mempty - liftIO $ BS.hPutStr stderr err + unless (err == mempty) $ logMsg $ T.decodeUtf8 err case code of ExitFailure 127 -> fail $ "'" <> unwords ("git" : opts) <> "' failed (program not found?)." ExitFailure _ -> fail $ "'" <> unwords ("git" : opts) <> "' failed." ExitSuccess -> pure out --- The GitLab and GitHub interactions are very similar, so we define a --- couple of generic functions that are used to implement support for --- both. - -ghglRevGetManifest :: - (MonadIO m, MonadLogger m, MonadFail m) => - T.Text -> - T.Text -> - T.Text -> - T.Text -> - GetManifest m -ghglRevGetManifest url owner repo tag = GetManifest $ do - logMsg $ "Downloading package manifest from " <> url +gitCmd_ :: (MonadIO m, MonadLogger m, MonadFail m) => [String] -> m () +gitCmd_ = void . gitCmd - let path = - T.unpack $ - owner - <> "/" - <> repo - <> "@" - <> tag - <> "/" - <> T.pack futharkPkg - msg = (("When reading " <> path <> ": ") <>) - http <- liftIO $ curl $ T.unpack url - case http of - Left e -> fail e - Right r' -> - case T.decodeUtf8' r' of - Left e -> fail $ msg $ show e - Right s -> - case parsePkgManifest path s of - Left e -> fail $ msg $ errorBundlePretty e - Right pm -> pure pm +gitCmdLines :: (MonadIO m, MonadLogger m, MonadFail m) => [String] -> m [T.Text] +gitCmdLines = fmap (T.lines . T.decodeUtf8) . gitCmd -ghglLookupCommit :: - (MonadIO m, MonadLogger m, MonadFail m) => - T.Text -> - T.Text -> - (T.Text -> T.Text) -> - T.Text -> - T.Text -> - T.Text -> - T.Text -> - T.Text -> - m (PkgRevInfo m) -ghglLookupCommit archive_url manifest_url mk_zip_dir owner repo d ref hash = do - gd <- memoiseGetManifest $ ghglRevGetManifest manifest_url owner repo ref - let dir = Posix.addTrailingPathSeparator $ T.unpack $ mk_zip_dir d - time <- liftIO getCurrentTime -- FIXME - pure $ PkgRevInfo archive_url dir hash gd time +-- | A temporary directory in which we store Git checkouts while +-- running. This is to avoid constantly re-cloning. Will be deleted +-- when @futhark pkg@ terminates. In principle we could keep this +-- around for longer, but then we would have to 'git pull' now and +-- then also. Note that the cache is stateful - we are going to use +-- @git checkout@ to move around the history. It is generally not +-- safe to have multiple operations running concurrently. +newtype CacheDir = CacheDir FilePath -ghglPkgInfo :: +ensureGit :: (MonadIO m, MonadLogger m, MonadFail m) => - T.Text -> - (T.Text -> T.Text) -> - (T.Text -> T.Text) -> - (T.Text -> T.Text) -> - T.Text -> + CacheDir -> T.Text -> - [Word] -> - m (Either T.Text (PkgInfo m)) -ghglPkgInfo repo_url mk_archive_url mk_manifest_url mk_zip_dir owner repo versions = do - logMsg $ "Retrieving list of tags from " <> repo_url - remote_lines <- T.lines . T.decodeUtf8 <$> gitCmd ["ls-remote", T.unpack repo_url] + m FilePath +ensureGit (CacheDir cachedir) url = do + exists <- liftIO $ doesDirectoryExist gitdir + unless exists $ + gitCmd_ ["-C", cachedir, "clone", "https://" <> T.unpack url, url'] + pure gitdir + where + url' = T.unpack $ zEncodeText url + gitdir = cachedir url' - head_ref <- - maybe (fail $ "Cannot find HEAD ref for " <> T.unpack repo_url) pure $ - maybeHead $ - mapMaybe isHeadRef remote_lines - let def = fromMaybe head_ref +-- A git reference (tag, commit, HEAD, etc). +type Ref = String - rev_info <- M.fromList . catMaybes <$> mapM revInfo remote_lines +versionRef :: SemVer -> Ref +versionRef v = T.unpack $ "v" <> prettySemVer v +revInfo :: + (MonadIO m, MonadLogger m, MonadFail m) => + FilePath -> + PkgPath -> + Ref -> + m (PkgRevInfo m) +revInfo gitdir path ref = do + gitCmd_ ["-C", gitdir, "rev-parse", ref, "--"] + [sha] <- gitCmdLines ["-C", gitdir, "rev-list", "-n1", ref] + [time] <- gitCmdLines ["-C", gitdir, "show", "-s", "--format=%cI", ref] + utc <- zonedTimeToUTC <$> iso8601ParseM (T.unpack time) + gm <- memoiseGetManifest getManifest' pure $ - Right $ - PkgInfo rev_info $ \r -> - ghglLookupCommit - (mk_archive_url (def r)) - (mk_manifest_url (def r)) - mk_zip_dir - owner - repo - (def r) - (def r) - (def r) + PkgRevInfo + { pkgGetFiles = getFiles gm, + pkgRevCommit = sha, + pkgRevGetManifest = gm, + pkgRevTime = utc + } where - isHeadRef l - | [hash, "HEAD"] <- T.words l = Just hash - | otherwise = Nothing + noPkgDir pdir = + fail $ + T.unpack path + <> "-" + <> ref + <> " does not contain a directory " + <> pdir - revInfo l - | [hash, ref] <- T.words l, - ["refs", "tags", t] <- T.splitOn "/" ref, - "v" `T.isPrefixOf` t, - Right v <- parseVersion $ T.drop 1 t, - _svMajor v `elem` versions = do - pinfo <- - ghglLookupCommit - (mk_archive_url t) - (mk_manifest_url t) - mk_zip_dir - owner - repo - (prettySemVer v) - t - hash - pure $ Just (v, pinfo) - | otherwise = pure Nothing + noPkgPath = + fail $ + "futhark.pkg for " + <> T.unpack path + <> "-" + <> ref + <> " does not define a package path." -ghPkgInfo :: - (MonadIO m, MonadLogger m, MonadFail m) => - T.Text -> - T.Text -> - [Word] -> - m (Either T.Text (PkgInfo m)) -ghPkgInfo owner repo versions = - ghglPkgInfo - repo_url - mk_archive_url - mk_manifest_url - mk_zip_dir - owner - repo - versions - where - repo_url = "https://github.com/" <> owner <> "/" <> repo - mk_archive_url r = repo_url <> "/archive/" <> r <> ".zip" - mk_manifest_url r = - "https://raw.githubusercontent.com/" - <> owner - <> "/" - <> repo - <> "/" - <> r - <> "/" - <> T.pack futharkPkg - mk_zip_dir r = repo <> "-" <> r + getFiles gm = GetFiles $ do + gitCmd_ ["-C", gitdir, "checkout", ref, "--"] + pdir <- maybe noPkgPath pure . pkgDir =<< getManifest gm + let pdir_abs = gitdir pdir + exists <- liftIO $ doesDirectoryExist pdir_abs + unless exists $ noPkgDir pdir + fs <- liftIO $ directoryContents pdir_abs + pure (pdir_abs, map (makeRelative pdir_abs) fs) -glPkgInfo :: + getManifest' = GetManifest $ do + gitCmd_ ["-C", gitdir, "checkout", ref, "--"] + let f = gitdir futharkPkg + s <- liftIO $ T.readFile f + let msg = + "When reading package manifest for " + <> T.unpack path + <> " " + <> ref + <> ":\n" + case parsePkgManifest f s of + Left e -> fail $ msg <> errorBundlePretty e + Right pm -> pure pm + +-- | Retrieve information about a package based on its package path. +-- This uses Semantic Import Versioning when interacting with +-- repositories. For example, a package @github.com/user/repo@ will +-- match version 0.* or 1.* tags only, a package +-- @github.com/user/repo/v2@ will match 2.* tags, and so forth.. +pkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) => - T.Text -> - T.Text -> - [Word] -> - m (Either T.Text (PkgInfo m)) -glPkgInfo owner repo versions = - ghglPkgInfo - repo_url - mk_archive_url - mk_manifest_url - mk_zip_dir - owner - repo - versions + CacheDir -> + PkgPath -> + m (PkgInfo m) +pkgInfo cachedir path = do + gitdir <- ensureGit cachedir url + versions <- mapMaybe isVersionRef <$> gitCmdLines ["-C", gitdir, "tag"] + versions' <- + M.fromList . zip versions + <$> mapM (revInfo gitdir path . versionRef) versions + pure $ PkgInfo versions' $ lookupCommit gitdir where - base_url = "https://gitlab.com/" <> owner <> "/" <> repo - repo_url = base_url <> ".git" - mk_archive_url r = - base_url - <> "/-/archive/" - <> r - <> "/" - <> repo - <> "-" - <> r - <> ".zip" - mk_manifest_url r = - base_url - <> "/raw/" - <> r - <> "/" - <> T.pack futharkPkg - mk_zip_dir r - | Right _ <- parseVersion r = repo <> "-v" <> r - | otherwise = repo <> "-" <> r + (url, path_versions) = majorRevOfPkg path + isVersionRef l + | "v" `T.isPrefixOf` l, + Right v <- parseVersion $ T.drop 1 l, + _svMajor v `elem` path_versions = + Just v + | otherwise = Nothing + lookupCommit gitdir = revInfo gitdir path . maybe "HEAD" T.unpack + -- | A package registry is a mapping from package paths to information -- about the package. It is unlikely that any given registry is -- global; rather small registries are constructed on-demand based on @@ -395,28 +272,27 @@ -- | Given a package path, look up information about that package. lookupPackage :: MonadPkgRegistry m => + CacheDir -> PkgPath -> m (PkgInfo m) -lookupPackage p = do +lookupPackage cachedir p = do r@(PkgRegistry m) <- getPkgRegistry case lookupKnownPackage p r of Just info -> pure info Nothing -> do - e <- pkgInfo p - case e of - Left e' -> fail $ T.unpack e' - Right pinfo -> do - putPkgRegistry $ PkgRegistry $ M.insert p pinfo m - pure pinfo + pinfo <- pkgInfo cachedir p + putPkgRegistry $ PkgRegistry $ M.insert p pinfo m + pure pinfo lookupPackageCommit :: MonadPkgRegistry m => + CacheDir -> PkgPath -> Maybe T.Text -> m (SemVer, PkgRevInfo m) -lookupPackageCommit p ref = do - pinfo <- lookupPackage p +lookupPackageCommit cachedir p ref = do + pinfo <- lookupPackage cachedir p rev_info <- pkgLookupCommit pinfo ref let timestamp = T.pack $ @@ -431,14 +307,15 @@ -- | Look up information about a specific version of a package. lookupPackageRev :: MonadPkgRegistry m => + CacheDir -> PkgPath -> SemVer -> m (PkgRevInfo m) -lookupPackageRev p v +lookupPackageRev cachedir p v | Just commit <- isCommitVersion v = - snd <$> lookupPackageCommit p (Just commit) + snd <$> lookupPackageCommit cachedir p (Just commit) | otherwise = do - pinfo <- lookupPackage p + pinfo <- lookupPackage cachedir p case lookupPkgRev v pinfo of Nothing -> let versions = case M.keys $ pkgVersions pinfo of @@ -470,12 +347,13 @@ -- | Find the newest version of a package. lookupNewestRev :: MonadPkgRegistry m => + CacheDir -> PkgPath -> m SemVer -lookupNewestRev p = do - pinfo <- lookupPackage p +lookupNewestRev cachedir p = do + pinfo <- lookupPackage cachedir p case M.keys $ pkgVersions pinfo of [] -> do logMsg $ "Package " <> p <> " has no released versions. Using HEAD." - fst <$> lookupPackageCommit p Nothing + fst <$> lookupPackageCommit cachedir p Nothing v : vs -> pure $ foldl' max v vs diff --git a/src/Futhark/Pkg/Solve.hs b/src/Futhark/Pkg/Solve.hs --- a/src/Futhark/Pkg/Solve.hs +++ b/src/Futhark/Pkg/Solve.hs @@ -75,9 +75,10 @@ -- a cache of the lookups performed, as well as a build list. solveDeps :: MonadPkgRegistry m => + CacheDir -> PkgRevDeps -> m BuildList -solveDeps deps = +solveDeps cachedir deps = buildList (depRoots deps) <$> runF (execStateT (doSolveDeps deps) emptyRoughBuildList) @@ -85,7 +86,7 @@ step where step (OpGetDeps p v h c) = do - pinfo <- lookupPackageRev p v + pinfo <- lookupPackageRev cachedir p v checkHash p v pinfo h diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs --- a/src/Futhark/Script.hs +++ b/src/Futhark/Script.hs @@ -22,6 +22,7 @@ -- * Evaluation EvalBuiltin, + scriptBuiltin, evalExp, getExpValue, evalExpToGround, @@ -32,6 +33,7 @@ import Control.Monad.Except import Data.Bifunctor (bimap) +import Data.ByteString.Lazy qualified as LBS import Data.Char import Data.Foldable (toList) import Data.Functor @@ -42,6 +44,7 @@ import Data.Text qualified as T import Data.Traversable import Data.Void +import Data.Word (Word8) import Futhark.Data.Parser qualified as V import Futhark.Server import Futhark.Server.Values (getValue, putValue) @@ -50,6 +53,7 @@ import Futhark.Util.Pretty hiding (line, sep, space, ()) import Language.Futhark.Core (Name, nameFromText, nameToText) import Language.Futhark.Tuple (areTupleFields) +import System.FilePath (()) import Text.Megaparsec import Text.Megaparsec.Char (space) import Text.Megaparsec.Char.Lexer (charLiteral) @@ -289,6 +293,38 @@ -- | How to evaluate a builtin function. type EvalBuiltin m = T.Text -> [V.CompoundValue] -> m V.CompoundValue + +loadData :: + (MonadIO m, MonadError T.Text m) => + FilePath -> + m (V.Compound V.Value) +loadData datafile = do + contents <- liftIO $ LBS.readFile datafile + let maybe_vs = V.readValues contents + case maybe_vs of + Nothing -> + throwError $ "Failed to read data file " <> T.pack datafile + Just [v] -> + pure $ V.ValueAtom v + Just vs -> + pure $ V.ValueTuple $ map V.ValueAtom vs + +-- | Handles the following builtin functions: @loaddata@. Fails for +-- everything else. The 'FilePath' indicates the directory that files +-- should be read relative to. +scriptBuiltin :: (MonadIO m, MonadError T.Text m) => FilePath -> EvalBuiltin m +scriptBuiltin dir "loaddata" vs = + case vs of + [V.ValueAtom v] + | Just path <- V.getValue v -> do + let path' = map (chr . fromIntegral) (path :: [Word8]) + loadData $ dir path' + _ -> + throwError $ + "$loaddata does not accept arguments of types: " + <> T.intercalate ", " (map (prettyText . fmap V.valueType) vs) +scriptBuiltin _ f _ = + throwError $ "Unknown builtin function $" <> prettyText f -- | Symbol table used for local variable lookups during expression evaluation. type VTable = M.Map VarName ExpValue diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -215,13 +215,10 @@ mapM_ (BS.hPutStr tmpf_h . Bin.encode) vs hClose tmpf_h cmdRestore server tmpf names_and_types -valuesAsVars server names_and_types _ _ (ScriptValues e) = +valuesAsVars server names_and_types _ dir (ScriptValues e) = Script.withScriptServer' server $ \server' -> do - e_v <- Script.evalExp noBuiltin server' e + e_v <- Script.evalExp (Script.scriptBuiltin dir) server' e scriptValueAsVars server names_and_types e_v - where - noBuiltin f _ = do - throwError $ "Unknown builtin procedure: " <> f valuesAsVars server names_and_types futhark dir (ScriptFile f) = do e <- either throwError pure . Script.parseExpFromText f @@ -264,7 +261,8 @@ genValues :: FutharkExe -> [GenValue] -> IO SBS.ByteString genValues (FutharkExe futhark) gens = do - (code, stdout, stderr) <- readProcessWithExitCode futhark ("dataset" : args) mempty + (code, stdout, stderr) <- + readProcessWithExitCode futhark ("dataset" : map T.unpack args) mempty case code of ExitSuccess -> pure stdout @@ -279,7 +277,7 @@ argForGen g = ["-g", genValueType g] genFileName :: GenValue -> FilePath -genFileName gen = genValueType gen ++ ".in" +genFileName gen = T.unpack (genValueType gen) <> ".in" -- | Compute the expected size of the file. We use this to check -- whether an existing file is broken/truncated. @@ -304,7 +302,7 @@ <> ":" <> T.unpack entry <> "-" - <> map clean (runDescription tr) + <> map clean (T.unpack (runDescription tr)) <.> "out" where clean '/' = '_' -- Would this ever happen? 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 @@ -27,7 +27,7 @@ import Control.Monad import Data.Char import Data.Functor -import Data.List (foldl') +import Data.List (foldl', (\\)) import Data.Map.Strict qualified as M import Data.Maybe import Data.Text qualified as T @@ -38,7 +38,7 @@ import Futhark.Data.Parser qualified as V import Futhark.Script qualified as Script import Futhark.Test.Values qualified as V -import Futhark.Util (directoryContents) +import Futhark.Util (directoryContents, nubOrd, showText) import Futhark.Util.Pretty (prettyTextOneLine) import System.Exit import System.FilePath @@ -46,6 +46,7 @@ import System.IO.Error import Text.Megaparsec hiding (many, some) import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer (charLiteral) import Text.Regex.TDFA import Prelude @@ -112,7 +113,7 @@ runInput :: Values, runExpectedResult :: ExpectedResult Success, runIndex :: Int, - runDescription :: String + runDescription :: T.Text } deriving (Show) @@ -137,11 +138,11 @@ -- | A prettyprinted representation of type of value produced by a -- 'GenValue'. -genValueType :: GenValue -> String +genValueType :: GenValue -> T.Text genValueType (GenValue (V.ValueType ds t)) = - concatMap (\d -> "[" ++ show d ++ "]") ds ++ T.unpack (V.primTypeText t) + foldMap (\d -> "[" <> showText d <> "]") ds <> V.primTypeText t genValueType (GenPrim v) = - T.unpack $ V.valueText v + V.valueText v -- | How a test case is expected to terminate. data ExpectedResult values @@ -240,6 +241,10 @@ guard $ s `notElem` ["input", "structure", "warning"] pure s +parseStringLiteral :: Parser () -> Parser T.Text +parseStringLiteral sep = + lexeme sep . fmap T.pack $ char '"' >> manyTill charLiteral (char '"') + parseRunCases :: Parser () -> Parser [TestRun] parseRunCases sep = parseRunCases' (0 :: Int) where @@ -247,6 +252,7 @@ (:) <$> parseRunCase i <*> parseRunCases' (i + 1) <|> pure [] parseRunCase i = do + name <- optional $ parseStringLiteral sep tags <- parseRunTags void $ lexeme sep "input" input <- @@ -257,7 +263,7 @@ then parseScriptValues sep else parseValues sep expr <- parseExpectedResult sep - pure $ TestRun tags input expr i $ desc i input + pure $ TestRun tags input expr i $ fromMaybe (desc i input) name -- If the file is gzipped, we strip the 'gz' extension from -- the dataset name. This makes it more convenient to rename @@ -265,22 +271,22 @@ -- does not change (which would make comparisons to historical -- data harder). desc _ (InFile path) - | takeExtension path == ".gz" = dropExtension path - | otherwise = path + | takeExtension path == ".gz" = T.pack $ dropExtension path + | otherwise = T.pack path desc i (Values vs) = -- Turn linebreaks into space. - "#" ++ show i ++ " (\"" ++ unwords (lines vs') ++ "\")" + "#" <> showText i <> " (\"" <> T.unwords (T.lines vs') <> "\")" where - vs' = case unwords $ map (T.unpack . V.valueText) vs of + vs' = case T.unwords $ map V.valueText vs of s - | length s > 50 -> take 50 s ++ "..." + | T.length s > 50 -> T.take 50 s <> "..." | otherwise -> s desc _ (GenValues gens) = - unwords $ map genValueType gens + T.unwords $ map genValueType gens desc _ (ScriptValues e) = - T.unpack $ prettyTextOneLine e + prettyTextOneLine e desc _ (ScriptFile path) = - path + T.pack path parseExpectedResult :: Parser () -> Parser (ExpectedResult Success) parseExpectedResult sep = @@ -395,10 +401,25 @@ pInputOutputs = "--" *> sep *> parseDescription sep *> parseInputOutputs sep <* pEndOfTestBlock +validate :: FilePath -> ProgramTest -> Either String ProgramTest +validate path pt = do + case testAction pt of + CompileTimeFailure {} -> pure pt + RunCases ios _ _ -> do + mapM_ (noDups . map runDescription . iosTestRuns) ios + Right pt + where + noDups xs = + let xs' = nubOrd xs + in -- Works because \\ only removes first instance. + case xs \\ xs' of + [] -> Right () + x : _ -> Left $ path <> ": multiple datasets with name " <> show (T.unpack x) + -- | Read the test specification from the given Futhark program. testSpecFromProgram :: FilePath -> IO (Either String ProgramTest) testSpecFromProgram path = - ( either (Left . errorBundlePretty) Right . parse pProgramTest path + ( either (Left . errorBundlePretty) (validate path) . parse pProgramTest path <$> T.readFile path ) `catch` couldNotRead 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 @@ -35,7 +35,7 @@ BuilderOps rep, LetDec SOACS ~ LetDec rep, LParamInfo SOACS ~ LParamInfo rep, - CanBeAliased (Op rep) + Alias.AliasableRep rep ) -- | First-order-transform a single function, with the given scope @@ -69,7 +69,7 @@ Buildable (Rep m), BuilderOps (Rep m), LParamInfo SOACS ~ LParamInfo (Rep m), - CanBeAliased (Op (Rep m)) + Alias.AliasableRep (Rep m) ) transformBody :: @@ -375,7 +375,7 @@ LocalScope somerep m, SameScope somerep rep, LetDec rep ~ LetDec SOACS, - CanBeAliased (Op rep) + Alias.AliasableRep rep ) => Lambda SOACS -> m (AST.Lambda rep) diff --git a/src/Futhark/Transform/Rename.hs b/src/Futhark/Transform/Rename.hs --- a/src/Futhark/Transform/Rename.hs +++ b/src/Futhark/Transform/Rename.hs @@ -325,6 +325,9 @@ instance Rename () where rename = pure +instance Rename (NoOp rep) where + rename NoOp = pure NoOp + instance Rename d => Rename (DimIndex d) where rename (DimFix i) = DimFix <$> rename i rename (DimSlice i n s) = DimSlice <$> rename i <*> rename n <*> rename s diff --git a/src/Futhark/Transform/Substitute.hs b/src/Futhark/Transform/Substitute.hs --- a/src/Futhark/Transform/Substitute.hs +++ b/src/Futhark/Transform/Substitute.hs @@ -138,6 +138,9 @@ instance Substitute () where substituteNames _ = id +instance Substitute (NoOp rep) where + substituteNames _ = id + instance Substitute d => Substitute (ShapeBase d) where substituteNames substs (Shape es) = Shape $ map (substituteNames substs) es diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -437,9 +437,9 @@ -- | Truncate to at most this many characters, making the last three -- characters "..." if truncation is necessary. -atMostChars :: Int -> String -> String +atMostChars :: Int -> T.Text -> T.Text atMostChars n s - | length s > n = take (n - 3) s ++ "..." + | T.length s > n = T.take (n - 3) s <> "..." | otherwise = s -- | Invert a map, handling duplicate values (now keys) by diff --git a/src/Futhark/Util/Log.hs b/src/Futhark/Util/Log.hs --- a/src/Futhark/Util/Log.hs +++ b/src/Futhark/Util/Log.hs @@ -13,6 +13,8 @@ import Control.Monad.Writer import Data.DList qualified as DL import Data.Text qualified as T +import Data.Text.IO qualified as T +import System.IO (stderr) -- | An efficiently catenable sequence of log entries. newtype Log = Log {unLog :: DL.DList T.Text} @@ -55,3 +57,6 @@ instance Monad m => MonadLogger (Control.Monad.RWS.Strict.RWST r Log s m) where addLog = tell + +instance MonadLogger IO where + addLog = mapM_ (T.hPutStrLn stderr) . unLog 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 @@ -348,12 +348,11 @@ T.envVtable = vtable } -break :: Loc -> EvalM () -break loc = do - backtrace <- asks fst - case NE.nonEmpty backtrace of - Nothing -> pure () - Just backtrace' -> liftF $ ExtOpBreak loc BreakPoint backtrace' () +break :: Env -> Loc -> EvalM () +break env loc = do + imports <- asks snd + backtrace <- asks ((StackFrame loc (Ctx env imports) NE.:|) . fst) + liftF $ ExtOpBreak loc BreakPoint backtrace () fromArray :: Value -> (ValueShape, [Value]) fromArray (ValueArray shape as) = (shape, elems as) @@ -800,7 +799,7 @@ let t = T.BoundV [] $ toStruct $ unInfo $ identType dest eval (valEnv (M.singleton (identName dest) (Just t, dest')) <> env) body where - oob = bad loc env "Bad update" + oob = bad loc env "Update out of bounds" evalAppExp env _ (DoLoop sparams pat init_e form body _) = do init_v <- eval env init_e case form of @@ -991,7 +990,7 @@ shape <- typeValueShape env $ toStruct t pure $ ValueSum shape c vs eval env (Attr (AttrAtom (AtomName "break") _) e loc) = do - break (locOf loc) + break env (locOf loc) eval env e eval env (Attr (AttrAtom (AtomName "trace") _) e loc) = do v <- eval env e diff --git a/src/Language/Futhark/Interpreter/Values.hs b/src/Language/Futhark/Interpreter/Values.hs --- a/src/Language/Futhark/Interpreter/Values.hs +++ b/src/Language/Futhark/Interpreter/Values.hs @@ -227,10 +227,12 @@ SVec.Vector Int -> SVec.Vector a -> Value m -fromDataValueWith f shape vector = - if SVec.null shape - then ValuePrim $ f $ SVec.head vector - else +fromDataValueWith f shape vector + | SVec.null shape = ValuePrim $ f $ SVec.head vector + | SVec.null vector = + toArray (fromDataShape shape) $ + replicate (SVec.head shape) (fromDataValueWith f shape' vector) + | otherwise = toArray (fromDataShape shape) . map (fromDataValueWith f shape' . SVec.fromList) $ chunk (SVec.product shape') (SVec.toList vector) diff --git a/src/Language/Futhark/Parser/Lexer.x b/src/Language/Futhark/Parser/Lexer.x --- a/src/Language/Futhark/Parser/Lexer.x +++ b/src/Language/Futhark/Parser/Lexer.x @@ -102,10 +102,10 @@ @intlit u64 { tokenM $ pure . U64LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='u') } @intlit { tokenM $ pure . INTLIT . readIntegral . T.filter (/= '_') } - [^\.] ^ @reallit f16 { tokenM $ fmap F16LIT . tryRead "f16" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } - [^\.] ^ @reallit f32 { tokenM $ fmap F32LIT . tryRead "f32" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } - [^\.] ^ @reallit f64 { tokenM $ fmap F64LIT . tryRead "f64" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } - [^\.] ^ @reallit { tokenM $ fmap FLOATLIT . tryRead "f64" . suffZero . T.filter (/= '_') } + [\n[^\.]] ^ @reallit f16 { tokenM $ fmap F16LIT . tryRead "f16" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } + [\n[^\.]] ^ @reallit f32 { tokenM $ fmap F32LIT . tryRead "f32" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } + [\n[^\.]] ^ @reallit f64 { tokenM $ fmap F64LIT . tryRead "f64" . suffZero . T.filter (/= '_') . T.takeWhile (/='f') } + [\n[^\.]] ^ @reallit { tokenM $ fmap FLOATLIT . tryRead "f64" . suffZero . T.filter (/= '_') } @hexreallit f16 { tokenM $ fmap F16LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 } @hexreallit f32 { tokenM $ fmap F32LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 } @hexreallit f64 { tokenM $ fmap F64LIT . readHexRealLit . T.filter (/= '_') . T.dropEnd 3 } 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 @@ -124,6 +124,8 @@ '^...' { L _ (SYMBOL Xor _ _) } '||...' { L _ (SYMBOL LogOr _ _) } '&&...' { L _ (SYMBOL LogAnd _ _) } + '!...' { L _ (SYMBOL Bang _ _) } + '=...' { L _ (SYMBOL Equ _ _) } '(' { L $$ LPAR } ')' { L $$ RPAR } @@ -162,11 +164,12 @@ hole { L $$ HOLE } %left bottom +%left typeprec %left ifprec letprec caseprec typeprec enumprec sumprec %left ',' case id constructor '(' '{' %right ':' ':>' %right '...' '..<' '..>' '..' -%left '`' +%left '`' '!...' %right '->' %left with %left '=' @@ -174,14 +177,15 @@ %right '<|...' %left '||...' %left '&&...' -%left '<=...' '>=...' '>...' '<' '<...' '==...' '!=...' +%left '<=...' '>=...' '>...' '<' '<...' '==...' '!=...' '!...' '=...' %left '&...' '^...' '^' '|...' '|' %left '<<...' '>>...' %left '+...' '-...' '-' %left '*...' '*' '/...' '%...' '//...' '%%...' %left '**...' %left juxtprec -%left indexprec +%left '[' '...[' indexprec +%left top %% -- The main parser. @@ -379,6 +383,8 @@ | '<|...' { binOpName $1 } | '|>...' { binOpName $1 } | '<' { (qualName (nameFromString "<"), $1) } + | '!...' { binOpName $1 } + | '=...' { binOpName $1 } | '`' QualName '`' { $2 } BindingBinOp :: { Name } @@ -387,6 +393,7 @@ Just "Cannot use a qualified name in binding position." pure name } | '-' { nameFromString "-" } + | '!' {% parseErrorAt $1 $ Just $ "'!' is a prefix operator and cannot be used as infix operator." } BindingId :: { (Name, Loc) } : id { let L loc (ID name) = $1 in (name, loc) } @@ -455,28 +462,22 @@ TypeExpTerm :: { UncheckedTypeExp } : '*' TypeExpTerm { TEUnique $2 (srcspan $1 $>) } - | '[' SizeExp ']' TypeExpTerm %prec indexprec - { TEArray $2 $4 (srcspan $1 $>) } - | '...[' SizeExp ']' TypeExpTerm %prec indexprec - { TEArray $2 $4 (srcspan $1 $>) } - | TypeExpApply %prec sumprec { $1 } - | SumType { $1 } + | TypeExpApply %prec typeprec { $1 } + | SumClauses %prec sumprec + { let (cs, loc) = $1 in TESum cs (srclocOf loc) } -- Errors | '[' SizeExp ']' %prec bottom {% parseErrorAt (srcspan $1 $>) $ Just $ - T.unlines ["missing array row type.", + T.unlines ["Missing array row type.", "Did you mean []" <> prettyText $2 <> "?"] } | '...[' SizeExp ']' %prec bottom {% parseErrorAt (srcspan $1 $>) $ Just $ - T.unlines ["missing array row type.", + T.unlines ["Missing array row type.", "Did you mean []" <> prettyText $2 <> "?"] } -SumType :: { UncheckedTypeExp } -SumType : SumClauses %prec sumprec { let (cs, loc) = $1 in TESum cs (srclocOf loc) } - SumClauses :: { ([(Name, [UncheckedTypeExp])], Loc) } : SumClauses '|' SumClause %prec sumprec { let (cs, loc1) = $1; (c, ts, loc2) = $3 @@ -484,11 +485,13 @@ | SumClause %prec sumprec { let (n, ts, loc) = $1 in ([(n, ts)], loc) } +SumPayload :: { [UncheckedTypeExp] } + : %prec bottom { [] } + | TypeExpAtom SumPayload { $1 : $2 } + SumClause :: { (Name, [UncheckedTypeExp], Loc) } - : SumClause TypeExpAtom - { let (n, ts, loc) = $1 in (n, ts ++ [$2], locOf (srcspan loc $>))} - | Constr - { (fst $1, [], snd $1) } + : Constr SumPayload + { (fst $1, $2, locOf (srcspan (snd $1) $>)) } TypeExpApply :: { UncheckedTypeExp } : TypeExpApply TypeArg @@ -502,15 +505,22 @@ | '(' TypeExp ',' TupleTypes ')' { TETuple ($2:$4) (srcspan $1 $>) } | '{' '}' { TERecord [] (srcspan $1 $>) } | '{' FieldTypes1 '}' { TERecord $2 (srcspan $1 $>) } + | '[' SizeExp ']' TypeExpTerm + { TEArray $2 $4 (srcspan $1 $>) } + | '...[' SizeExp ']' TypeExpTerm + { TEArray $2 $4 (srcspan $1 $>) } | QualName { TEVar (fst $1) (srclocOf (snd $1)) } Constr :: { (Name, Loc) } : constructor { let L _ (CONSTRUCTOR c) = $1 in (c, locOf $1) } TypeArg :: { TypeArgExp Name } - : '[' SizeExp ']' { TypeArgExpDim $2 (srcspan $1 $>) } - | '...[' SizeExp ']' { TypeArgExpDim $2 (srcspan $1 $>) } - | TypeExpAtom { TypeArgExpType $1 } + : '[' SizeExp ']' %prec top + { TypeArgExpDim $2 (srcspan $1 $>) } + | '...[' SizeExp ']' %prec top + { TypeArgExpDim $2 (srcspan $1 $>) } + | TypeExpAtom + { TypeArgExpType $1 } FieldType :: { (Name, UncheckedTypeExp) } FieldType : FieldId ':' TypeExp { (fst $1, $3) } @@ -740,7 +750,9 @@ | Exp2 '>=...' Exp2 { binOp $1 $2 $3 } | Exp2 '|>...' Exp2 { binOp $1 $2 $3 } | Exp2 '<|...' Exp2 { binOp $1 $2 $3 } - | Exp2 '<' Exp2 { binOp $1 (L $2 (SYMBOL Less [] (nameFromString "<"))) $3 } + | Exp2 '<' Exp2 { binOp $1 (L $2 (SYMBOL Less [] (nameFromString "<"))) $3 } + | Exp2 '!...' Exp2 { binOp $1 $2 $3 } + | Exp2 '=...' Exp2 { binOp $1 $2 $3 } | Exp2 '`' QualName '`' Exp2 { AppExp (BinOp (second srclocOf $3) NoInfo ($1, NoInfo) ($5, NoInfo) (srcspan $1 $>)) NoInfo } SectionExp :: { UncheckedExp } 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Futhark prettyprinter. This module defines 'Pretty' instances @@ -157,7 +156,7 @@ prettyTypeArg _ (TypeArgDim d _) = pretty $ Shape [d] prettyTypeArg p (TypeArgType t _) = prettyType p t -instance Pretty (Shape dim) => Pretty (TypeArg dim) where +instance Pretty (TypeArg Size) where pretty = prettyTypeArg 0 instance (Eq vn, IsName vn) => Pretty (TypeExp vn) where @@ -367,7 +366,8 @@ p name = "." <> pretty name prettyExp _ (IndexSection idxs _ _) = parens $ "." <> brackets (commasep (map pretty idxs)) -prettyExp _ (Constr n cs _ _) = "#" <> pretty n <+> sep (map pretty cs) +prettyExp _ (Constr n cs t _) = + "#" <> pretty n <+> sep (map pretty cs) <> prettyInst t prettyExp _ (Attr attr e _) = prettyAttr attr prettyExp (-1) e prettyExp i (AppExp e _) = prettyAppExp i e @@ -564,6 +564,8 @@ precedence Xor = 1 precedence Equal = 2 precedence NotEqual = 2 + precedence Bang = 2 + precedence Equ = 2 precedence Less = 2 precedence Leq = 2 precedence Greater = 2 diff --git a/src/Language/Futhark/Primitive.hs b/src/Language/Futhark/Primitive.hs --- a/src/Language/Futhark/Primitive.hs +++ b/src/Language/Futhark/Primitive.hs @@ -135,6 +135,7 @@ import Futhark.Util (convFloat) import Futhark.Util.CMath import Futhark.Util.Pretty +import Numeric (log1p) import Numeric.Half import Prelude hiding (id, (.)) @@ -1193,6 +1194,10 @@ f16 "log10_16" (logBase 10), f32 "log10_32" (logBase 10), f64 "log10_64" (logBase 10), + -- + f16 "log1p_16" log1p, + f32 "log1p_32" log1p, + f64 "log1p_64" log1p, -- f16 "log2_16" (logBase 2), f32 "log2_32" (logBase 2), 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 @@ -192,8 +192,10 @@ uniqueness :: TypeBase shape as -> Uniqueness uniqueness (Array _ u _ _) = u uniqueness (Scalar (TypeVar _ u _ _)) = u -uniqueness (Scalar (Sum ts)) = foldMap (foldMap uniqueness) $ M.elems ts -uniqueness (Scalar (Record fs)) = foldMap uniqueness $ M.elems fs +uniqueness (Scalar (Sum ts)) + | any (any unique) ts = Unique +uniqueness (Scalar (Record fs)) + | any unique fs = Unique uniqueness _ = Nonunique -- | @unique t@ is 'True' if the type of the argument is unique. 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 @@ -80,8 +80,12 @@ data FileModule = FileModule { -- | Abstract types. fileAbs :: TySet, + -- | The environment made available when importing this module. fileEnv :: Env, - fileProg :: Prog + fileProg :: Prog, + -- | The environment at the bottom of the file. Includes local + -- parts. + fileScope :: Env } -- | A mapping from import names to imports. The ordering is significant. 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 @@ -497,8 +497,13 @@ = -- | A pseudo-operator standing in for any normal -- identifier used as an operator (they all have the -- same fixity). - -- Binary Ops for Numbers Backtick + | -- | Not a real operator, but operator with this as a prefix may + -- be defined by the user. + Bang + | -- | Not a real operator, but operator with this as a prefix + -- may be defined by the user. + Equ | Plus | Minus | Pow @@ -1236,6 +1241,8 @@ instance Pretty BinOp where pretty Backtick = "``" + pretty Bang = "!" + pretty Equ = "=" pretty Plus = "+" pretty Minus = "-" pretty Pow = "**" 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 @@ -219,8 +219,8 @@ <$> mapM (astMap tv) idxs <*> traverse (mapOnPatType tv) t <*> pure loc - astMap tv (Constr name es ts loc) = - Constr name <$> traverse (mapOnExp tv) es <*> traverse (mapOnPatType tv) ts <*> pure loc + astMap tv (Constr name es t loc) = + Constr name <$> traverse (mapOnExp tv) es <*> traverse (mapOnPatType tv) t <*> pure loc astMap tv (Attr attr e loc) = Attr attr <$> mapOnExp tv e <*> pure loc astMap tv (AppExp e res) = 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 @@ -143,8 +143,8 @@ checkProgM :: UncheckedProg -> TypeM FileModule checkProgM (Prog doc decs) = do checkForDuplicateDecs decs - (abs, env, decs') <- checkDecs decs - pure (FileModule abs env $ Prog doc decs') + (abs, env, decs', full_env) <- checkDecs decs + pure (FileModule abs env (Prog doc decs') full_env) dupDefinitionError :: MonadTypeChecker m => @@ -378,7 +378,7 @@ pure (abs, mty, ModParens e' loc) checkOneModExp (ModDecs decs loc) = do checkForDuplicateDecs decs - (abstypes, env, decs') <- checkDecs decs + (abstypes, env, decs', _) <- checkDecs decs pure ( abstypes, MTy abstypes $ ModEnv env, @@ -626,6 +626,51 @@ onRetType te t = ([], EntryType t te) +checkEntryPoint :: + SrcLoc -> + [TypeParam] -> + [Pat] -> + Maybe (TypeExp VName) -> + StructRetType -> + TypeM () +checkEntryPoint loc tparams params maybe_tdecl rettype + | any isTypeParam tparams = + typeError loc mempty $ + withIndexLink + "polymorphic-entry" + "Entry point functions may not be polymorphic." + | not (all patternOrderZero params) + || not (all orderZero rettype_params) + || not (orderZero rettype') = + typeError loc mempty $ + withIndexLink + "higher-order-entry" + "Entry point functions may not be higher-order." + | sizes_only_in_ret <- + S.fromList (map typeParamName tparams) + `S.intersection` freeInType rettype' + `S.difference` foldMap freeInType (map patternStructType params ++ rettype_params), + not $ S.null sizes_only_in_ret = + typeError loc mempty $ + withIndexLink + "size-polymorphic-entry" + "Entry point functions must not be size-polymorphic in their return type." + | p : _ <- filter nastyParameter params = + warn loc $ + "Entry point parameter\n" + indent 2 (pretty p) + "\nwill have an opaque type, so the entry point will likely not be callable." + | nastyReturnType maybe_tdecl rettype_t = + warn loc $ + "Entry point return type\n" + indent 2 (pretty rettype) + "\nwill have an opaque type, so the result will likely not be usable." + | otherwise = + pure () + where + (RetType _ rettype_t) = rettype + (rettype_params, rettype') = unfoldFunType rettype_t + checkValBind :: ValBindBase NoInfo Name -> TypeM (Env, ValBind) checkValBind (ValBind entry fname maybe_tdecl NoInfo tparams params body doc attrs loc) = do top_level <- atTopLevel @@ -633,45 +678,13 @@ typeError loc mempty $ withIndexLink "nested-entry" "Entry points may not be declared inside modules." - (fname', tparams', params', maybe_tdecl', rettype@(RetType _ rettype_t), body') <- + (fname', tparams', params', maybe_tdecl', rettype, body') <- checkFunDef (fname, maybe_tdecl, tparams, params, body, loc) - let (rettype_params, rettype') = unfoldFunType rettype_t - entry' = Info (entryPoint params' maybe_tdecl' rettype) <$ entry + let entry' = Info (entryPoint params' maybe_tdecl' rettype) <$ entry case entry' of - Just _ - | any isTypeParam tparams' -> - typeError loc mempty $ - withIndexLink - "polymorphic-entry" - "Entry point functions may not be polymorphic." - | not (all patternOrderZero params') - || not (all orderZero rettype_params) - || not (orderZero rettype') -> - typeError loc mempty $ - withIndexLink - "higher-order-entry" - "Entry point functions may not be higher-order." - | sizes_only_in_ret <- - S.fromList (map typeParamName tparams') - `S.intersection` freeInType rettype' - `S.difference` foldMap freeInType (map patternStructType params' ++ rettype_params), - not $ S.null sizes_only_in_ret -> - typeError loc mempty $ - withIndexLink - "size-polymorphic-entry" - "Entry point functions must not be size-polymorphic in their return type." - | p : _ <- filter nastyParameter params' -> - warn loc $ - "Entry point parameter\n" - indent 2 (pretty p) - "\nwill have an opaque type, so the entry point will likely not be callable." - | nastyReturnType maybe_tdecl' rettype_t -> - warn loc $ - "Entry point return type\n" - indent 2 (pretty rettype) - "\nwill have an opaque type, so the result will likely not be usable." + Just _ -> checkEntryPoint loc tparams' params' maybe_tdecl' rettype _ -> pure () attrs' <- mapM checkAttr attrs @@ -749,17 +762,19 @@ (env, vb') <- checkValBind vb pure (mempty, env, ValDec vb') -checkDecs :: [DecBase NoInfo Name] -> TypeM (TySet, Env, [DecBase Info VName]) +checkDecs :: [DecBase NoInfo Name] -> TypeM (TySet, Env, [DecBase Info VName], Env) checkDecs (d : ds) = do (d_abstypes, d_env, d') <- checkOneDec d - (ds_abstypes, ds_env, ds') <- localEnv d_env $ checkDecs ds + (ds_abstypes, ds_env, ds', full_env) <- localEnv d_env $ checkDecs ds pure ( d_abstypes <> ds_abstypes, case d' of LocalDec {} -> ds_env ImportDec {} -> ds_env _ -> ds_env <> d_env, - d' : ds' + d' : ds', + full_env ) -checkDecs [] = - pure (mempty, mempty, []) +checkDecs [] = do + full_env <- askEnv + pure (mempty, mempty, [], full_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 @@ -1438,6 +1438,8 @@ uniques = uniqueParamNames params delve (Scalar (Record fs)) = Scalar $ Record $ M.map delve fs + delve (Scalar (Sum cs)) = + Scalar $ Sum $ M.map (map delve) cs delve t' | all (`S.member` uniques) (boundArrayAliases t'), not $ any ((`S.member` forbidden) . aliasVar) (aliases t') = 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 @@ -172,8 +172,9 @@ allOccurring :: Occurrences -> Names allOccurring occs = allConsumed occs <> allObserved occs +-- | Find any consumption that references a variable in scope. anyConsumption :: Occurrences -> Maybe Occurrence -anyConsumption = find (isJust . consumed) +anyConsumption = find (maybe False (not . null) . consumed) seqOccurrences :: Occurrences -> Occurrences -> Occurrences seqOccurrences occurs1 occurs2 = @@ -304,7 +305,7 @@ "Cannot apply" <+> dquotes (pretty fname) <+> "to" - <+> dquotes (shorten $ group $ pretty e) <> " (invalid type)." + <+> dquotes (align $ shorten $ group $ pretty e) <> " (invalid type)." pretty (CheckingReturn expected actual) = "Function body does not have expected type." "Expected:" 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 @@ -283,7 +283,7 @@ t <- newTypeVar loc "t" pure $ Id name' (Info t) loc checkPat' _ (Wildcard _ loc) (Ascribed t) = - pure $ Wildcard (Info $ t `setUniqueness` Nonunique) loc + pure $ Wildcard (Info t) loc checkPat' _ (Wildcard NoInfo loc) NoneInferred = do t <- newTypeVar loc "t" pure $ Wildcard (Info t) loc @@ -364,7 +364,9 @@ pure $ PatConstr n (Info (Scalar (Sum cs))) ps' loc checkPat' sizes (PatConstr n NoInfo ps loc) (Ascribed t) = do t' <- newTypeVar loc "t" - ps' <- mapM (\p -> checkPat' sizes p NoneInferred) ps + ps' <- forM ps $ \p -> do + p_t <- newTypeVar (srclocOf p) "t" + checkPat' sizes p $ Ascribed $ addAliasesFromType p_t t mustHaveConstr usage n t' (patternStructType <$> ps') unify usage t' (toStruct t) t'' <- normTypeFully t 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 @@ -484,36 +484,44 @@ link (not ord) v2 lvl t1' ( Scalar (Arrow _ p1 a1 (RetType b1_dims b1)), Scalar (Arrow _ p2 a2 (RetType b2_dims b2)) - ) -> do - -- Introduce the existentials as size variables so they - -- are subject to unification. We will remove them again - -- afterwards. - let (r1, r2) = - swap - ord - (Size Nothing $ Usage Nothing mempty) - (UnknowableSize mempty RigidUnify) - lvl <- curLevel - modifyConstraints (M.fromList (zip b1_dims $ repeat (lvl, r1)) <>) - modifyConstraints (M.fromList (zip b2_dims $ repeat (lvl, r2)) <>) + ) + | uncurry (<) $ swap ord (uniqueness a1) (uniqueness a2) -> do + unifyError usage mempty bcs . withIndexLink "unify-consuming-param" $ + "Parameter types" + indent 2 (pretty a1) + "and" + indent 2 (pretty a2) + "are incompatible regarding consuming their arguments." + | otherwise -> do + -- Introduce the existentials as size variables so they + -- are subject to unification. We will remove them again + -- afterwards. + let (r1, r2) = + swap + ord + (Size Nothing $ Usage Nothing mempty) + (UnknowableSize mempty RigidUnify) + lvl <- curLevel + modifyConstraints (M.fromList (zip b1_dims $ repeat (lvl, r1)) <>) + modifyConstraints (M.fromList (zip b2_dims $ repeat (lvl, r2)) <>) - let bound' = bound <> mapMaybe pname [p1, p2] <> b1_dims <> b2_dims - subunify - (not ord) - bound - (breadCrumb (Matching "When matching parameter types.") bcs) - a1 - a2 - subunify - ord - bound' - (breadCrumb (Matching "When matching return types.") bcs) - b1' - b2' + let bound' = bound <> mapMaybe pname [p1, p2] <> b1_dims <> b2_dims + subunify + (not ord) + bound + (breadCrumb (Matching "When matching parameter types.") bcs) + a1 + a2 + subunify + ord + bound' + (breadCrumb (Matching "When matching return types.") bcs) + b1' + b2' - -- Delete the size variables we introduced to represent - -- the existential sizes. - modifyConstraints $ \m -> foldl' (flip M.delete) m (b1_dims <> b2_dims) + -- Delete the size variables we introduced to represent + -- the existential sizes. + modifyConstraints $ \m -> foldl' (flip M.delete) m (b1_dims <> b2_dims) where (b1', b2') = -- Replace one parameter name with the other in the diff --git a/unittests/Futhark/BenchTests.hs b/unittests/Futhark/BenchTests.hs --- a/unittests/Futhark/BenchTests.hs +++ b/unittests/Futhark/BenchTests.hs @@ -17,7 +17,7 @@ instance Arbitrary DataResult where arbitrary = DataResult - <$> printable + <$> (T.pack <$> printable) <*> oneof [ Left <$> arbText, Right