futhark 0.15.6 → 0.15.7
raw patch · 103 files changed
+2118/−1203 lines, 103 files
Files
- docs/c-api.rst +328/−0
- docs/index.rst +1/−0
- docs/man/futhark-cuda.rst +4/−3
- docs/man/futhark-opencl.rst +4/−3
- docs/usage.rst +7/−17
- futhark.cabal +1/−1
- rts/c/cuda.h +14/−41
- rts/c/opencl.h +13/−32
- rts/c/panic.h +0/−30
- rts/c/util.h +100/−0
- rts/csharp/scalar.cs +15/−0
- src/Futhark/Actions.hs +7/−0
- src/Futhark/Analysis/HORepresentation/MapNest.hs +1/−1
- src/Futhark/Analysis/HORepresentation/SOAC.hs +7/−14
- src/Futhark/Analysis/PrimExp.hs +9/−3
- src/Futhark/Analysis/ScalExp.hs +4/−4
- src/Futhark/CLI/Autotune.hs +2/−0
- src/Futhark/CLI/Bench.hs +2/−2
- src/Futhark/CLI/C.hs +2/−0
- src/Futhark/CLI/CSOpenCL.hs +2/−0
- src/Futhark/CLI/CSharp.hs +2/−0
- src/Futhark/CLI/CUDA.hs +2/−0
- src/Futhark/CLI/Check.hs +2/−0
- src/Futhark/CLI/Datacmp.hs +2/−0
- src/Futhark/CLI/Dataset.hs +2/−2
- src/Futhark/CLI/Dev.hs +20/−1
- src/Futhark/CLI/Doc.hs +2/−0
- src/Futhark/CLI/Misc.hs +3/−1
- src/Futhark/CLI/OpenCL.hs +2/−0
- src/Futhark/CLI/Pkg.hs +13/−11
- src/Futhark/CLI/PyOpenCL.hs +2/−0
- src/Futhark/CLI/Python.hs +2/−0
- src/Futhark/CLI/Query.hs +2/−0
- src/Futhark/CLI/REPL.hs +2/−0
- src/Futhark/CLI/Run.hs +2/−0
- src/Futhark/CLI/Test.hs +2/−2
- src/Futhark/CodeGen/Backends/CCUDA.hs +1/−0
- src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +8/−18
- src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +17/−33
- src/Futhark/CodeGen/Backends/GenericC.hs +216/−96
- src/Futhark/CodeGen/Backends/SequentialC.hs +9/−18
- src/Futhark/CodeGen/ImpCode.hs +33/−0
- src/Futhark/CodeGen/ImpCode/Kernels.hs +0/−1
- src/Futhark/CodeGen/ImpCode/Sequential.hs +0/−1
- src/Futhark/CodeGen/ImpGen.hs +58/−41
- src/Futhark/CodeGen/ImpGen/Kernels.hs +7/−3
- src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +84/−42
- src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +1/−1
- src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs +2/−1
- src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +116/−81
- src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +241/−130
- src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +1/−1
- src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +0/−1
- src/Futhark/Compiler.hs +14/−0
- src/Futhark/Construct.hs +9/−3
- src/Futhark/Internalise.hs +48/−53
- src/Futhark/Internalise/AccurateSizes.hs +1/−1
- src/Futhark/Internalise/Lambdas.hs +2/−68
- src/Futhark/Internalise/Monomorphise.hs +2/−2
- src/Futhark/Optimise/Fusion.hs +24/−13
- src/Futhark/Optimise/Fusion/LoopKernel.hs +10/−9
- src/Futhark/Optimise/InPlaceLowering.hs +29/−38
- src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +47/−21
- src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +14/−11
- src/Futhark/Optimise/Simplify.hs +2/−0
- src/Futhark/Optimise/Simplify/ClosedForm.hs +5/−5
- src/Futhark/Optimise/Simplify/Engine.hs +3/−0
- src/Futhark/Optimise/Simplify/Rules.hs +10/−10
- src/Futhark/Optimise/TileLoops.hs +6/−6
- src/Futhark/Pass.hs +2/−0
- src/Futhark/Pass/ExpandAllocations.hs +15/−12
- src/Futhark/Pass/ExplicitAllocations.hs +40/−15
- src/Futhark/Pass/ExplicitAllocations/Kernels.hs +14/−8
- src/Futhark/Pass/ExplicitAllocations/SegOp.hs +1/−1
- src/Futhark/Pass/ExtractKernels.hs +24/−8
- src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +6/−6
- src/Futhark/Pass/ExtractKernels/DistributeNests.hs +6/−4
- src/Futhark/Pass/ExtractKernels/ISRWIM.hs +2/−2
- src/Futhark/Pass/ExtractKernels/Intragroup.hs +7/−6
- src/Futhark/Pass/ExtractKernels/StreamKernel.hs +4/−4
- src/Futhark/Pass/KernelBabysitting.hs +2/−2
- src/Futhark/Pass/Simplify.hs +9/−11
- src/Futhark/Pkg/Info.hs +7/−3
- src/Futhark/Pkg/Types.hs +3/−1
- src/Futhark/Representation/AST/Attributes/Ranges.hs +3/−3
- src/Futhark/Representation/AST/Attributes/Rearrange.hs +2/−0
- src/Futhark/Representation/Kernels/Kernel.hs +1/−0
- src/Futhark/Representation/Kernels/Simplify.hs +2/−0
- src/Futhark/Representation/Mem/Simplify.hs +9/−7
- src/Futhark/Representation/Primitive.hs +48/−14
- src/Futhark/Representation/SOACS/SOAC.hs +98/−73
- src/Futhark/Representation/SOACS/Simplify.hs +35/−7
- src/Futhark/Representation/SegOp.hs +137/−115
- src/Futhark/Representation/SeqMem.hs +0/−9
- src/Futhark/Tools.hs +9/−7
- src/Futhark/Transform/FirstOrderTransform.hs +3/−2
- src/Futhark/TypeCheck.hs +2/−0
- src/Futhark/Util.hs +3/−1
- src/Futhark/Util/Console.hs +4/−0
- src/Futhark/Util/IntegralExp.hs +4/−1
- src/Language/Futhark/Attributes.hs +2/−0
- src/Language/Futhark/Interpreter.hs +3/−3
- src/Language/Futhark/TypeChecker/Modules.hs +6/−2
+ docs/c-api.rst view
@@ -0,0 +1,328 @@+.. _c-api:++C API Reference+===============++A Futhark program ``futlib.fut`` compiled to a C library with the+``--library`` command line option produces two files: ``futlib.c`` and+``futlib.h``. The API provided in the ``.h`` file is documented in+the following.++Usaging the API revolves around creating a *configuration object*,+which can then be used to obtain a *context object*, which must be+passed whenever entry points are called.++Most functions that can fail return an integer: 0 on success and a+non-zero value on error. Others return a ``NULL`` pointer. Use+:c:func:`futhark_context_get_error` to get a (possibly) more precise+error message.++Configuration+-------------++Context creation is parameterised by a configuration object. Any+changes to the configuration must be made *before* calling+:c:func:`futhark_context_new`. A configuration object must not be+freed while before any context objects for which it is used. The same+configuration may be used for multiple concurrent contexts.++.. c:type:: struct futhark_context_config++ An opaque struct representing a Futhark configuration.++.. c:function:: struct futhark_context_config *futhark_context_config_new(void)++ Produce a new configuration object. You must call+ :c:func:`futhark_context_config_free` when you are done with+ it.++.. c:function:: void futhark_context_config_free(struct futhark_context_config *cfg)++ Free the configuration object.++.. c:function:: void futhark_context_config_set_debugging(struct futhark_context_config *cfg, int flag)++ With a nonzero flag, enable various debugging information, with the+ details specific to the backend. This may involve spewing copious+ amounts of information to the standard error stream. It is also+ likely to make the program run much slower.++.. c:function:: void futhark_context_config_set_profiling(struct futhark_context_config *cfg, int flag)++ With a nonzero flag, enable the capture of profiling information.+ This should not significantly impact program performance. Use+ :c:func:`futhark_context_report` to retrieve captured information,+ the details of which are backend-specific.++.. c:function:: void futhark_context_config_set_logging(struct futhark_context_config *cfg, int flag)++ With a nonzero flag, print a running log to standard error of what+ the program is doing.++Context+-------++.. c:type:: struct futhark_context++ An opaque struct representing a Futhark context.++.. c:function:: struct futhark_context *futhark_context_new(struct futhark_context_config *cfg)++ Create a new context object. You must call+ :c:func:`futhark_context_free` when you are done with it. It is+ fine for multiple contexts to co-exist within the same process, but+ you must not pass values between them. They have the same C type,+ so this is an easy mistake to make.++.. c:function:: void futhark_context_free(struct futhark_context *ctx)++ Free the context object. It must not be used again. The+ configuration must be freed separately with+ :c:func:`futhark_context_config_free`.++.. c:function:: int futhark_context_sync(struct futhark_context *ctx)++ Block until all outstanding operations have finished executing.+ Many API functions are asynchronous on their own.++.. c:function:: void futhark_context_pause_profiling(struct futhark_context *ctx)++ Temporarily suspend the collection of profiling information. Has+ no effect if profiling was not enabled in the configuration.++.. c:function:: void futhark_context_unpause_profiling(struct futhark_context *ctx)++ Resume the collection of profiling information. Has no effect if+ profiling was not enabled in the configuration.++.. c:function:: char *futhark_context_get_error(struct futhark_context *ctx)++ A human-readable string describing the last error, if any. It is+ the caller's responsibility to ``free()`` the returned string. Any+ subsequent call to the function returns ``NULL``, until a new error+ occurs.++.. c:function:: char *futhark_context_report(struct futhark_context *ctx)++ Produce a human-readable C string with debug and profiling+ information collected during program runtime. It is the caller's+ responsibility to free the returned string. It is likely to only+ contain interesting information if+ :c:func:`futhark_context_config_set_debugging` or+ :c:func:`futhark_context_config_set_profiling` has been called+ previously.++.. c:function:: int futhark_context_clear_caches(struct futhark_context *ctx)++ Release any context-internal caches and buffers that may otherwise+ use computer resources. This is useful for freeing up those+ resources when no Futhark entry points are expected to run for some+ time. Particularly relevant when using a GPU backend, due to the+ relative scarcity of GPU memory.++Values+------++Primitive types (``i32``, ``bool``, etc) are mapped directly to their+corresponding C type. For each distinct array type (without sizes),+an opaque C struct is defined. Complex types (records, nested tuples)+are also assigned an opaque C struct. In the general case, these+types will be named with a random hash. However, if you insert an+explicit type annotation (and the type name contains only characters+valid for C identifiers), the indicated name will be used. Note that+arrays contain brackets, which are usually not valid in identifiers.+Defining a simple type alias is the best way around this.++All values share a similar API, which is illustrated here for the case+of the type ``[]i32``. The creation/retrieval functions are all+asynchronous, so make sure to call :c:func:`futhark_context_sync` when+appropriate. Memory management is entirely manual. All values that+are created with a ``new`` function, or returned from an entry point,+*must* at some point be freed manually. Values are internally+reference counted, so even for entry points that return their input+unchanged, you should still free both the input and the output - this+will not result in a double free.++.. c:type:: struct futhark_i32_1d++ An opaque struct representing a Futhark value of type ``[]i32``.++.. c:function:: struct futhark_i32_1d *futhark_new_i32_1d(struct futhark_context *ctx, int32_t *data, int64_t dim0)++ Asynchronously create a new array based on the given data. The+ dimensions express the number of elements. The data is copied into+ the new value. It is the caller's responsibility to eventually+ call :c:func:`futhark_free_i32_1d`. Multi-dimensional arrays are+ assumed to be in row-major form.++.. c:function:: struct futhark_i32_1d *futhark_new_raw_i32_1d(struct futhark_context *ctx, char *data, int offset, int64_t dim0)++ Create an array based on *raw* data, as well as an offset into it.+ This differs little from :c:func:`futhark_i32_1d` when using the+ ``c`` backend, but when using e.g. the ``opencl`` backend, the+ ``data`` parameter will be a ``cl_mem``. It is the caller's+ responsibility to eventually call :c:func:`futhark_free_i32_1d`.++.. c:function:: int futhark_free_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr)++ Free the value. In practice, this merely decrements the reference+ count by one. The value (or at least this reference) may not be+ used again after this function returns.++.. c:function:: int futhark_values_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr, int32_t *data)++ Copy data from the value into ``data``, which must be of sufficient+ size. Multi-dimensional arrays are written in row-major form.++.. c:function:: const int64_t *futhark_shape_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr)++ Return a pointer to the shape of the array, with one element per+ dimension. The lifetime of the shape is the same as ``arr``, and+ should *not* be manually freed.++Entry points+------------++Entry points are mapped 1:1 to C functions. Return value are handled+with "out"-parameters.++For example, the following entry point::++ entry sum = i32.sum++Results in the following C function:++.. c:function:: int futhark_entry_main(struct futhark_context *ctx, int32_t *out0, const struct futhark_i32_1d *in0)++ Asynchronously call the entry point with the given arguments. Make+ sure to call :c:func:`futhark_context_sync` before using the value+ of ``out0``.++GPU+---++The following API functions are available when using the ``opencl`` or+``cuda`` backends.++.. c:function:: void futhark_context_config_set_device(struct futhark_context_config *cfg, const char *s)++ Use the first device whose name contains the given string. The+ special string ``#k``, where ``k`` is an integer, can be used to+ pick the *k*-th device, numbered from zero. If used in conjunction+ with :c:func:`futhark_context_config_set_platform`, only the+ devices from matching platforms are considered.+++Exotic+~~~~~~++The following functions are not going to interesting to most users.++.. c:function:: void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size)++ Set the default number of work-items in a work-group.++.. c:function:: void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int num)++ Set the default number of work-groups used for kernels.++.. c:function:: void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int num)++ Set the default tile size used when executing kernels that have+ been block tiled.++OpenCL+------++The following API functions are available only when using the+``opencl`` backend.++.. c:function:: void futhark_context_config_set_platform(struct futhark_context_config *cfg, const char *s)++ Use the first OpenCL platform whose name contains the given string.+ The special string ``#k``, where ``k`` is an integer, can be used+ to pick the *k*-th platform, numbered from zero.++.. c:function:: void futhark_context_config_select_device_interactively(struct futhark_context_config *cfg)++ 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)++ Construct a context that uses a pre-existing command queue. This+ allows the caller to directly customise which device and platform+ is used.++.. c:function:: cl_command_queue futhark_context_get_command_queue(struct futhark_context *ctx)++ Retrieve the command queue used by the Futhark context. Be very+ careful with it - enqueueing your own work is unlikely to go well.++Exotic+~~~~~~++The following functions are used for debugging generated code or+advanced usage.++.. c:function:: void futhark_context_config_add_build_option(struct futhark_context_config *cfg, const char *opt)++ Add a build option to the OpenCL kernel compiler. See the OpenCL+ specification for `clBuildProgram` for available options.++.. c:function:: void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path)++ During :c:func:`futhark_context_new`, dump the OpenCL program+ source to the given file.++.. c:function:: void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path)++ During :c:func:`futhark_context_new`, read OpenCL program source+ from the given file instead of using the embedded program.++.. c:function:: void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char *path)++ During :c:func:`futhark_context_new`, dump the compiled OpenCL+ binary to the given file.++.. c:function:: void futhark_context_config_load_binary_from(struct futhark_context_config *cfg, const char *path)++ During :c:func:`futhark_context_new`, read a compiled OpenCL binary+ from the given file instead of using the embedded program.++CUDA+----++The following API functions are available when using the ``cuda``+backend.++Exotic+~~~~~~++The following functions are used for debugging generated code or+advanced usage.++.. c:function:: void futhark_context_config_add_nvrtc_option(struct futhark_context_config *cfg, const char *opt)++ Add a build option to the NVRTC compiler. See the CUDA+ documentation for ``nvrtcCompileProgram`` for available options.++.. c:function:: void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path)++ During :c:func:`futhark_context_new`, dump the CUDA program+ source to the given file.++.. c:function:: void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path)++ During :c:func:`futhark_context_new`, read CUDA program source+ from the given file instead of using the embedded program.++.. c:function:: void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char *path)++ During :c:func:`futhark_context_new`, dump the generated PTX code+ to the given file.++.. c:function:: void futhark_context_config_load_ptx_from(struct futhark_context_config *cfg, const char *path)++ During :c:func:`futhark_context_new`, read PTX code from the given+ file instead of using the embedded program.
docs/index.rst view
@@ -30,6 +30,7 @@ installation.rst usage.rst language-reference.rst+ c-api.rst package-management.rst c-porting-guide.rst versus-other-languages.rst
docs/man/futhark-cuda.rst view
@@ -119,10 +119,11 @@ Print all sizes that can be set with ``-size`` or ``--tuning``. ---size=NAME=INT+--size=ASSIGNMENT - Set a configurable run-time parameter to the given value. Use- ``--print-sizes`` to see which are available.+ Set a configurable run-time parameter to the given+ value. ``ASSIGNMENT`` must be of the form ``NAME=INT`` Use+ ``--print-sizes`` to see which names are available. --tuning=FILE
docs/man/futhark-opencl.rst view
@@ -145,10 +145,11 @@ end. When ``-r`` is used, only the last run will be profiled. Implied by ``-D``. ---size=NAME=INT+--size=ASSIGNMENT - Set a configurable run-time parameter to the given value. Use- ``--print-sizes`` to see which are available.+ Set a configurable run-time parameter to the given+ value. ``ASSIGNMENT`` must be of the form ``NAME=INT`` Use+ ``--print-sizes`` to see which names are available. --tuning=FILE
docs/usage.rst view
@@ -320,11 +320,13 @@ support code that is not needed by the Futhark program). The generated header file (here, ``futlib.h``) specifies the API, and-is intended to be human-readable. The basic usage revolves around-creating a *configuration object*, which can then be used to obtain a-*context object*, which must be passed whenever entry points are-called.+is intended to be human-readable. See :ref:`c-api` for more+information. +The basic usage revolves around creating a *configuration object*,+which can then be used to obtain a *context object*, which must be+passed whenever entry points are called.+ The configuration object is created using the following function:: struct futhark_context_config *futhark_context_config_new();@@ -343,28 +345,16 @@ Context creation may fail. Immediately after ``futhark_context_new()``, call ``futhark_context_get_error()`` (see below), which will return a non-NULL error string if context creation-failed.+failed. The API functions are all thread safe. Memory management is entirely manual. Deallocation functions are provided for all types defined in the header file. Everything returned by an entry point must be manually deallocated. -Functions that can fail return an integer: 0 on success and a non-zero-value on error. A human-readable string describing the error can be-retrieved with the following function::-- char *futhark_context_get_error(struct futhark_context *ctx);--It is the caller's responsibility to ``free()`` the returned string.-Any subsequent call to the function returns ``NULL``, until a new-error occurs.- For now, many internal errors, such as failure to allocate memory, will cause the function to ``abort()`` rather than return an error code. However, all application errors (such as bounds and array size checks) will produce an error code.--The API functions are thread safe. C with OpenCL ~~~~~~~~~~~~~
futhark.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: futhark-version: 0.15.6+version: 0.15.7 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to efficient parallel code. It is a statically typed, data-parallel,
rts/c/cuda.h view
@@ -387,63 +387,36 @@ } } -static void dump_string_to_file(const char *file, const char *buf) {- FILE *f = fopen(file, "w");- assert(f != NULL);- assert(fputs(buf, f) != EOF);- assert(fclose(f) == 0);-}--static void load_string_from_file(const char *file, char **obuf, size_t *olen) {- char *buf;- size_t len;- FILE *f = fopen(file, "r");-- assert(f != NULL);- assert(fseek(f, 0, SEEK_END) == 0);- len = ftell(f);- assert(fseek(f, 0, SEEK_SET) == 0);-- buf = (char*) malloc(len + 1);- assert(fread(buf, 1, len, f) == len);- buf[len] = 0;- *obuf = buf;- if (olen != NULL) {- *olen = len;- }-- assert(fclose(f) == 0);-}- static void cuda_module_setup(struct cuda_context *ctx, const char *src_fragments[], const char *extra_opts[]) { char *ptx = NULL, *src = NULL; - if (ctx->cfg.load_ptx_from == NULL && ctx->cfg.load_program_from == NULL) {+ if (ctx->cfg.load_program_from == NULL) { src = concat_fragments(src_fragments);- ptx = cuda_nvrtc_build(ctx, src, extra_opts);- } else if (ctx->cfg.load_ptx_from == NULL) {- load_string_from_file(ctx->cfg.load_program_from, &src, NULL);- ptx = cuda_nvrtc_build(ctx, src, extra_opts); } 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: Loading PTX from %s instead of C code from %s\n",+ "WARNING: Using PTX from %s instead of C code from %s\n", ctx->cfg.load_ptx_from, ctx->cfg.load_program_from); }-- load_string_from_file(ctx->cfg.load_ptx_from, &ptx, NULL);+ ptx = slurp_file(ctx->cfg.load_ptx_from, NULL); } if (ctx->cfg.dump_program_to != NULL) {- if (src == NULL) {- src = concat_fragments(src_fragments);- }- dump_string_to_file(ctx->cfg.dump_program_to, src);+ dump_file(ctx->cfg.dump_program_to, src, strlen(src)); }++ if (ptx == NULL) {+ ptx = cuda_nvrtc_build(ctx, src, extra_opts);+ }+ if (ctx->cfg.dump_ptx_to != NULL) {- dump_string_to_file(ctx->cfg.dump_ptx_to, ptx);+ dump_file(ctx->cfg.dump_ptx_to, ptx, strlen(ptx)); } CUDA_SUCCEED(cuModuleLoadData(&ctx->module, ptx));
rts/c/opencl.h view
@@ -140,30 +140,6 @@ return copy; } -// Read a file into a NUL-terminated string; returns NULL on error.-static char* slurp_file(const char *filename, size_t *size) {- char *s;- FILE *f = fopen(filename, "rb"); // To avoid Windows messing with linebreaks.- if (f == NULL) return NULL;- fseek(f, 0, SEEK_END);- size_t src_size = ftell(f);- fseek(f, 0, SEEK_SET);- s = (char*) malloc(src_size + 1);- if (fread(s, 1, src_size, f) != src_size) {- free(s);- s = NULL;- } else {- s[src_size] = '\0';- }- fclose(f);-- if (size) {- *size = src_size;- }-- return s;-}- static const char* opencl_error_string(cl_int err) { switch (err) {@@ -647,10 +623,8 @@ if (ctx->cfg.debugging) { fprintf(stderr, "Dumping OpenCL source to %s...\n", ctx->cfg.dump_program_to); }- FILE *f = fopen(ctx->cfg.dump_program_to, "w");- assert(f != NULL);- fputs(fut_opencl_src, f);- fclose(f);++ dump_file(ctx->cfg.dump_program_to, fut_opencl_src, strlen(fut_opencl_src)); } if (ctx->cfg.debugging) {@@ -728,10 +702,7 @@ OPENCL_SUCCEED_FATAL(clGetProgramInfo(prog, CL_PROGRAM_BINARIES, sizeof(unsigned char*), binaries, NULL)); - FILE *f = fopen(ctx->cfg.dump_binary_to, "w");- assert(f != NULL);- fwrite(binary, sizeof(char), binary_size, f);- fclose(f);+ dump_file(ctx->cfg.dump_binary_to, binary, binary_size); } return prog;@@ -948,6 +919,16 @@ } 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.
− rts/c/panic.h
@@ -1,30 +0,0 @@-// Start of panic.h.--#include <stdarg.h>--static const char *fut_progname;--static void futhark_panic(int eval, const char *fmt, ...)-{- va_list ap;-- va_start(ap, fmt);- fprintf(stderr, "%s: ", fut_progname);- vfprintf(stderr, fmt, ap);- va_end(ap);- exit(eval);-}--/* For generating arbitrary-sized error messages. It is the callers- responsibility to free the buffer at some point. */-static char* msgprintf(const char *s, ...) {- va_list vl;- va_start(vl, s);- size_t needed = 1 + (size_t)vsnprintf(NULL, 0, s, vl);- char *buffer = (char*) malloc(needed);- va_start(vl, s); /* Must re-init. */- vsnprintf(buffer, needed, s, vl);- return buffer;-}--// End of panic.h.
+ rts/c/util.h view
@@ -0,0 +1,100 @@+// Start of util.h.+//+// Various helper functions that are useful in all generated C code.++static const char *fut_progname = "(some Futhark code)";++static void futhark_panic(int eval, const char *fmt, ...) {+ va_list ap;+ va_start(ap, fmt);+ fprintf(stderr, "%s: ", fut_progname);+ vfprintf(stderr, fmt, ap);+ va_end(ap);+ exit(eval);+}++// For generating arbitrary-sized error messages. It is the callers+// responsibility to free the buffer at some point.+static char* msgprintf(const char *s, ...) {+ va_list vl;+ va_start(vl, s);+ size_t needed = 1 + (size_t)vsnprintf(NULL, 0, s, vl);+ char *buffer = (char*) malloc(needed);+ va_start(vl, s); /* Must re-init. */+ vsnprintf(buffer, needed, s, vl);+ return buffer;+}++// Read a file into a NUL-terminated string; returns NULL on error.+static char* slurp_file(const char *filename, size_t *size) {+ char *s;+ FILE *f = fopen(filename, "rb"); // To avoid Windows messing with linebreaks.+ if (f == NULL) return NULL;+ fseek(f, 0, SEEK_END);+ size_t src_size = ftell(f);+ fseek(f, 0, SEEK_SET);+ s = (char*) malloc(src_size + 1);+ if (fread(s, 1, src_size, f) != src_size) {+ free(s);+ s = NULL;+ } else {+ s[src_size] = '\0';+ }+ fclose(f);++ if (size) {+ *size = src_size;+ }++ return s;+}++// Dump 'n' bytes from 'buf' into the file at the designated location.+// Returns 0 on success.+static int dump_file(const char *file, const char *buf, size_t n) {+ FILE *f = fopen(file, "w");++ if (f == NULL) {+ return 1;+ }++ if (fwrite(buf, sizeof(char), n, f) != n) {+ return 1;+ }++ if (fclose(f) != 0) {+ return 1;+ }++ return 0;+}++struct str_builder {+ char *str;+ size_t capacity; // Size of buffer.+ size_t used; // Bytes used, *not* including final zero.+};++static void str_builder_init(struct str_builder *b) {+ b->capacity = 10;+ b->used = 0;+ b->str = malloc(b->capacity);+ b->str[0] = 0;+}++static void str_builder(struct str_builder *b, const char *s, ...) {+ va_list vl;+ va_start(vl, s);+ size_t needed = (size_t)vsnprintf(NULL, 0, s, vl);++ while (b->capacity < b->used + needed + 1) {+ b->capacity *= 2;+ b->str = realloc(b->str, b->capacity);+ }++ va_start(vl, s); /* Must re-init. */+ vsnprintf(b->str+b->used, b->capacity-b->used, s, vl);+ b->used += needed;+}++// End of util.h.
rts/csharp/scalar.cs view
@@ -14,15 +14,30 @@ private static int add32(int x, int y){ return (int) ((uint) x + (uint) y);} private static long add64(long x, long y){ return (long) ((ulong) x + (ulong) y);} +private static sbyte add_nw8(sbyte x, sbyte y){ return (sbyte) ((byte) x + (byte) y);}+private static short add_nw16(short x, short y){ return (short) ((ushort) x + (ushort) y);}+private static int add_nw32(int x, int y){ return (int) ((uint) x + (uint) y);}+private static long add_nw64(long x, long y){ return (long) ((ulong) x + (ulong) y);}+ private static sbyte sub8(sbyte x, sbyte y){ return (sbyte) ((byte) x - (byte) y);} private static short sub16(short x, short y){ return (short) ((ushort) x - (ushort) y);} private static int sub32(int x, int y){ return (int) ((uint) x - (uint) y);} private static long sub64(long x, long y){ return (long) ((ulong) x - (ulong) y);} +private static sbyte sub_nw8(sbyte x, sbyte y){ return (sbyte) ((byte) x - (byte) y);}+private static short sub_nw16(short x, short y){ return (short) ((ushort) x - (ushort) y);}+private static int sub_nw32(int x, int y){ return (int) ((uint) x - (uint) y);}+private static long sub_nw64(long x, long y){ return (long) ((ulong) x - (ulong) y);}+ private static sbyte mul8(sbyte x, sbyte y){ return (sbyte) ((byte) x * (byte) y);} private static short mul16(short x, short y){ return (short) ((ushort) x * (ushort) y);} private static int mul32(int x, int y){ return (int) ((uint) x * (uint) y);} private static long mul64(long x, long y){ return (long) ((ulong) x * (ulong) y);}++private static sbyte mul_nw8(sbyte x, sbyte y){ return (sbyte) ((byte) x * (byte) y);}+private static short mul_nw16(short x, short y){ return (short) ((ushort) x * (ushort) y);}+private static int mul_nw32(int x, int y){ return (int) ((uint) x * (uint) y);}+private static long mul_nw64(long x, long y){ return (long) ((ulong) x * (ulong) y);} private static sbyte or8(sbyte x, sbyte y){ return (sbyte) (x | y); } private static short or16(short x, short y){ return (short) (x | y); }
src/Futhark/Actions.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}+-- | All (almost) compiler pipelines end with an 'Action', which does+-- something with the result of the pipeline. module Futhark.Actions ( printAction , impCodeGenAction@@ -23,6 +25,7 @@ import Futhark.Representation.AST.Attributes.Ranges (CanBeRanged) import Futhark.Analysis.Metrics +-- | Print the result to stdout, with alias annotations. printAction :: (Attributes lore, CanBeAliased (Op lore)) => Action lore printAction = Action { actionName = "Prettyprint"@@ -30,6 +33,7 @@ , actionProcedure = liftIO . putStrLn . pretty . aliasAnalysis } +-- | Print the result to stdout, with range annotations. rangeAction :: (Attributes lore, CanBeRanged (Op lore)) => Action lore rangeAction = Action { actionName = "Range analysis"@@ -37,6 +41,7 @@ , actionProcedure = liftIO . putStrLn . pretty . rangeAnalysis } +-- | Print metrics about AST node counts to stdout. metricsAction :: OpMetrics (Op lore) => Action lore metricsAction = Action { actionName = "Compute metrics"@@ -44,6 +49,7 @@ , actionProcedure = liftIO . putStr . show . progMetrics } +-- | Convert the program to sequential ImpCode and print it to stdout. impCodeGenAction :: Action SeqMem impCodeGenAction = Action { actionName = "Compile imperative"@@ -51,6 +57,7 @@ , actionProcedure = liftIO . putStrLn . pretty <=< ImpGenSequential.compileProg } +-- | Convert the program to GPU ImpCode and print it to stdout. kernelImpCodeGenAction :: Action KernelsMem kernelImpCodeGenAction = Action { actionName = "Compile imperative kernels"
src/Futhark/Analysis/HORepresentation/MapNest.hs view
@@ -71,7 +71,7 @@ -> SOAC lore -> m (Maybe (MapNest lore)) -fromSOAC' bound (SOAC.Screma w (SOAC.ScremaForm (_, []) [] lam) inps) = do+fromSOAC' bound (SOAC.Screma w (SOAC.ScremaForm [] [] lam) inps) = do maybenest <- case (stmsToList $ bodyStms $ lambdaBody lam, bodyResult $ lambdaBody lam) of ([Let pat _ e], res) | res == map Var (patternNames pat) ->
src/Futhark/Analysis/HORepresentation/SOAC.hs view
@@ -464,20 +464,12 @@ -- | Either convert an expression to the normalised SOAC -- representation, or a reason why the expression does not have the -- valid form.-fromExp :: (Op lore ~ Futhark.SOAC lore, Bindable lore,- HasScope lore m, MonadFreshNames m) =>+fromExp :: (Op lore ~ Futhark.SOAC lore, HasScope lore m) => Exp lore -> m (Either NotSOAC (SOAC lore))--fromExp (BasicOp (Copy arr)) = do- arr_t <- lookupType arr- p <- Param <$> newVName "copy_p" <*> pure (rowType arr_t)- let lam = Lambda [p] (mkBody mempty [Futhark.Var $ paramName p]) [rowType arr_t]- Right . Screma (arraySize 0 arr_t) (Futhark.mapSOAC lam) . pure <$> varInput arr fromExp (Op (Futhark.Stream w form lam as)) = Right . Stream w form lam <$> traverse varInput as-fromExp (Op (Futhark.Scatter len lam ivs as)) = do- ivs' <- traverse varInput ivs- return $ Right $ Scatter len lam ivs' as+fromExp (Op (Futhark.Scatter len lam ivs as)) =+ Right <$> (Scatter len lam <$> traverse varInput ivs <*> pure as) fromExp (Op (Futhark.Screma w form arrs)) = Right . Screma w form <$> traverse varInput arrs fromExp (Op (Futhark.Hist w ops lam arrs)) =@@ -519,7 +511,8 @@ -- map(f,a) creates a stream with NO accumulators return (Stream w (Parallel Disorder Commutative empty_lam []) strmlam inps, []) - | Just (scan_lam, nes, _) <- Futhark.isScanomapSOAC form -> do+ | Just (scans, _) <- Futhark.isScanomapSOAC form,+ Futhark.Scan scan_lam nes <- Futhark.singleScan scans -> do -- scanomap(scan_lam,nes,map_lam,a) => is translated in strem's body to: -- 1. let (scan0_ids,map_resids) = scanomap(scan_lam, nes, map_lam, a_ch) -- 2. let strm_resids = map (acc `+`,nes, scan0_ids)@@ -546,11 +539,11 @@ outszm1id <- newIdent "szm1" $ Prim int32 -- 1. let (scan0_ids,map_resids) = scanomap(scan_lam,nes,map_lam,a_ch) let insbnd = mkLet [] (scan0_ids++map_resids) $ Op $- Futhark.Screma chvar (Futhark.scanomapSOAC scan_lam nes lam') $+ Futhark.Screma chvar (Futhark.scanomapSOAC [Futhark.Scan scan_lam nes] lam') $ map paramName strm_inpids -- 2. let outerszm1id = chunksize - 1 outszm1bnd = mkLet [] [outszm1id] $ BasicOp $- BinOp (Sub Int32)+ BinOp (Sub Int32 OverflowUndef) (Futhark.Var $ paramName chunk_param) (constant (1::Int32)) -- 3. let lasteel_ids = ...
src/Futhark/Analysis/PrimExp.hs view
@@ -29,6 +29,9 @@ -- | A primitive expression parametrised over the representation of -- free variables. Note that the 'Functor', 'Traversable', and 'Num' -- instances perform automatic (but simple) constant folding.+--+-- Note also that the 'Num' instance assumes 'OverflowUndef'+-- semantics! data PrimExp v = LeafExp v PrimType | ValueExp PrimValue | BinOpExp BinOp (PrimExp v) (PrimExp v)@@ -153,13 +156,16 @@ -- expressions to constants so that the above works. However, it is -- still a bit of a hack. instance Pretty v => Num (PrimExp v) where- x + y | Just z <- msum [asIntOp Add x y, asFloatOp FAdd x y] = constFoldPrimExp z+ x + y | Just z <- msum [asIntOp (`Add` OverflowUndef) x y,+ asFloatOp FAdd x y] = constFoldPrimExp z | otherwise = numBad "+" (x,y) - x - y | Just z <- msum [asIntOp Sub x y, asFloatOp FSub x y] = constFoldPrimExp z+ x - y | Just z <- msum [asIntOp (`Sub` OverflowUndef) x y,+ asFloatOp FSub x y] = constFoldPrimExp z | otherwise = numBad "-" (x,y) - x * y | Just z <- msum [asIntOp Mul x y, asFloatOp FMul x y] = constFoldPrimExp z+ x * y | Just z <- msum [asIntOp (`Mul` OverflowUndef) x y,+ asFloatOp FMul x y] = constFoldPrimExp z | otherwise = numBad "*" (x,y) abs x | IntType t <- primExpType x = UnOpExp (Abs t) x
src/Futhark/Analysis/ScalExp.hs view
@@ -214,7 +214,7 @@ SLogAnd x' y' `SLogOr` SLogAnd (SNot x') (SNot y') _ -> RelExp LEQ0 (x' `sminus` y') `SLogAnd` RelExp LEQ0 (y' `sminus` x')-toScalExp look (BasicOp (BinOp (Sub t) (Constant x) y))+toScalExp look (BasicOp (BinOp (Sub t _) (Constant x) y)) | typeIsOK $ IntType t, zeroIsh x = Just . SNeg <$> subExpToScalExp' look y toScalExp look (BasicOp (UnOp AST.Not e)) =@@ -277,9 +277,9 @@ binOpScalExp bop = fmap snd . find ((==bop) . fst) $ concatMap intOps allIntTypes ++ [ (LogAnd, SLogAnd), (LogOr, SLogOr) ]- where intOps t = [ (Add t, SPlus)- , (Sub t, SMinus)- , (Mul t, STimes)+ where intOps t = [ (Add t OverflowWrap, SPlus)+ , (Sub t OverflowWrap, SMinus)+ , (Mul t OverflowWrap, STimes) , (AST.SDiv t, SDiv) , (AST.Pow t, SPow) , (AST.SMax t, \x y -> MaxMin False [x,y])
src/Futhark/CLI/Autotune.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+-- | @futhark autotune@ module Futhark.CLI.Autotune (main) where import Control.Monad@@ -358,6 +359,7 @@ "Enable logging. Pass multiple times for more." ] +-- | Run @futhark autotune@ main :: String -> [String] -> IO () main = mainWithOptions initialAutotuneOptions commandLineOptions "options... program" $
src/Futhark/CLI/Bench.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}--- | Simple tool for benchmarking Futhark programs. Use the @--json@--- flag for machine-readable output.+-- | @futhark bench@ module Futhark.CLI.Bench ( main ) where import Control.Monad@@ -287,6 +286,7 @@ where max_timeout :: Int max_timeout = maxBound `div` 1000000 +-- | Run @futhark bench@. main :: String -> [String] -> IO () main = mainWithOptions initialBenchOptions commandLineOptions "options... programs..." $ \progs config -> Just $ runBenchmarks config progs
src/Futhark/CLI/C.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | @futhark c@ module Futhark.CLI.C (main) where import Control.Monad.IO.Class@@ -11,6 +12,7 @@ import Futhark.Compiler.CLI import Futhark.Util +-- | Run @futhark c@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile sequential C" "Generate sequential C code from optimised Futhark program."
src/Futhark/CLI/CSOpenCL.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | @futhark csopencl@ module Futhark.CLI.CSOpenCL (main) where import Control.Monad.IO.Class@@ -14,6 +15,7 @@ import Futhark.Compiler.CLI import Futhark.Util +-- | Run @futhark csopencl@. main :: String -> [String] -> IO () main = compilerMain () [] "Compile OpenCL C#" "Generate OpenCL C# code from optimised Futhark program."
src/Futhark/CLI/CSharp.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | @futhark csharp@ module Futhark.CLI.CSharp (main) where import Control.Monad.IO.Class@@ -14,6 +15,7 @@ import Futhark.Compiler.CLI import Futhark.Util +-- | Run @futhark csharp@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile sequential C#" "Generate sequential C# code from optimised Futhark program."
src/Futhark/CLI/CUDA.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | @futhark cuda@ module Futhark.CLI.CUDA (main) where import Control.Monad.IO.Class@@ -11,6 +12,7 @@ import Futhark.Util import Futhark.Compiler.CLI +-- | Run @futhark cuda@. main :: String -> [String] -> IO () main = compilerMain () [] "Compile CUDA" "Generate CUDA/C code from optimised Futhark program."
src/Futhark/CLI/Check.hs view
@@ -1,3 +1,4 @@+-- | @futhark check@ module Futhark.CLI.Check (main) where import Control.Monad@@ -18,6 +19,7 @@ (NoArg $ Right $ \cfg -> cfg { checkWarn = False }) "Disable all warnings."] +-- | Run @futhark check@. main :: String -> [String] -> IO () main = mainWithOptions newCheckConfig options "program" $ \args cfg -> case args of
src/Futhark/CLI/Datacmp.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+-- | @futhark datacmp@ module Futhark.CLI.Datacmp (main) where import qualified Data.ByteString.Lazy.Char8 as BS@@ -7,6 +8,7 @@ import Futhark.Test.Values import Futhark.Util.Options +-- | Run @futhark datacmp@ main :: String -> [String] -> IO () main = mainWithOptions () [] "<file> <file>" f where f [file_a, file_b] () = Just $ do
src/Futhark/CLI/Dataset.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} {-# LANGUAGE StrictData #-}--- | Randomly generate Futhark input files containing values of a--- specified type and shape.+-- | @futhark dataset@ module Futhark.CLI.Dataset (main) where import Control.Monad@@ -29,6 +28,7 @@ import Futhark.Test.Values import Futhark.Util.Options +-- | Run @futhark dataset@. main :: String -> [String] -> IO () main = mainWithOptions initialDataOptions commandLineOptions "options..." f where f [] config
src/Futhark/CLI/Dev.hs view
@@ -48,6 +48,7 @@ import qualified Futhark.Pass.ExplicitAllocations.Kernels as Kernels import qualified Futhark.Pass.ExplicitAllocations.Seq as Seq import Futhark.Passes+import Futhark.Util.Log -- | What to do with the program after it has been read. data FutharkPipeline = PrettyPrint@@ -242,6 +243,22 @@ long = [passLongOption pass] pass = Seq.explicitAllocations +iplOption :: String -> FutharkOption+iplOption short =+ passOption (passDescription pass) (UntypedPass perform) short long+ where perform (Kernels prog) config =+ Kernels <$>+ runPasses (onePass inPlaceLoweringKernels) config prog+ perform (Seq prog) config =+ Seq <$>+ runPasses (onePass inPlaceLoweringSeq) config prog+ perform s _ =+ externalErrorS $+ "Pass '" ++ passDescription pass ++ "' cannot operate on " ++ representation s++ long = [passLongOption pass]+ pass = inPlaceLoweringSeq+ cseOption :: String -> FutharkOption cseOption short = passOption (passDescription pass) (UntypedPass perform) short long@@ -338,13 +355,13 @@ , typedPassOption soacsProg Seq firstOrderTransform "f" , soacsPassOption fuseSOACs "o" , soacsPassOption inlineFunctions []- , kernelsPassOption inPlaceLoweringKernels [] , kernelsPassOption babysitKernels [] , kernelsPassOption tileLoops [] , kernelsPassOption unstream [] , kernelsPassOption sink [] , typedPassOption soacsProg Kernels extractKernels [] + , iplOption [] , allocateOption "a" , kernelsMemPassOption doubleBuffer []@@ -432,6 +449,7 @@ runPolyPasses config initial_prog = do end_prog <- foldM (runPolyPass pipeline_config) (SOACS initial_prog) (getFutharkPipeline config)+ logMsg $ "Running action " ++ untypedActionName (futharkAction config) case (end_prog, futharkAction config) of (SOACS prog, SOACSAction action) -> actionProcedure action prog@@ -458,6 +476,7 @@ untypedActionName action <> " expects " ++ representation action ++ " representation, but got " ++ representation end_prog ++ "."+ logMsg ("Done." :: String) where pipeline_config = PipelineConfig { pipelineVerbose = fst (futharkVerbose $ futharkConfig config) > NotVerbose , pipelineValidate = True
src/Futhark/CLI/Doc.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+-- | @futhark doc@ module Futhark.CLI.Doc (main) where import Control.Monad.State@@ -23,6 +24,7 @@ import Futhark.Util.Options import Futhark.Util (directoryContents, trim) +-- | Run @futhark doc@. main :: String -> [String] -> IO () main = mainWithOptions initialDocConfig commandLineOptions "options... -o outdir programs..." f where f [dir] config = Just $ do
src/Futhark/CLI/Misc.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}--- Various small subcommands that are too simple to deserve their own file.+-- | Various small subcommands that are too simple to deserve their own file. module Futhark.CLI.Misc ( mainImports , mainDataget@@ -18,6 +18,7 @@ import Futhark.Util.Options import Futhark.Test +-- | @futhark imports@ mainImports :: String -> [String] -> IO () mainImports = mainWithOptions () [] "program" $ \args () -> case args of@@ -28,6 +29,7 @@ $ map fst prog_imports _ -> Nothing +-- | @futhark dataget@ mainDataget :: String -> [String] -> IO () mainDataget = mainWithOptions () [] "program dataset" $ \args () -> case args of
src/Futhark/CLI/OpenCL.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | @futhark opencl@ module Futhark.CLI.OpenCL (main) where import Control.Monad.IO.Class@@ -12,6 +13,7 @@ import Futhark.Util import Futhark.Compiler.CLI +-- | Run @futhark opencl@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile OpenCL" "Generate OpenCL/C code from optimised Futhark program."
src/Futhark/CLI/Pkg.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | @futhark pkg@ module Futhark.CLI.Pkg (main) where import Control.Monad.IO.Class@@ -61,7 +62,7 @@ forM_ (M.toList bl) $ \(p, v) -> do info <- lookupPackageRev p v- a <- downloadZipball $ pkgRevZipballUrl info+ a <- downloadZipball info m <- getManifest $ pkgRevGetManifest info -- Compute the directory in the zipball that should contain the@@ -91,32 +92,32 @@ libDir, libNewDir, libOldDir :: FilePath (libDir, libNewDir, libOldDir) = ("lib", "lib~new", "lib~old") --- | Install the packages listed in the build list in the 'lib'+-- | Install the packages listed in the build list in the @lib@ -- directory of the current working directory. Since we are touching -- the file system, we are going to be very paranoid. In particular,--- we want to avoid corrupting the 'lib' directory if something fails+-- we want to avoid corrupting the @lib@ directory if something fails -- along the way. -- -- The procedure is as follows: ----- 1) Create a directory 'lib~new'. Delete an existing 'lib~new' if+-- 1) Create a directory @lib~new@. Delete an existing @lib~new@ if -- necessary. ----- 2) Populate 'lib~new' based on the build list.+-- 2) Populate @lib~new@ based on the build list. ----- 3) Rename 'lib' to 'lib~old'. Delete an existing 'lib~old' if+-- 3) Rename @lib@ to @lib~old@. Delete an existing @lib~old@ if -- necessary. ----- 4) Rename 'lib~new' to 'lib'+-- 4) Rename @lib~new@ to @lib@ ----- 5) If the current package has package path 'p', move 'lib~old/p' to--- 'lib~new/p'.+-- 5) If the current package has package path @p@, move @lib~old/p@ to+-- @lib~new/p@. ----- 6) Delete 'lib~old'.+-- 6) Delete @lib~old@. -- -- 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.+-- @lib~old@ will still exist and can be put back by the user. installBuildList :: Maybe PkgPath -> BuildList -> PkgM () installBuildList p bl = do libdir_exists <- liftIO $ doesDirectoryExist libDir@@ -356,6 +357,7 @@ mapM_ (liftIO . T.putStrLn . prettySemVer) . M.keys . pkgVersions <=< lookupPackage +-- | Run @futhark pkg@. main :: String -> [String] -> IO () main prog args = do -- Avoid Git asking for credentials. We prefer failure.
src/Futhark/CLI/PyOpenCL.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | @futhark pyopencl@ module Futhark.CLI.PyOpenCL (main) where import Control.Monad.IO.Class@@ -9,6 +10,7 @@ import qualified Futhark.CodeGen.Backends.PyOpenCL as PyOpenCL import Futhark.Compiler.CLI +-- | Run @futhark pyopencl@. main :: String -> [String] -> IO () main = compilerMain () [] "Compile PyOpenCL" "Generate Python + OpenCL code from optimised Futhark program."
src/Futhark/CLI/Python.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | @futhark py@ module Futhark.CLI.Python (main) where import Control.Monad.IO.Class@@ -9,6 +10,7 @@ import qualified Futhark.CodeGen.Backends.SequentialPython as SequentialPy import Futhark.Compiler.CLI +-- | Run @futhark py@ main :: String -> [String] -> IO () main = compilerMain () [] "Compile sequential Python" "Generate sequential Python code from optimised Futhark program."
src/Futhark/CLI/Query.hs view
@@ -1,3 +1,4 @@+-- | @futhark query@ module Futhark.CLI.Query (main) where import Text.Read (readMaybe)@@ -8,6 +9,7 @@ import Language.Futhark.Query import Language.Futhark.Syntax +-- | Run @futhark query@. main :: String -> [String] -> IO () main = mainWithOptions () [] "program line:col" $ \args () -> case args of
src/Futhark/CLI/REPL.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | @futhark repl@ module Futhark.CLI.REPL (main) where import Control.Monad.Free.Church@@ -48,6 +49,7 @@ "| | \\ | | | \\ \\" ] +-- | Run @futhark repl@. main :: String -> [String] -> IO () main = mainWithOptions interpreterConfig options "options..." run where run [] _ = Just repl
src/Futhark/CLI/Run.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+-- | @futhark run@ module Futhark.CLI.Run (main) where import Control.Monad.Free.Church@@ -30,6 +31,7 @@ import qualified Language.Futhark.Interpreter as I +-- | Run @futhark run@. main :: String -> [String] -> IO () main = mainWithOptions interpreterConfig options "options... program" run where run [prog] config = Just $ interpret config prog
src/Futhark/CLI/Test.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings, FlexibleContexts, LambdaCase #-}--- | This program is a convenience utility for running the Futhark--- test suite, and its test programs.+-- | @futhark test@ module Futhark.CLI.Test (main) where import Control.Applicative.Lift (runErrors, failure, Errors, Lift(..))@@ -596,6 +595,7 @@ "Number of tests to run concurrently." ] +-- | Run @futhark test@. main :: String -> [String] -> IO () main = mainWithOptions defaultConfig commandLineOptions "options... programs..." $ \progs config -> Just $ runTests config progs
src/Futhark/CodeGen/Backends/CCUDA.hs view
@@ -22,6 +22,7 @@ import Futhark.CodeGen.Backends.CCUDA.Boilerplate import Futhark.CodeGen.Backends.GenericC.Options +-- | Compile the program to C with calls to CUDA. compileProg :: MonadFreshNames m => Prog KernelsMem -> m GC.CParts compileProg prog = do (Program cuda_code cuda_prelude kernel_names _ sizes failures prog') <-
src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs view
@@ -240,6 +240,7 @@ int detail_memory; int debugging; int profiling;+ int profiling_paused; typename lock_t lock; char *error; $sdecls:fields@@ -304,7 +305,7 @@ free(ctx); }|]) - GC.publicDef_ "context_sync" GC.InitDecl $ \s ->+ 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(cuCtxSynchronize());@@ -332,24 +333,13 @@ return 0; }|]) - GC.publicDef_ "context_get_error" GC.InitDecl $ \s ->- ([C.cedecl|char* $id:s(struct $id:ctx* ctx);|],- [C.cedecl|char* $id:s(struct $id:ctx* ctx) {- return ctx->error;- }|]) -- GC.publicDef_ "context_pause_profiling" GC.InitDecl $ \s ->- ([C.cedecl|void $id:s(struct $id:ctx* ctx);|],- [C.cedecl|void $id:s(struct $id:ctx* ctx) {- (void)ctx;- }|])-- GC.publicDef_ "context_unpause_profiling" GC.InitDecl $ \s ->- ([C.cedecl|void $id:s(struct $id:ctx* ctx);|],- [C.cedecl|void $id:s(struct $id:ctx* ctx) {- (void)ctx;- }|])+ GC.publicDef_ "context_clear_caches" GC.MiscDecl $ \s ->+ ([C.cedecl|int $id:s(struct $id:ctx* ctx);|],+ [C.cedecl|int $id:s(struct $id:ctx* ctx) {+ CUDA_SUCCEED(cuda_free_all(&ctx->cuda));+ return 0;+ }|]) where loadKernel (name, _) =
src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs view
@@ -339,6 +339,9 @@ // 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); }|] @@ -384,12 +387,12 @@ [C.cedecl|void $id:s(struct $id:ctx* ctx) { free_constants(ctx); free_lock(&ctx->lock);- opencl_tally_profiling_records(&ctx->opencl);- free(ctx->opencl.profiling_records);+ $stms:(map releaseKernel (M.toList kernels))+ teardown_opencl(&ctx->opencl); free(ctx); }|]) - GC.publicDef_ "context_sync" GC.InitDecl $ \s ->+ 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.@@ -422,27 +425,7 @@ return 0; }|]) - GC.publicDef_ "context_get_error" GC.InitDecl $ \s ->- ([C.cedecl|char* $id:s(struct $id:ctx* ctx);|],- [C.cedecl|char* $id:s(struct $id:ctx* ctx) {- char* error = ctx->error;- ctx->error = NULL;- return error;- }|])-- GC.publicDef_ "context_pause_profiling" GC.InitDecl $ \s ->- ([C.cedecl|void $id:s(struct $id:ctx* ctx);|],- [C.cedecl|void $id:s(struct $id:ctx* ctx) {- ctx->profiling_paused = 1;- }|])-- GC.publicDef_ "context_unpause_profiling" GC.InitDecl $ \s ->- ([C.cedecl|void $id:s(struct $id:ctx* ctx);|],- [C.cedecl|void $id:s(struct $id:ctx* ctx) {- ctx->profiling_paused = 0;- }|])-- GC.publicDef_ "context_clear_caches" GC.InitDecl $ \s ->+ GC.publicDef_ "context_clear_caches" GC.MiscDecl $ \s -> ([C.cedecl|int $id:s(struct $id:ctx* ctx);|], [C.cedecl|int $id:s(struct $id:ctx* ctx) { ctx->error = OPENCL_SUCCEED_NONFATAL(opencl_free_all(&ctx->opencl));@@ -526,6 +509,9 @@ SafetyCheap -> [set_global_failure] SafetyFull -> [set_global_failure, set_global_failure_args] +releaseKernel :: (KernelName, Safety) -> C.Stm+releaseKernel (name, _) = [C.cstm|OPENCL_SUCCEED_FATAL(clReleaseKernel(ctx->$id:name));|]+ kernelRuntime :: String -> String kernelRuntime = (++"_total_runtime") @@ -544,20 +530,18 @@ let runs = kernelRuns name total_runtime = kernelRuntime name in [[C.citem|- fprintf(stderr,- $string:(format_string name),- ctx->$id:runs,- (long int) ctx->$id:total_runtime / (ctx->$id:runs != 0 ? ctx->$id:runs : 1),- (long int) ctx->$id:total_runtime);+ str_builder(&builder,+ $string:(format_string name),+ ctx->$id:runs,+ (long int) ctx->$id:total_runtime / (ctx->$id:runs != 0 ? ctx->$id:runs : 1),+ (long int) ctx->$id:total_runtime); |], [C.citem|ctx->total_runtime += ctx->$id:total_runtime;|], [C.citem|ctx->total_runs += ctx->$id:runs;|]] report_total = [C.citem|- if (ctx->profiling) {- fprintf(stderr, "%d operations with cumulative runtime: %6ldus\n",- ctx->total_runs, ctx->total_runtime);- }+ str_builder(&builder, "%d operations with cumulative runtime: %6ldus\n",+ ctx->total_runs, ctx->total_runtime); |] sizeHeuristicsCode :: SizeHeuristic -> C.Stm
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -34,6 +34,7 @@ , contextContents , contextFinalInits , runCompilerM+ , cachingMemory , blockScope , compileFun , compileCode@@ -68,6 +69,7 @@ import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.RWS+import Data.Bifunctor (first) import Data.Bits (xor, shiftR) import Data.Char (ord, isDigit, isAlphaNum) import qualified Data.Map.Strict as M@@ -234,8 +236,16 @@ error "The default compiler cannot compile extended operations" -newtype CompilerEnv op s = CompilerEnv- { envOperations :: Operations op s }+data CompilerEnv op s = CompilerEnv+ { envOperations :: Operations op s+ , envCachedMem :: M.Map C.Exp VName+ -- ^ Mapping memory blocks to sizes. These memory blocks are CPU+ -- memory that we know are used in particularly simple ways (no+ -- reference counting necessary). To cut down on allocator+ -- pressure, we keep these allocations around for a long time, and+ -- record their sizes so we can reuse them if possible (and+ -- realloc() when needed).+ } newtype CompilerAcc op s = CompilerAcc { accItems :: DL.DList C.BlockItem@@ -275,9 +285,6 @@ envFatMemory :: CompilerEnv op s -> Bool envFatMemory = opsFatMemory . envOperations -newCompilerEnv :: Operations op s -> CompilerEnv op s-newCompilerEnv ops = CompilerEnv { envOperations = ops }- tupleDefinitions, arrayDefinitions, opaqueDefinitions :: CompilerState s -> [C.Definition] tupleDefinitions = map (snd . snd) . compTypeStructs arrayDefinitions = concatMap (snd . snd) . compArrayStructs@@ -323,7 +330,7 @@ -> CompilerM op s a -> (a, CompilerState s) runCompilerM ops src userstate (CompilerM m) =- let (x, s, _) = runRWS m (newCompilerEnv ops) (newCompilerState src userstate)+ let (x, s, _) = runRWS m (CompilerEnv ops mempty) (newCompilerState src userstate) in (x, s) getUserState :: CompilerM op s s@@ -353,6 +360,9 @@ fatMemory ScalarSpace{} = return False fatMemory _ = asks envFatMemory +cacheMem :: C.ToExp a => a -> CompilerM op s (Maybe VName)+cacheMem a = asks $ M.lookup (C.toExp a noLoc) . envCachedMem+ instance C.ToIdent Name where toIdent = C.toIdent . zEncodeString . nameToString @@ -446,10 +456,11 @@ name <- publicName "context" return [C.cty|struct $id:name|] -memToCType :: Space -> CompilerM op s C.Type-memToCType space = do+memToCType :: VName -> Space -> CompilerM op s C.Type+memToCType v space = do refcount <- fatMemory space- if refcount+ cached <- isJust <$> cacheMem v+ if refcount && not cached then return $ fatMemType space else rawMemCType space @@ -481,13 +492,31 @@ fatMemUnRef (Space sid) = "memblock_unref_" ++ sid fatMemUnRef _ = "memblock_unref" -rawMem :: C.ToExp a => a -> CompilerM op s C.Exp-rawMem v = rawMem' <$> asks envFatMemory <*> pure v+rawMem :: VName -> CompilerM op s C.Exp+rawMem v = rawMem' <$> fat <*> pure v+ where fat = (&&) <$> asks envFatMemory <*> (isNothing <$> cacheMem v) rawMem' :: C.ToExp a => Bool -> a -> C.Exp rawMem' True e = [C.cexp|$exp:e.mem|] rawMem' False e = [C.cexp|$exp:e|] +allocRawMem :: (C.ToExp a, C.ToExp b, C.ToExp c) =>+ a -> b -> Space -> c -> CompilerM op s ()+allocRawMem dest size space desc = case space of+ Space sid ->+ join $ asks envAllocate <*> pure [C.cexp|$exp:dest|] <*>+ pure [C.cexp|$exp:size|] <*> pure [C.cexp|$exp:desc|] <*> pure sid+ _ ->+ stm [C.cstm|$exp:dest = (char*) malloc($exp:size);|]++freeRawMem :: (C.ToExp a, C.ToExp b) =>+ a -> Space -> b -> CompilerM op s ()+freeRawMem mem space desc =+ case space of+ Space sid -> do free_mem <- asks envDeallocate+ free_mem [C.cexp|$exp:mem|] [C.cexp|$exp:desc|] sid+ _ -> item [C.citem|free($exp:mem);|]+ defineMemorySpace :: Space -> CompilerM op s (C.Definition, [C.Definition], C.BlockItem) defineMemorySpace space = do rm <- rawMemCType space@@ -503,10 +532,7 @@ -- Unreferencing a memory block consists of decreasing its reference -- count and freeing the corresponding memory if the count reaches -- zero.- free <- case space of- Space sid -> do free_mem <- asks envDeallocate- collect $ free_mem [C.cexp|block->mem|] [C.cexp|block->desc|] sid- _ -> return [[C.citem|free(block->mem);|]]+ free <- collect $ freeRawMem [C.cexp|block->mem|] space [C.cexp|desc|] ctx_ty <- contextType let unrefdef = [C.cedecl|static int $id:(fatMemUnRef space) ($ty:ctx_ty *ctx, $ty:mty *block, const char *desc) { if (block->references != NULL) {@@ -531,12 +557,7 @@ -- When allocating a memory block we initialise the reference count to 1. alloc <- collect $- case space of- Space sid ->- join $ asks envAllocate <*> pure [C.cexp|block->mem|] <*>- pure [C.cexp|size|] <*> pure [C.cexp|desc|] <*> pure sid- _ ->- stm [C.cstm|block->mem = (char*) malloc(size);|]+ allocRawMem [C.cexp|block->mem|] [C.cexp|size|] space [C.cexp|desc|] let allocdef = [C.cedecl|static int $id:(fatMemAlloc space) ($ty:ctx_ty *ctx, $ty:mty *block, typename int64_t size, const char *desc) { if (size < 0) { futhark_panic(1, "Negative allocation of %lld bytes attempted for %s in %s.\n",@@ -581,8 +602,12 @@ let peakmsg = "Peak memory usage for " ++ spacedesc ++ ": %lld bytes.\n" return (structdef, [unrefdef, allocdef, setdef],- [C.citem|fprintf(stderr, $string:peakmsg,- (long long) ctx->$id:peakname);|])+ -- Do not report memory usage for DefaultSpace (CPU memory),+ -- because it would not be accurate anyway. This whole+ -- tracking probably needs to be rethought.+ if space == DefaultSpace+ then [C.citem|{}|]+ else [C.citem|str_builder(&builder, $string:peakmsg, (long long) ctx->$id:peakname);|]) where mty = fatMemType space (peakname, usagename, sname, spacedesc) = case space of Space sid -> ("peak_mem_usage_" ++ sid,@@ -596,16 +621,21 @@ declMem :: VName -> Space -> CompilerM op s () declMem name space = do- ty <- memToCType space- decl [C.cdecl|$ty:ty $id:name;|]- resetMem name space- modify $ \s -> s { compDeclaredMem = (name, space) : compDeclaredMem s }+ cached <- isJust <$> cacheMem name+ unless cached $ do+ ty <- memToCType name space+ decl [C.cdecl|$ty:ty $id:name;|]+ resetMem name space+ modify $ \s -> s { compDeclaredMem = (name, space) : compDeclaredMem s } resetMem :: C.ToExp a => a -> Space -> CompilerM op s () resetMem mem space = do refcount <- fatMemory space- when refcount $- stm [C.cstm|$exp:mem.references = NULL;|]+ cached <- isJust <$> cacheMem mem+ if cached+ then stm [C.cstm|$exp:mem = NULL;|]+ else when refcount $+ stm [C.cstm|$exp:mem.references = NULL;|] setMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> CompilerM op s () setMem dest src space = do@@ -621,29 +651,25 @@ unRefMem :: C.ToExp a => a -> Space -> CompilerM op s () unRefMem mem space = do refcount <- fatMemory space+ cached <- isJust <$> cacheMem mem let mem_s = pretty $ C.toExp mem noLoc- when refcount $+ when (refcount && not cached) $ stm [C.cstm|if ($id:(fatMemUnRef space)(ctx, &$exp:mem, $string:mem_s) != 0) {- return 1;- }|]+ return 1;+ }|] allocMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> C.Stm -> CompilerM op s ()-allocMem name size space on_failure = do+allocMem mem size space on_failure = do refcount <- fatMemory space- let name_s = pretty $ C.toExp name noLoc+ let mem_s = pretty $ C.toExp mem noLoc if refcount- then stm [C.cstm|if ($id:(fatMemAlloc space)(ctx, &$exp:name, $exp:size,- $string:name_s)) {+ then stm [C.cstm|if ($id:(fatMemAlloc space)(ctx, &$exp:mem, $exp:size,+ $string:mem_s)) { $stm:on_failure }|]- else alloc name- where alloc dest = case space of- Space sid ->- join $ asks envAllocate <*> rawMem name <*>- pure [C.cexp|$exp:size|] <*> pure [C.cexp|desc|] <*> pure sid- _ ->- stm [C.cstm|$exp:dest = (char*) malloc($exp:size);|]+ else do freeRawMem mem space mem_s+ allocRawMem mem size space [C.cexp|desc|] primTypeInfo :: PrimType -> Signedness -> C.Exp primTypeInfo (IntType it) t = case (it, t) of@@ -719,7 +745,6 @@ arr_size_array = cproduct [ [C.cexp|arr->shape[$int:i]|] | i <- [0..rank-1] ] copy <- asks envCopy - arr_raw_mem <- rawMem [C.cexp|arr->mem|] memty <- rawMemCType space let prepare_new = do@@ -732,13 +757,13 @@ new_body <- collect $ do prepare_new- copy arr_raw_mem [C.cexp|0|] space+ copy [C.cexp|arr->mem.mem|] [C.cexp|0|] space [C.cexp|data|] [C.cexp|0|] DefaultSpace [C.cexp|((size_t)$exp:arr_size) * sizeof($ty:pt')|] new_raw_body <- collect $ do prepare_new- copy arr_raw_mem [C.cexp|0|] space+ copy [C.cexp|arr->mem.mem|] [C.cexp|0|] space [C.cexp|data|] [C.cexp|offset|] space [C.cexp|((size_t)$exp:arr_size) * sizeof($ty:pt')|] @@ -746,7 +771,7 @@ values_body <- collect $ copy [C.cexp|data|] [C.cexp|0|] DefaultSpace- arr_raw_mem [C.cexp|0|] space+ [C.cexp|arr->mem.mem|] [C.cexp|0|] space [C.cexp|((size_t)$exp:arr_size_array) * sizeof($ty:pt')|] ctx_ty <- contextType@@ -764,7 +789,7 @@ headerDecl (ArrayDecl name) [C.cedecl|$ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr);|] headerDecl (ArrayDecl name)- [C.cedecl|typename int64_t* $id:shape_array($ty:ctx_ty *ctx, $ty:array_type *arr);|]+ [C.cedecl|const typename int64_t* $id:shape_array($ty:ctx_ty *ctx, $ty:array_type *arr);|] return [C.cunit| $ty:array_type* $id:new_array($ty:ctx_ty *ctx, $ty:pt' *data, $params:shape_params) {@@ -801,10 +826,10 @@ $ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr) { (void)ctx;- return $exp:arr_raw_mem;+ return arr->mem.mem; } - typename int64_t* $id:shape_array($ty:ctx_ty *ctx, $ty:array_type *arr) {+ const typename int64_t* $id:shape_array($ty:ctx_ty *ctx, $ty:array_type *arr) { (void)ctx; return arr->shape; }@@ -846,14 +871,14 @@ valueDescToCType :: ValueDesc -> CompilerM op s C.Type valueDescToCType (ScalarValue pt signed _) = return $ signedPrimTypeToCType signed pt-valueDescToCType (ArrayValue _ space pt signed shape) = do+valueDescToCType (ArrayValue mem space pt signed shape) = do let pt' = signedPrimTypeToCType signed pt rank = length shape exists <- gets $ lookup (pt',rank) . compArrayStructs case exists of Just (cty, _) -> return cty Nothing -> do- memty <- memToCType space+ memty <- memToCType mem space name <- publicName $ arrayName pt signed rank let struct = [C.cedecl|struct $id:name { $ty:memty mem; typename int64_t shape[$int:rank]; };|] stype = [C.cty|struct $id:name|]@@ -1372,8 +1397,9 @@ // side effects), we want to avoid that. $esc:("#undef NDEBUG") $esc:("#include <assert.h>")+$esc:("#include <stdarg.h>") -$esc:futhark_panic_h+$esc:util_h $esc:timing_h |]@@ -1461,7 +1487,9 @@ fclose(runtime_file); } - futhark_debugging_report(ctx);+ char *report = futhark_context_report(ctx);+ fputs(report, stderr);+ free(report); } futhark_context_free(ctx);@@ -1517,20 +1545,12 @@ mapM_ earlyDecl memstructs entry_points <- mapM (uncurry onEntryPoint) $ filter (functionEntry . snd) funs+ extra+ mapM_ earlyDecl $ concat memfuns- profilereport <- gets $ DL.toList . compProfileItems - ctx_ty <- contextType- headerDecl MiscDecl [C.cedecl|void futhark_debugging_report($ty:ctx_ty *ctx);|]- libDecl [C.cedecl|void futhark_debugging_report($ty:ctx_ty *ctx) {- if (ctx->detail_memory || ctx->profiling) {- $items:memreport- }- if (ctx->profiling) {- $items:profilereport- }- }|]+ commonLibFuns memreport return (prototypes, definitions, entry_points) @@ -1542,12 +1562,51 @@ builtin = cIntOps ++ cFloat32Ops ++ cFloat64Ops ++ cFloatConvOps ++ cFloat32Funs ++ cFloat64Funs - futhark_panic_h = $(embedStringFile "rts/c/panic.h")+ util_h = $(embedStringFile "rts/c/util.h") values_h = $(embedStringFile "rts/c/values.h") timing_h = $(embedStringFile "rts/c/timing.h") lock_h = $(embedStringFile "rts/c/lock.h") tuning_h = $(embedStringFile "rts/c/tuning.h") +commonLibFuns :: [C.BlockItem] -> CompilerM op s ()+commonLibFuns memreport = do+ ctx <- contextType+ profilereport <- gets $ DL.toList . compProfileItems++ publicDef_ "context_report" MiscDecl $ \s ->+ ([C.cedecl|char* $id:s($ty:ctx *ctx);|],+ [C.cedecl|char* $id:s($ty:ctx *ctx) {+ struct str_builder builder;+ str_builder_init(&builder);+ if (ctx->detail_memory || ctx->profiling) {+ $items:memreport+ }+ if (ctx->profiling) {+ $items:profilereport+ }+ return builder.str;+ }|])++ publicDef_ "context_get_error" MiscDecl $ \s ->+ ([C.cedecl|char* $id:s($ty:ctx* ctx);|],+ [C.cedecl|char* $id:s($ty:ctx* ctx) {+ char* error = ctx->error;+ ctx->error = NULL;+ return error;+ }|])++ publicDef_ "context_pause_profiling" MiscDecl $ \s ->+ ([C.cedecl|void $id:s($ty:ctx* ctx);|],+ [C.cedecl|void $id:s($ty:ctx* ctx) {+ ctx->profiling_paused = 1;+ }|])++ publicDef_ "context_unpause_profiling" MiscDecl $ \s ->+ ([C.cedecl|void $id:s($ty:ctx* ctx);|],+ [C.cedecl|void $id:s($ty:ctx* ctx) {+ ctx->profiling_paused = 0;+ }|])+ compileConstants :: Constants op -> CompilerM op s [C.BlockItem] compileConstants (Constants ps init_consts) = do ctx_ty <- contextType@@ -1565,10 +1624,12 @@ mapM_ resetMemConst ps compileCode init_consts libDecl [C.cedecl|int init_constants($ty:ctx_ty *ctx) {+ int err = 0; $items:defs $items:init_consts' $items:undefs- return 0;+ cleanup:+ return err; }|] free_consts <- collect $ mapM_ freeConst ps@@ -1583,7 +1644,7 @@ let ctp = primTypeToCType bt return [C.csdecl|$ty:ctp $id:name;|] constParamField (MemParam name space) = do- ty <- memToCType space+ ty <- memToCType name space return [C.csdecl|$ty:ty $id:name;|] constMacro p = ([C.citem|$escstm:def|], [C.citem|$escstm:undef|])@@ -1601,28 +1662,67 @@ let ctp = primTypeToCType bt return [C.citem|$ty:ctp $id:name = ctx->constants.$id:name;|] getConst (MemParam name space) = do- ty <- memToCType space+ ty <- memToCType name space return [C.citem|$ty:ty $id:name = ctx->constants.$id:name;|] +cachingMemory :: M.Map VName Space+ -> ([C.BlockItem] -> [C.Stm] -> CompilerM op s a)+ -> CompilerM op s a+cachingMemory lexical f = do+ -- We only consider lexical 'DefaultSpace' memory blocks to be+ -- cached. This is not a deep technical restriction, but merely a+ -- heuristic based on GPU memory usually involving larger+ -- allocations, that do not suffer from the overhead of reference+ -- counting.+ let cached = M.keys $ M.filter (==DefaultSpace) lexical++ cached' <- forM cached $ \mem -> do+ size <- newVName $ pretty mem <> "_cached_size"+ return (mem, size)++ let lexMem env =+ env { envCachedMem =+ M.fromList (map (first (`C.toExp` noLoc)) cached')+ <> envCachedMem env+ }++ declCached (mem, size) =+ [[C.citem|size_t $id:size = 0;|],+ [C.citem|$ty:defaultMemBlockType $id:mem = NULL;|]]++ freeCached (mem, _) =+ [C.cstm|free($id:mem);|]++ local lexMem $ f (concatMap declCached cached') (map freeCached cached')+ compileFun :: [C.BlockItem] -> (Name, Function op) -> CompilerM op s (C.Definition, C.Func)-compileFun get_constants (fname, Function _ outputs inputs body _ _) = do+compileFun get_constants (fname, func@(Function _ outputs inputs body _ _)) = do (outparams, out_ptrs) <- unzip <$> mapM compileOutput outputs inparams <- mapM compileInput inputs- body' <- blockScope $ compileFunBody out_ptrs outputs body- ctx_ty <- contextType- return ([C.cedecl|static int $id:(funName fname)($ty:ctx_ty *ctx,- $params:outparams, $params:inparams);|],- [C.cfun|static int $id:(funName fname)($ty:ctx_ty *ctx,- $params:outparams, $params:inparams) {- $items:get_constants- $items:body'- return 0;-}|])++ cachingMemory (lexicalMemoryUsage func) $ \decl_cached free_cached -> do+ body' <- blockScope $ compileFunBody out_ptrs outputs body++ ctx_ty <- contextType+ return ([C.cedecl|static int $id:(funName fname)($ty:ctx_ty *ctx,+ $params:outparams, $params:inparams);|],+ [C.cfun|static int $id:(funName fname)($ty:ctx_ty *ctx,+ $params:outparams, $params:inparams) {+ int err = 0;+ $items:decl_cached+ $items:get_constants+ $items:body'+ cleanup:+ {}+ $stms:free_cached+ return err;+ }|])+ where compileInput (ScalarParam name bt) = do let ctp = primTypeToCType bt return [C.cparam|$ty:ctp $id:name|] compileInput (MemParam name space) = do- ty <- memToCType space+ ty <- memToCType name space return [C.cparam|$ty:ty $id:name|] compileOutput (ScalarParam name bt) = do@@ -1630,7 +1730,7 @@ p_name <- newVName $ "out_" ++ baseString name return ([C.cparam|$ty:ctp *$id:p_name|], [C.cexp|$id:p_name|]) compileOutput (MemParam name space) = do- ty <- memToCType space+ ty <- memToCType name space p_name <- newVName $ baseString name ++ "_p" return ([C.cparam|$ty:ty *$id:p_name|], [C.cexp|$id:p_name|]) @@ -1778,12 +1878,15 @@ compilePrimExp f (BinOpExp bop x y) = do x' <- compilePrimExp f x y' <- compilePrimExp f y- -- Note that integer addition, subtraction, and multiplication are- -- not handled by explicit operators, but rather by functions. This- -- is because we want to implicitly convert them to unsigned- -- numbers, so we can do overflow without invoking undefined- -- behaviour.+ -- Note that integer addition, subtraction, and multiplication with+ -- OverflowWrap are not handled by explicit operators, but rather by+ -- functions. This is because we want to implicitly convert them to+ -- unsigned numbers, so we can do overflow without invoking+ -- undefined behaviour. return $ case bop of+ Add _ OverflowUndef -> [C.cexp|$exp:x' + $exp:y'|]+ Sub _ OverflowUndef -> [C.cexp|$exp:x' - $exp:y'|]+ Mul _ OverflowUndef -> [C.cexp|$exp:x' * $exp:y'|] FAdd{} -> [C.cexp|$exp:x' + $exp:y'|] FSub{} -> [C.cexp|$exp:x' - $exp:y'|] FMul{} -> [C.cexp|$exp:x' * $exp:y'|]@@ -1853,10 +1956,19 @@ compileCode (Allocate name (Count e) space) = do size <- compileExp e- allocMem name size space [C.cstm|return 1;|]+ cached <- cacheMem name+ case cached of+ Just cur_size ->+ stm [C.cstm|if ($exp:cur_size < $exp:size) {+ $exp:name = realloc($exp:name, $exp:size);+ $exp:cur_size = $exp:size;+ }|]+ _ ->+ allocMem name size space [C.cstm|{err = 1; goto cleanup;}|] -compileCode (Free name space) =- unRefMem name space+compileCode (Free name space) = do+ cached <- isJust <$> cacheMem name+ unless cached $ unRefMem name space compileCode (For i it bound body) = do let i' = C.toIdent i@@ -1978,7 +2090,7 @@ [dest] | isBuiltInFunction fname -> stm [C.cstm|$id:dest = $id:(funName fname)($args:args'');|] _ ->- item [C.citem|if ($id:(funName fname)($args:args'') != 0) { return 1; }|]+ item [C.citem|if ($id:(funName fname)($args:args'') != 0) { err = 1; goto cleanup; }|] where compileArg (MemArg m) = return [C.cexp|$exp:m|] compileArg (ExpArg e) = compileExp e @@ -2015,11 +2127,19 @@ stm [C.cstm|*$exp:p = $id:name;|] declareAndSet :: Code op -> Maybe (VName, Volatility, PrimType, Exp, Code op)-declareAndSet (DeclareScalar name vol t :>>: (SetScalar dest e :>>: c))- | name == dest = Just (name, vol, t, e, c)-declareAndSet ((DeclareScalar name vol t :>>: SetScalar dest e) :>>: c)- | name == dest = Just (name, vol, t, e, c)-declareAndSet _ = Nothing+declareAndSet code = do+ (DeclareScalar name vol t, code') <- nextCode code+ (SetScalar dest e, code'') <- nextCode code'+ guard $ name == dest+ Just (name, vol, t, e, code'')++nextCode :: Code op -> Maybe (Code op, Code op)+nextCode (x :>>: y)+ | Just (x_a, x_b) <- nextCode x =+ Just (x_a, x_b <> y)+ | otherwise =+ Just (x, y)+nextCode _ = Nothing assignmentOperator :: BinOp -> Maybe (VName -> C.Exp -> C.Exp) assignmentOperator Add{} = Just $ \d e -> [C.cexp|$id:d += $exp:e|]
src/Futhark/CodeGen/Backends/SequentialC.hs view
@@ -19,6 +19,7 @@ import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.MonadFreshNames +-- | Compile the program to sequential C. compileProg :: MonadFreshNames m => Prog SeqMem -> m GC.CParts compileProg = GC.compileProg operations generateContext "" [DefaultSpace] [] <=<@@ -74,6 +75,7 @@ int profiling; typename lock_t lock; char *error;+ int profiling_paused; $sdecls:fields };|]) @@ -102,31 +104,20 @@ free(ctx); }|]) - GC.publicDef_ "context_sync" GC.InitDecl $ \s ->+ 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.publicDef_ "context_get_error" GC.InitDecl $ \s ->- ([C.cedecl|char* $id:s(struct $id:ctx* ctx);|],- [C.cedecl|char* $id:s(struct $id:ctx* ctx) {- char* error = ctx->error;- ctx->error = NULL;- return error;- }|]) - GC.publicDef_ "context_pause_profiling" GC.InitDecl $ \s ->- ([C.cedecl|void $id:s(struct $id:ctx* ctx);|],- [C.cedecl|void $id:s(struct $id:ctx* ctx) {- (void)ctx;- }|])+ GC.publicDef_ "context_clear_caches" 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.publicDef_ "context_unpause_profiling" GC.InitDecl $ \s ->- ([C.cedecl|void $id:s(struct $id:ctx* ctx);|],- [C.cedecl|void $id:s(struct $id:ctx* ctx) {- (void)ctx;- }|]) copySequentialMemory :: GC.Copy Imp.Sequential () copySequentialMemory destmem destidx DefaultSpace srcmem srcidx DefaultSpace nbytes =
src/Futhark/CodeGen/ImpCode.hs view
@@ -38,6 +38,8 @@ , errorMsgArgTypes , ArrayContents(..) + , lexicalMemoryUsage+ -- * Typed enumerations , Bytes , Elements@@ -50,12 +52,14 @@ , module Futhark.Representation.Primitive , module Futhark.Analysis.PrimExp , module Futhark.Representation.Kernels.Sizes+ , module Futhark.Representation.AST.Attributes.Names ) where import Data.List (intersperse) import Data.Loc import Data.Traversable+import qualified Data.Map as M import Language.Futhark.Core import Futhark.Representation.Primitive@@ -210,6 +214,35 @@ instance Monoid (Code a) where mempty = Skip++-- | Find those memory blocks that are used only lexically. That is,+-- are not used as the source or target of a 'SetMem', or are the+-- result of the function. This is interesting because such memory+-- blocks do not need reference counting, but can be managed in a+-- purely stack-like fashion.+--+-- We do not look inside any 'Op's. We assume that no 'Op' is going+-- to 'SetMem' a memory block declared outside it.+lexicalMemoryUsage :: Function a -> M.Map VName Space+lexicalMemoryUsage func =+ M.filterWithKey (const . not . (`nameIn` nonlexical)) $+ declared $ functionBody func+ where nonlexical =+ set (functionBody func) <>+ namesFromList (map paramName (functionOutput func))++ go f (x :>>: y) = f x <> f y+ go f (If _ x y) = f x <> f y+ go f (For _ _ _ x) = f x+ go f (While _ x) = f x+ go f (Comment _ x) = f x+ go _ _ = mempty++ declared (DeclareMem mem space) = M.singleton mem space+ declared x = go declared x++ set (SetMem x y _) = namesFromList [x,y]+ set x = go set x data ExpLeaf = ScalarVar VName | SizeOf PrimType
src/Futhark/CodeGen/ImpCode/Kernels.hs view
@@ -24,7 +24,6 @@ import Futhark.CodeGen.ImpCode hiding (Function, Code) import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.Representation.Kernels.Sizes-import Futhark.Representation.AST.Attributes.Names import Futhark.Representation.AST.Pretty () import Futhark.Util.Pretty
src/Futhark/CodeGen/ImpCode/Sequential.hs view
@@ -11,7 +11,6 @@ import Futhark.CodeGen.ImpCode hiding (Function, Code) import qualified Futhark.CodeGen.ImpCode as Imp-import Futhark.Representation.AST.Attributes.Names import Futhark.Util.Pretty
src/Futhark/CodeGen/ImpGen.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, LambdaCase, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-} module Futhark.CodeGen.ImpGen ( -- * Entry Points compileProg@@ -72,7 +74,7 @@ , sIf, sWhen, sUnless , sOp , sDeclareMem, sAlloc, sAlloc_- , sArray, sAllocArray, sAllocArrayPerm, sStaticArray+ , sArray, sArrayInMem, sAllocArray, sAllocArrayPerm, sStaticArray , sWrite, sUpdate , sLoopNest , (<--)@@ -81,13 +83,12 @@ ) where -import Control.Monad.RWS hiding (mapM, forM)-import Control.Monad.State hiding (mapM, forM, State)-import Control.Monad.Writer hiding (mapM, forM)+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer import Data.Bifunctor (first) import qualified Data.DList as DL import Data.Either-import Data.Traversable import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe@@ -217,19 +218,21 @@ -- | The symbol table used during compilation. type VTable lore = M.Map VName (VarEntry lore) -data State lore r op = State { stateVTable :: VTable lore- , stateFunctions :: Imp.Functions op- , stateNameSource :: VNameSource- }+data ImpState lore r op =+ ImpState { stateVTable :: VTable lore+ , stateFunctions :: Imp.Functions op+ , stateCode :: Imp.Code op+ , stateNameSource :: VNameSource+ } -newState :: VNameSource -> State lore r op-newState = State mempty mempty+newState :: VNameSource -> ImpState lore r op+newState = ImpState mempty mempty mempty -newtype ImpM lore r op a = ImpM (RWS (Env lore r op) (Imp.Code op) (State lore r op) a)+newtype ImpM lore r op a =+ ImpM (ReaderT (Env lore r op) (State (ImpState lore r op)) a) deriving (Functor, Applicative, Monad,- MonadState (State lore r op),- MonadReader (Env lore r op),- MonadWriter (Imp.Code op))+ MonadState (ImpState lore r op),+ MonadReader (Env lore r op)) instance MonadFreshNames (ImpM lore r op) where getNameSource = gets stateNameSource@@ -250,9 +253,9 @@ Prim $ entryScalarType scalarEntry runImpM :: ImpM lore r op a- -> r -> Operations lore r op -> Imp.Space -> State lore r op- -> (a, State lore r op, Imp.Code op)-runImpM (ImpM m) r ops space = runRWS m $ newEnv r ops space+ -> r -> Operations lore r op -> Imp.Space -> ImpState lore r op+ -> (a, ImpState lore r op)+runImpM (ImpM m) r ops space = runState (runReaderT m $ newEnv r ops space) subImpM_ :: r' -> Operations lore r' op' -> ImpM lore r' op' a -> ImpM lore r op (Imp.Code op')@@ -263,30 +266,37 @@ subImpM r ops (ImpM m) = do env <- ask s <- get- let (x, s', code) =- runRWS m env { envExpCompiler = opsExpCompiler ops- , envStmsCompiler = opsStmsCompiler ops- , envCopyCompiler = opsCopyCompiler ops- , envOpCompiler = opsOpCompiler ops- , envAllocCompilers = opsAllocCompilers ops- , envEnv = r- }- s { stateVTable = stateVTable s- , stateFunctions = mempty }- putNameSource $ stateNameSource s'- return (x, code) + let env' = env { envExpCompiler = opsExpCompiler ops+ , envStmsCompiler = opsStmsCompiler ops+ , envCopyCompiler = opsCopyCompiler ops+ , envOpCompiler = opsOpCompiler ops+ , envAllocCompilers = opsAllocCompilers ops+ , envEnv = r+ }+ s' = ImpState { stateVTable = stateVTable s+ , stateFunctions = mempty+ , stateCode = mempty+ , stateNameSource = stateNameSource s+ }+ (x, s'') = runState (runReaderT m env') s'++ putNameSource $ stateNameSource s''+ return (x, stateCode s'')+ -- | Execute a code generation action, returning the code that was -- emitted. collect :: ImpM lore r op () -> ImpM lore r op (Imp.Code op)-collect m = pass $ do- ((), code) <- listen m- return (code, const mempty)+collect = fmap snd . collect' collect' :: ImpM lore r op a -> ImpM lore r op (a, Imp.Code op)-collect' m = pass $ do- (x, code) <- listen m- return ((x, code), const mempty)+collect' m = do+ prev_code <- gets stateCode+ modify $ \s -> s { stateCode = mempty }+ x <- m+ new_code <- gets stateCode+ modify $ \s -> s { stateCode = prev_code }+ return (x, new_code) -- | Execute a code generation action, wrapping the generated code -- within a 'Imp.Comment' with the given description.@@ -296,7 +306,7 @@ -- | Emit some generated imperative code. emit :: Imp.Code op -> ImpM lore r op ()-emit = tell+emit code = modify $ \s -> s { stateCode = stateCode s <> code } -- | Emit a function in the generated code. emitFunction :: Name -> Imp.Function op -> ImpM lore r op ()@@ -321,7 +331,7 @@ -> Prog lore -> m (Imp.Definitions op) compileProg r ops space (Prog consts funs) = modifyNameSource $ \src ->- let (consts', s', _) =+ let (consts', s') = runImpM compile r ops space (newState src) { stateVTable = constsVTable consts } in (Imp.Definitions consts' (stateFunctions s'),@@ -1016,9 +1026,9 @@ | otherwise = copyElementWise bt dest destslice src srcslice where bt_size = primByteSize bt- num_elems = Imp.elements $ product $ map (toExp' int32) srcshape+ num_elems = Imp.elements $ product $ sliceDims srcslice MemLocation destmem _ destIxFun = dest- MemLocation srcmem srcshape srcIxFun = src+ MemLocation srcmem _ srcIxFun = src isScalarSpace ScalarSpace{} = True isScalarSpace _ = False @@ -1130,7 +1140,8 @@ emit $ Imp.SetScalar name $ Imp.var src pt (ScalarDestination name, ArrayVar _ arr)- | Just src_is <- mapM dimFix src_slice -> do+ | Just src_is <- mapM dimFix src_slice,+ length src_slice == length (entryArrayShape arr) -> do let bt = entryArrayElemType arr (mem, space, i) <- fullyIndexArray' (entryArrayLocation arr) src_is@@ -1274,6 +1285,12 @@ name' <- newVName name dArray name' bt shape membind return name'++-- | Declare an array in row-major order in the given memory block.+sArrayInMem :: String -> PrimType -> ShapeBase SubExp -> VName -> ImpM lore r op VName+sArrayInMem name pt shape mem =+ sArray name pt shape $ ArrayIn mem $+ IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape -- | Like 'sAllocArray', but permute the in-memory representation of the indices as specified. sAllocArrayPerm :: String -> PrimType -> ShapeBase SubExp -> Space -> [Int] -> ImpM lore r op VName
src/Futhark/CodeGen/ImpGen/Kernels.hs view
@@ -2,6 +2,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-}+-- | Compile a 'KernelsMem' program to imperative code with kernels.+-- This is mostly (but not entirely) the same process no matter if we+-- are targeting OpenCL or CUDA. The important distinctions (the host+-- level code) are introduced later. module Futhark.CodeGen.ImpGen.Kernels ( compileProgOpenCL , compileProgCUDA@@ -42,7 +46,7 @@ openclAtomics, cudaAtomics :: AtomicBinOp (openclAtomics, cudaAtomics) = (flip lookup opencl, flip lookup cuda)- where opencl = [ (Add Int32, Imp.AtomicAdd Int32)+ where opencl = [ (Add Int32 OverflowUndef, Imp.AtomicAdd Int32) , (SMax Int32, Imp.AtomicSMax Int32) , (SMin Int32, Imp.AtomicSMin Int32) , (UMax Int32, Imp.AtomicUMax Int32)@@ -124,8 +128,8 @@ compileSegMap pat lvl space kbody segOpCompiler pat (SegRed lvl@SegThread{} space reds _ kbody) = compileSegRed pat lvl space reds kbody-segOpCompiler pat (SegScan lvl@SegThread{} space scan_op nes _ kbody) =- compileSegScan pat lvl space scan_op nes kbody+segOpCompiler pat (SegScan lvl@SegThread{} space scans _ kbody) =+ compileSegScan pat lvl space scans kbody segOpCompiler pat (SegHist (SegThread num_groups group_size _) space ops _ kbody) = compileSegHist pat num_groups group_size space ops kbody segOpCompiler pat segop =
src/Futhark/CodeGen/ImpGen/Kernels/Base.hs view
@@ -23,6 +23,7 @@ , groupLoop , kernelLoop , groupCoverSpace+ , precomputeSegOpIDs , atomicUpdateLocking , AtomicBinOp@@ -35,6 +36,7 @@ import Control.Monad.Except import Data.Maybe import qualified Data.Map.Strict as M+import qualified Data.Set as S import Data.List (elemIndex, find, nub, zip4) import Prelude hiding (quot, rem)@@ -60,20 +62,48 @@ type CallKernelGen = ImpM KernelsMem HostEnv Imp.HostOp type InKernelGen = ImpM KernelsMem KernelEnv Imp.KernelOp -data KernelConstants = KernelConstants- { kernelGlobalThreadId :: Imp.Exp- , kernelLocalThreadId :: Imp.Exp- , kernelGroupId :: Imp.Exp- , kernelGlobalThreadIdVar :: VName- , kernelLocalThreadIdVar :: VName- , kernelGroupIdVar :: VName- , kernelNumGroups :: Imp.Exp- , kernelGroupSize :: Imp.Exp- , kernelNumThreads :: Imp.Exp- , kernelWaveSize :: Imp.Exp- , kernelThreadActive :: Imp.Exp- }+data KernelConstants =+ KernelConstants+ { kernelGlobalThreadId :: Imp.Exp+ , kernelLocalThreadId :: Imp.Exp+ , kernelGroupId :: Imp.Exp+ , kernelGlobalThreadIdVar :: VName+ , kernelLocalThreadIdVar :: VName+ , kernelGroupIdVar :: VName+ , kernelNumGroups :: Imp.Exp+ , kernelGroupSize :: Imp.Exp+ , kernelNumThreads :: Imp.Exp+ , kernelWaveSize :: Imp.Exp+ , kernelThreadActive :: Imp.Exp+ , kernelLocalIdMap :: M.Map [SubExp] [Imp.Exp]+ -- ^ A mapping from dimensions of nested SegOps to already+ -- computed local thread IDs.+ } +segOpSizes :: Stms KernelsMem -> S.Set [SubExp]+segOpSizes = onStms+ where onStms = foldMap (onExp . stmExp)+ onExp (Op (Inner (SegOp op))) =+ S.singleton $ map snd $ unSegSpace $ segSpace op+ onExp (If _ tbranch fbranch _) =+ onStms (bodyStms tbranch) <> onStms (bodyStms fbranch)+ onExp (DoLoop _ _ _ body) =+ onStms (bodyStms body)+ onExp _ = mempty++precomputeSegOpIDs :: Stms KernelsMem -> InKernelGen a -> InKernelGen a+precomputeSegOpIDs stms m = do+ ltid <- kernelLocalThreadId . kernelConstants <$> askEnv+ new_ids <- M.fromList <$> mapM (mkMap ltid) (S.toList (segOpSizes stms))+ let f env = env { kernelConstants =+ (kernelConstants env) { kernelLocalIdMap = new_ids }+ }+ localEnv f m+ where mkMap ltid dims = do+ dims' <- mapM toExp dims+ ids' <- mapM (dPrimVE "ltid_pre") $ unflattenIndex dims' ltid+ return (dims, ids')+ keyWithEntryPoint :: Maybe Name -> Name -> Name keyWithEntryPoint fname key = nameFromString $ maybe "" ((++".") . nameToString) fname ++ nameToString key@@ -169,25 +199,27 @@ x <- dPrimV "x" $ e' + i' * s' copyDWIMFix (patElemName dest) [i'] (Var x) [] sOp $ Imp.Barrier Imp.FenceLocal-compileGroupExp dest e = do+compileGroupExp dest e = defCompileExp dest e- when (any ((>0) . arrayRank) (patternTypes dest)) $- sOp $ Imp.Barrier Imp.FenceLocal sanityCheckLevel :: SegLevel -> InKernelGen () sanityCheckLevel SegThread{} = return () sanityCheckLevel SegGroup{} = error "compileGroupOp: unexpected group-level SegOp." +localThreadIDs :: [SubExp] -> InKernelGen [Imp.Exp]+localThreadIDs dims = do+ ltid <- kernelLocalThreadId . kernelConstants <$> askEnv+ dims' <- mapM toExp dims+ fromMaybe (unflattenIndex dims' ltid) .+ M.lookup dims . kernelLocalIdMap . kernelConstants <$> askEnv+ compileGroupSpace :: SegLevel -> SegSpace -> InKernelGen () compileGroupSpace lvl space = do sanityCheckLevel lvl- let (ltids, dims) = unzip $ unSegSpace space- dims' <- mapM toExp dims+ zipWithM_ dPrimV_ ltids =<< localThreadIDs dims ltid <- kernelLocalThreadId . kernelConstants <$> askEnv- zipWithM_ dPrimV_ ltids $ unflattenIndex dims' ltid- dPrimV_ (segFlat space) ltid -- Construct the necessary lock arrays for an intra-group histogram.@@ -229,6 +261,11 @@ return (Just l', f l' (Space "local") local_subhistos) +whenActive :: SegLevel -> SegSpace -> InKernelGen () -> InKernelGen ()+whenActive lvl space m+ | SegNoVirtFull <- segVirt lvl = m+ | otherwise = sWhen (isActive $ unSegSpace space) m+ compileGroupOp :: OpCompiler KernelsMem KernelEnv Imp.KernelOp compileGroupOp pat (Alloc size space) =@@ -240,19 +277,19 @@ compileGroupOp pat (Inner (SegOp (SegMap lvl space _ body))) = do void $ compileGroupSpace lvl space - sWhen (isActive $ unSegSpace space) $ localOps threadOperations $+ whenActive lvl space $ localOps threadOperations $ compileStms mempty (kernelBodyStms body) $ zipWithM_ (compileThreadResult space) (patternElements pat) $ kernelBodyResult body sOp $ Imp.ErrorSync Imp.FenceLocal -compileGroupOp pat (Inner (SegOp (SegScan lvl space scan_op _ _ body))) = do+compileGroupOp pat (Inner (SegOp (SegScan lvl space scans _ body))) = do compileGroupSpace lvl space let (ltids, dims) = unzip $ unSegSpace space dims' <- mapM toExp dims - sWhen (isActive $ unSegSpace space) $+ whenActive lvl space $ compileStms mempty (kernelBodyStms body) $ forM_ (zip (patternNames pat) $ kernelBodyResult body) $ \(dest, res) -> copyDWIMFix dest@@ -263,27 +300,30 @@ let segment_size = last dims' crossesSegment from to = (to-from) .>. (to `rem` segment_size)- groupScan (Just crossesSegment) (product dims') (product dims') scan_op $- patternNames pat + forM_ scans $ \scan -> do+ let scan_op = segBinOpLambda scan+ groupScan (Just crossesSegment) (product dims') (product dims') scan_op $+ patternNames pat+ compileGroupOp pat (Inner (SegOp (SegRed lvl space ops _ body))) = do compileGroupSpace lvl space let (ltids, dims) = unzip $ unSegSpace space (red_pes, map_pes) =- splitAt (segRedResults ops) $ patternElements pat+ splitAt (segBinOpResults ops) $ patternElements pat dims' <- mapM toExp dims let mkTempArr t = sAllocArray "red_arr" (elemType t) (Shape dims <> arrayShape t) $ Space "local"- tmp_arrs <- mapM mkTempArr $ concatMap (lambdaReturnType . segRedLambda) ops- let tmps_for_ops = chunks (map (length . segRedNeutral) ops) tmp_arrs+ tmp_arrs <- mapM mkTempArr $ concatMap (lambdaReturnType . segBinOpLambda) ops+ let tmps_for_ops = chunks (map (length . segBinOpNeutral) ops) tmp_arrs - sWhen (isActive $ unSegSpace space) $+ whenActive lvl space $ compileStms mempty (kernelBodyStms body) $ do let (red_res, map_res) =- splitAt (segRedResults ops) $ kernelBodyResult body+ splitAt (segBinOpResults ops) $ kernelBodyResult body forM_ (zip tmp_arrs red_res) $ \(dest, res) -> copyDWIMFix dest (map (`Imp.var` int32) ltids) (kernelResultSubExp res) [] zipWithM_ (compileThreadResult space) map_pes map_res@@ -295,7 +335,7 @@ -- handle directly with a group-level reduction. [dim'] -> do forM_ (zip ops tmps_for_ops) $ \(op, tmps) ->- groupReduce dim' (segRedLambda op) tmps+ groupReduce dim' (segBinOpLambda op) tmps sOp $ Imp.ErrorSync Imp.FenceLocal @@ -325,7 +365,7 @@ forM_ (zip ops tmps_for_ops) $ \(op, tmps) -> do tmps_flat <- mapM flatten tmps groupScan (Just crossesSegment) (product dims') (product dims')- (segRedLambda op) tmps_flat+ (segBinOpLambda op) tmps_flat sOp $ Imp.ErrorSync Imp.FenceLocal @@ -351,7 +391,7 @@ -- Ensure that all locks have been initialised. sOp $ Imp.Barrier Imp.FenceLocal - sWhen (isActive $ unSegSpace space) $+ whenActive lvl space $ compileStms mempty (kernelBodyStms kbody) $ do let (red_res, map_res) = splitAt num_red_res $ kernelBodyResult kbody (red_is, red_vs) = splitAt (length ops) $ map kernelResultSubExp red_res@@ -688,6 +728,7 @@ num_groups group_size (group_size*num_groups) (Imp.var wave_size int32) true+ mempty let set_constants = do dPrim_ global_tid int32@@ -1070,7 +1111,8 @@ (Imp.var thread_gtid int32) (Imp.var thread_ltid int32) (Imp.var group_id int32) thread_gtid thread_ltid group_id num_groups group_size (group_size*num_groups) 0- (Imp.var thread_gtid int32 .<. kernel_size),+ (Imp.var thread_gtid int32 .<. kernel_size)+ mempty, set_constants) @@ -1085,9 +1127,6 @@ -> Imp.Exp -> (VName -> InKernelGen ()) -> InKernelGen ()-virtualiseGroups SegNoVirt _ m = do- gid <- kernelGroupIdVar . kernelConstants <$> askEnv- m gid virtualiseGroups SegVirt required_groups m = do constants <- kernelConstants <$> askEnv phys_group_id <- dPrim "phys_group_id" int32@@ -1100,6 +1139,9 @@ -- Make sure the virtual group is actually done before we let -- another virtual group have its way with it. sOp $ Imp.Barrier Imp.FenceGlobal+virtualiseGroups _ _ m = do+ gid <- kernelGroupIdVar . kernelConstants <$> askEnv+ m gid sKernelThread :: String -> Count NumGroups Imp.Exp -> Count GroupSize Imp.Exp@@ -1166,10 +1208,11 @@ copyElementWise pt destloc destslice' srcloc srcslice' _ ->- groupCoverSpace (sliceDims destslice) $ \is ->+ groupCoverSpace (sliceDims destslice) $ \is -> do copyElementWise pt- destloc (map DimFix $ fixSlice destslice is)- srcloc (map DimFix $ fixSlice srcslice is)+ destloc (map DimFix $ fixSlice destslice is)+ srcloc (map DimFix $ fixSlice srcslice is)+ sOp $ Imp.Barrier Imp.FenceLocal threadOperations, groupOperations :: Operations KernelsMem KernelEnv Imp.KernelOp threadOperations =@@ -1334,11 +1377,10 @@ sWhen (j .<. n) $ copyDWIMFix (patElemName pe) [j + offset] (Var what) [j] compileGroupResult space pe (TileReturns dims what) = do- constants <- kernelConstants <$> askEnv let gids = map fst $ unSegSpace space out_tile_sizes = map (toExp' int32 . snd) dims- local_is = unflattenIndex out_tile_sizes $ kernelLocalThreadId constants group_is = zipWith (*) (map Imp.vi32 gids) out_tile_sizes+ local_is <- localThreadIDs $ map snd dims is_for_thread <- mapM (dPrimV "thread_out_index") $ zipWith (+) group_is local_is sWhen (isActive $ zip is_for_thread $ map fst dims) $
src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs view
@@ -974,7 +974,7 @@ zip vector_ids (shapeDims $ histShape op) ++ [(subhistogram_id, Var num_histos)] - let segred_op = SegRedOp Commutative (histOp op) (histNeutral op) mempty+ let segred_op = SegBinOp Commutative (histOp op) (histNeutral op) mempty compileSegRed' (Pattern [] red_pes) lvl segred_space [segred_op] $ \red_cont -> red_cont $ flip map subhistos $ \subhisto -> (Var subhisto, map Imp.vi32 $
src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs view
@@ -47,7 +47,8 @@ SegGroup{} -> sKernelGroup "segmap_intragroup" num_groups' group_size' (segFlat space) $ do let virt_num_groups = product dims'- virtualiseGroups (segVirt lvl) virt_num_groups $ \group_id -> do+ precomputeSegOpIDs (kernelBodyStms kbody) $+ virtualiseGroups (segVirt lvl) virt_num_groups $ \group_id -> do zipWithM_ dPrimV_ is $ unflattenIndex dims' $ Imp.vi32 group_id
src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs view
@@ -50,7 +50,7 @@ import Control.Monad.Except import Data.Maybe-import Data.List (genericLength, zip4, zip7)+import Data.List (genericLength, zip7) import Prelude hiding (quot, rem) @@ -75,16 +75,16 @@ -- various kernels. compileSegRed :: Pattern KernelsMem -> SegLevel -> SegSpace- -> [SegRedOp KernelsMem]+ -> [SegBinOp KernelsMem] -> KernelBody KernelsMem -> CallKernelGen () compileSegRed pat lvl space reds body = compileSegRed' pat lvl space reds $ \red_cont -> compileStms mempty (kernelBodyStms body) $ do- let (red_res, map_res) = splitAt (segRedResults reds) $ kernelBodyResult body+ let (red_res, map_res) = splitAt (segBinOpResults reds) $ kernelBodyResult body sComment "save map-out results" $ do- let map_arrs = drop (segRedResults reds) $ patternElements pat+ let map_arrs = drop (segBinOpResults reds) $ patternElements pat zipWithM_ (compileThreadResult space) map_arrs map_res red_cont $ zip (map kernelResultSubExp red_res) $ repeat []@@ -92,7 +92,7 @@ -- | Like 'compileSegRed', but where the body is a monadic action. compileSegRed' :: Pattern KernelsMem -> SegLevel -> SegSpace- -> [SegRedOp KernelsMem]+ -> [SegBinOp KernelsMem] -> DoSegBody -> CallKernelGen () compileSegRed' pat lvl space reds body@@ -118,9 +118,9 @@ -- performed. This policy is baked into how the allocations are done -- in ExplicitAllocations. intermediateArrays :: Count GroupSize SubExp -> SubExp- -> SegRedOp KernelsMem+ -> SegBinOp KernelsMem -> InKernelGen [VName]-intermediateArrays (Count group_size) num_threads (SegRedOp _ red_op nes _) = do+intermediateArrays (Count group_size) num_threads (SegBinOp _ red_op nes _) = do let red_op_params = lambdaParams red_op (red_acc_params, _) = splitAt (length nes) red_op_params forM red_acc_params $ \p ->@@ -141,10 +141,10 @@ -- first-stage reduction, if necessary. When actually storing group -- results, the first index is set to 0. groupResultArrays :: Count NumGroups SubExp -> Count GroupSize SubExp- -> [SegRedOp KernelsMem]+ -> [SegBinOp KernelsMem] -> CallKernelGen [[VName]] groupResultArrays (Count virt_num_groups) (Count group_size) reds =- forM reds $ \(SegRedOp _ lam _ shape) ->+ forM reds $ \(SegBinOp _ lam _ shape) -> forM (lambdaReturnType lam) $ \t -> do let pt = elemType t full_shape = Shape [group_size, virt_num_groups] <> shape <> arrayShape t@@ -155,7 +155,7 @@ nonsegmentedReduction :: Pattern KernelsMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace- -> [SegRedOp KernelsMem]+ -> [SegBinOp KernelsMem] -> DoSegBody -> CallKernelGen () nonsegmentedReduction segred_pat num_groups group_size space reds body = do@@ -190,29 +190,32 @@ let num_elements = Imp.elements w let elems_per_thread = num_elements `quotRoundingUp` Imp.elements (kernelNumThreads constants) - slugs <- mapM (segRedOpSlug (kernelLocalThreadId constants) (kernelGroupId constants)) $+ slugs <- mapM (segBinOpSlug+ (kernelLocalThreadId constants)+ (kernelGroupId constants)) $ zip3 reds reds_arrs reds_group_res_arrs reds_op_renamed <- reductionStageOne constants (zip gtids dims') num_elements global_tid elems_per_thread num_threads slugs body - let segred_pes = chunks (map (length . segRedNeutral) reds) $+ let segred_pes = chunks (map (length . segBinOpNeutral) reds) $ patternElements segred_pat forM_ (zip7 reds reds_arrs reds_group_res_arrs segred_pes slugs reds_op_renamed [0..]) $- \(SegRedOp _ red_op nes _,+ \(SegBinOp _ red_op nes _, red_arrs, group_res_arrs, pes, slug, red_op_renamed, i) -> do- let red_acc_params = take (length nes) $ lambdaParams red_op+ let (red_x_params, red_y_params) = splitAt (length nes) $ lambdaParams red_op reductionStageTwo constants pes (kernelGroupId constants) 0 [0] 0- (kernelNumGroups constants) slug red_acc_params red_op_renamed nes+ (kernelNumGroups constants) slug red_x_params red_y_params+ red_op_renamed nes 1 counter (ValueExp $ IntValue $ Int32Value i) sync_arr group_res_arrs red_arrs smallSegmentsReduction :: Pattern KernelsMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace- -> [SegRedOp KernelsMem]+ -> [SegBinOp KernelsMem] -> DoSegBody -> CallKernelGen () smallSegmentsReduction (Pattern _ segred_pes) num_groups group_size space reds body = do@@ -258,7 +261,7 @@ dPrimV_ (last gtids) index_within_segment let out_of_bounds =- forM_ (zip reds reds_arrs) $ \(SegRedOp _ _ nes _, red_arrs) ->+ forM_ (zip reds reds_arrs) $ \(SegBinOp _ _ nes _, red_arrs) -> forM_ (zip red_arrs nes) $ \(arr, ne) -> copyDWIMFix arr [ltid] ne [] @@ -279,7 +282,7 @@ let crossesSegment from to = (to-from) .>. (to `rem` segment_size) sWhen (segment_size .>. 0) $ sComment "perform segmented scan to imitate reduction" $- forM_ (zip reds reds_arrs) $ \(SegRedOp _ red_op _ _, red_arrs) ->+ forM_ (zip reds reds_arrs) $ \(SegBinOp _ red_op _ _, red_arrs) -> groupScan (Just crossesSegment) (Imp.vi32 num_threads) (segment_size*segments_per_group) red_op red_arrs @@ -302,7 +305,7 @@ largeSegmentsReduction :: Pattern KernelsMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace- -> [SegRedOp KernelsMem]+ -> [SegBinOp KernelsMem] -> DoSegBody -> CallKernelGen () largeSegmentsReduction segred_pat num_groups group_size space reds body = do@@ -314,15 +317,16 @@ num_groups' <- traverse toExp num_groups group_size' <- traverse toExp group_size - let (groups_per_segment, elems_per_thread) =- groupsPerSegmentAndElementsPerThread segment_size num_segments- num_groups' group_size'- virt_num_groups <- dPrimV "vit_num_groups" $- groups_per_segment * num_segments+ (groups_per_segment, elems_per_thread) <-+ groupsPerSegmentAndElementsPerThread segment_size num_segments+ num_groups' group_size'+ virt_num_groups <- dPrimV "virt_num_groups" $+ groups_per_segment * num_segments - num_threads <- dPrimV "num_threads" $ unCount num_groups' * unCount group_size'+ num_threads <- dPrimV "num_threads" $+ unCount num_groups' * unCount group_size' - threads_per_segment <- dPrimV "thread_per_segment" $+ threads_per_segment <- dPrimV "threads_per_segment" $ groups_per_segment * unCount group_size' emit $ Imp.DebugPrint "\n# SegRed-large" Nothing@@ -361,39 +365,44 @@ -- duty; we put an outer loop to accomplish this. virtualiseGroups SegVirt (Imp.vi32 virt_num_groups) $ \group_id_var -> do let segment_gtids = init gtids+ w = last dims group_id = Imp.vi32 group_id_var- flat_segment_id = group_id `quot` groups_per_segment local_tid = kernelLocalThreadId constants - global_tid = (group_id * unCount group_size' + local_tid)- `rem` (unCount group_size' * groups_per_segment)- w = last dims- first_group_for_segment = flat_segment_id * groups_per_segment+ flat_segment_id <- dPrimVE "flat_segment_id" $+ group_id `quot` groups_per_segment + global_tid <- dPrimVE "global_tid" $+ (group_id * unCount group_size' + local_tid)+ `rem` (unCount group_size' * groups_per_segment)++ let first_group_for_segment = flat_segment_id * groups_per_segment+ zipWithM_ dPrimV_ segment_gtids $ unflattenIndex (init dims') flat_segment_id dPrim_ (last gtids) int32 num_elements <- Imp.elements <$> toExp w - slugs <- mapM (segRedOpSlug local_tid group_id) $+ slugs <- mapM (segBinOpSlug local_tid group_id) $ zip3 reds reds_arrs reds_group_res_arrs reds_op_renamed <- reductionStageOne constants (zip gtids dims') num_elements global_tid elems_per_thread threads_per_segment slugs body - let segred_pes = chunks (map (length . segRedNeutral) reds) $+ let segred_pes = chunks (map (length . segBinOpNeutral) reds) $ patternElements segred_pat multiple_groups_per_segment = forM_ (zip7 reds reds_arrs reds_group_res_arrs segred_pes slugs reds_op_renamed [0..]) $- \(SegRedOp _ red_op nes _, red_arrs, group_res_arrs, pes,+ \(SegBinOp _ red_op nes _, red_arrs, group_res_arrs, pes, slug, red_op_renamed, i) -> do- let red_acc_params = take (length nes) $ lambdaParams red_op+ let (red_x_params, red_y_params) =+ splitAt (length nes) $ lambdaParams red_op reductionStageTwo constants pes group_id flat_segment_id (map (`Imp.var` int32) segment_gtids) first_group_for_segment groups_per_segment- slug red_acc_params red_op_renamed nes+ slug red_x_params red_y_params red_op_renamed nes (fromIntegral num_counters) counter (ValueExp $ IntValue $ Int32Value i) sync_arr group_res_arrs red_arrs @@ -410,18 +419,20 @@ -- per segment. groupsPerSegmentAndElementsPerThread :: Imp.Exp -> Imp.Exp -> Count NumGroups Imp.Exp -> Count GroupSize Imp.Exp- -> (Imp.Exp, Imp.Count Imp.Elements Imp.Exp)-groupsPerSegmentAndElementsPerThread segment_size num_segments num_groups_hint group_size =- let groups_per_segment =- unCount num_groups_hint `quotRoundingUp` BinOpExp (SMax Int32) 1 num_segments- elements_per_thread =- segment_size `quotRoundingUp` (unCount group_size * groups_per_segment)- in (groups_per_segment, Imp.elements elements_per_thread)+ -> CallKernelGen (Imp.Exp, Imp.Count Imp.Elements Imp.Exp)+groupsPerSegmentAndElementsPerThread segment_size num_segments num_groups_hint group_size = do+ groups_per_segment <-+ dPrimVE "groups_per_segment" $+ unCount num_groups_hint `quotRoundingUp` BinOpExp (SMax Int32) 1 num_segments+ elements_per_thread <-+ dPrimVE "elements_per_thread" $+ segment_size `quotRoundingUp` (unCount group_size * groups_per_segment)+ return (groups_per_segment, Imp.elements elements_per_thread) --- | A SegRedOp with auxiliary information.-data SegRedOpSlug =- SegRedOpSlug- { slugOp :: SegRedOp KernelsMem+-- | A SegBinOp with auxiliary information.+data SegBinOpSlug =+ SegBinOpSlug+ { slugOp :: SegBinOp KernelsMem , slugArrs :: [VName] -- ^ The arrays used for computing the intra-group reduction -- (either local or global memory).@@ -429,32 +440,32 @@ -- ^ Places to store accumulator in stage 1 reduction. } -slugBody :: SegRedOpSlug -> Body KernelsMem-slugBody = lambdaBody . segRedLambda . slugOp+slugBody :: SegBinOpSlug -> Body KernelsMem+slugBody = lambdaBody . segBinOpLambda . slugOp -slugParams :: SegRedOpSlug -> [LParam KernelsMem]-slugParams = lambdaParams . segRedLambda . slugOp+slugParams :: SegBinOpSlug -> [LParam KernelsMem]+slugParams = lambdaParams . segBinOpLambda . slugOp -slugNeutral :: SegRedOpSlug -> [SubExp]-slugNeutral = segRedNeutral . slugOp+slugNeutral :: SegBinOpSlug -> [SubExp]+slugNeutral = segBinOpNeutral . slugOp -slugShape :: SegRedOpSlug -> Shape-slugShape = segRedShape . slugOp+slugShape :: SegBinOpSlug -> Shape+slugShape = segBinOpShape . slugOp -slugsComm :: [SegRedOpSlug] -> Commutativity-slugsComm = mconcat . map (segRedComm . slugOp)+slugsComm :: [SegBinOpSlug] -> Commutativity+slugsComm = mconcat . map (segBinOpComm . slugOp) -accParams, nextParams :: SegRedOpSlug -> [LParam KernelsMem]+accParams, nextParams :: SegBinOpSlug -> [LParam KernelsMem] accParams slug = take (length (slugNeutral slug)) $ slugParams slug nextParams slug = drop (length (slugNeutral slug)) $ slugParams slug -segRedOpSlug :: Imp.Exp -> Imp.Exp -> (SegRedOp KernelsMem, [VName], [VName]) -> InKernelGen SegRedOpSlug-segRedOpSlug local_tid group_id (op, group_res_arrs, param_arrs) =- SegRedOpSlug op group_res_arrs <$>- zipWithM mkAcc (lambdaParams (segRedLambda op)) param_arrs+segBinOpSlug :: Imp.Exp -> Imp.Exp -> (SegBinOp KernelsMem, [VName], [VName]) -> InKernelGen SegBinOpSlug+segBinOpSlug local_tid group_id (op, group_res_arrs, param_arrs) =+ SegBinOpSlug op group_res_arrs <$>+ zipWithM mkAcc (lambdaParams (segBinOpLambda op)) param_arrs where mkAcc p param_arr | Prim t <- paramType p,- shapeRank (segRedShape op) == 0 = do+ shapeRank (segBinOpShape op) == 0 = do acc <- dPrim (baseString (paramName p) <> "_acc") t return (acc, []) | otherwise =@@ -466,7 +477,7 @@ -> Imp.Exp -> Imp.Count Imp.Elements Imp.Exp -> VName- -> [SegRedOpSlug]+ -> [SegBinOpSlug] -> DoSegBody -> InKernelGen ([Lambda KernelsMem], InKernelGen ()) reductionStageZero constants ispace num_elements global_tid elems_per_thread threads_per_segment slugs body = do@@ -489,7 +500,7 @@ sLoopNest (slugShape slug) $ \vec_is -> copyDWIMFix acc (acc_is++vec_is) ne [] - slugs_op_renamed <- mapM (renameLambda . segRedLambda . slugOp) slugs+ slugs_op_renamed <- mapM (renameLambda . segBinOpLambda . slugOp) slugs let doTheReduction = forM_ (zip slugs_op_renamed slugs) $ \(slug_op_renamed, slug) ->@@ -576,7 +587,7 @@ -> Imp.Exp -> Imp.Count Imp.Elements Imp.Exp -> VName- -> [SegRedOpSlug]+ -> [SegBinOpSlug] -> DoSegBody -> InKernelGen [Lambda KernelsMem] reductionStageOne constants ispace num_elements global_tid elems_per_thread threads_per_segment slugs body = do@@ -599,14 +610,14 @@ -> [Imp.Exp] -> Imp.Exp -> Imp.Exp- -> SegRedOpSlug- -> [LParam KernelsMem]+ -> SegBinOpSlug+ -> [LParam KernelsMem] -> [LParam KernelsMem] -> Lambda KernelsMem -> [SubExp] -> Imp.Exp -> VName -> Imp.Exp -> VName -> [VName] -> [VName] -> InKernelGen () reductionStageTwo constants segred_pes group_id flat_segment_id segment_gtids first_group_for_segment groups_per_segment- slug red_acc_params+ slug red_x_params red_y_params red_op_renamed nes num_counters counter counter_i sync_arr group_res_arrs red_arrs = do let local_tid = kernelLocalThreadId constants@@ -641,20 +652,42 @@ sOp $ Imp.Atomic DefaultSpace $ Imp.AtomicAdd Int32 old_counter counter_mem counter_offset $ negate groups_per_segment+ sLoopNest (slugShape slug) $ \vec_is -> do- comment "read in the per-group-results" $- forM_ (zip4 red_acc_params red_arrs nes group_res_arrs) $- \(p, arr, ne, group_res_arr) -> do- let load_group_result =+ -- There is no guarantee that the number of workgroups for the+ -- segment is less than the workgroup size, so each thread may+ -- have to read multiple elements. We do this in a sequential+ -- way that may induce non-coalesced accesses, but the total+ -- number of accesses should be tiny here.+ comment "read in the per-group-results" $ do+ read_per_thread <- dPrimVE "read_per_thread" $+ groups_per_segment `quotRoundingUp` group_size++ forM_ (zip red_x_params nes) $ \(p, ne) ->+ copyDWIMFix (paramName p) [] ne []++ sFor "i" read_per_thread $ \i -> do++ group_res_id <- dPrimVE "group_res_id" $+ local_tid * read_per_thread + i+ index_of_group_res <- dPrimVE "index_of_group_res" $+ first_group_for_segment + group_res_id++ sWhen (group_res_id .<. groups_per_segment) $ do+ forM_ (zip red_y_params group_res_arrs) $+ \(p, group_res_arr) -> copyDWIMFix (paramName p) []- (Var group_res_arr) ([0, first_group_for_segment + local_tid] ++ vec_is)- load_neutral_element =- copyDWIMFix (paramName p) [] ne []- sIf (local_tid .<. groups_per_segment)- load_group_result load_neutral_element- when (primType $ paramType p) $- copyDWIMFix arr [local_tid] (Var $ paramName p) []+ (Var group_res_arr)+ ([0, index_of_group_res] ++ vec_is) + compileStms mempty (bodyStms $ slugBody slug) $+ forM_ (zip red_x_params (bodyResult $ slugBody slug)) $ \(p, se) ->+ copyDWIMFix (paramName p) [] se []++ forM_ (zip red_x_params red_arrs) $ \(p, arr) ->+ when (primType $ paramType p) $+ copyDWIMFix arr [local_tid] (Var $ paramName p) []+ sOp $ Imp.Barrier Imp.FenceLocal sComment "reduce the per-group results" $ do@@ -663,4 +696,6 @@ sComment "and back to memory with the final result" $ sWhen (local_tid .==. 0) $ forM_ (zip segred_pes $ lambdaParams red_op_renamed) $ \(pe, p) ->- copyDWIMFix (patElemName pe) (segment_gtids++vec_is) (Var $ paramName p) []+ copyDWIMFix+ (patElemName pe) (segment_gtids++vec_is)+ (Var $ paramName p) []
src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs view
@@ -5,8 +5,9 @@ where import Control.Monad.Except+import Control.Monad.State import Data.Maybe-import Data.List ()+import Data.List (delete, find, foldl', zip4) import Prelude hiding (quot, rem) @@ -17,23 +18,54 @@ import Futhark.CodeGen.ImpGen.Kernels.Base import qualified Futhark.Representation.Mem.IxFun as IxFun import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem)+import Futhark.Util (takeLast) -makeLocalArrays :: Count GroupSize SubExp -> SubExp -> [SubExp] -> Lambda KernelsMem- -> InKernelGen [VName]-makeLocalArrays (Count group_size) num_threads nes scan_op = do- let (scan_x_params, _scan_y_params) =- splitAt (length nes) $ lambdaParams scan_op- forM scan_x_params $ \p ->- case paramAttr p of- MemArray pt shape _ (ArrayIn mem _) -> do- let shape' = Shape [num_threads] <> shape- sArray "scan_arr" pt shape' $- ArrayIn mem $ IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape'- _ -> do- let pt = elemType $ paramType p- shape = Shape [group_size]- sAllocArray "scan_arr" pt shape $ Space "local"+-- Aggressively try to reuse memory for different SegBinOps, because+-- we will run them sequentially after another.+makeLocalArrays :: Count GroupSize SubExp -> SubExp -> [SegBinOp KernelsMem]+ -> InKernelGen [[VName]]+makeLocalArrays (Count group_size) num_threads scans = do+ (arrs, mems_and_sizes) <- runStateT (mapM onScan scans) mempty+ let maxSize sizes =+ Imp.bytes $ foldl' (Imp.BinOpExp (SMax Int32)) 1 $+ map Imp.unCount sizes+ forM_ mems_and_sizes $ \(sizes, mem) ->+ sAlloc_ mem (maxSize sizes) (Space "local")+ return arrs + where onScan (SegBinOp _ scan_op nes _) = do+ let (scan_x_params, _scan_y_params) =+ splitAt (length nes) $ lambdaParams scan_op+ (arrs, used_mems) <- fmap unzip $ forM scan_x_params $ \p ->+ case paramAttr p of+ MemArray pt shape _ (ArrayIn mem _) -> do+ let shape' = Shape [num_threads] <> shape+ arr <- lift $ sArray "scan_arr" pt shape' $+ ArrayIn mem $ IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape'+ return (arr, [])+ _ -> do+ let pt = elemType $ paramType p+ shape = Shape [group_size]+ (sizes, mem') <- getMem pt shape+ arr <- lift $ sArrayInMem "scan_arr" pt shape mem'+ return (arr, [(sizes, mem')])+ modify (<>concat used_mems)+ return arrs++ getMem pt shape = do+ let size = typeSize $ Array pt shape NoUniqueness+ mems <- get+ case (find ((size `elem`) . fst) mems, mems) of+ (Just mem, _) -> do+ modify $ delete mem+ return mem+ (Nothing, (size', mem) : mems') -> do+ put mems'+ return (size : size', mem)+ (Nothing, []) -> do+ mem <- lift $ sDeclareMem "scan_arr_mem" $ Space "local"+ return ([size], mem)+ type CrossesSegment = Maybe (Imp.Exp -> Imp.Exp -> Imp.Exp) localArrayIndex :: KernelConstants -> Type -> Imp.Exp@@ -48,29 +80,69 @@ fence | array_scan = Imp.FenceGlobal | otherwise = Imp.FenceLocal +xParams, yParams :: SegBinOp KernelsMem -> [LParam KernelsMem]+xParams scan =+ take (length (segBinOpNeutral scan)) (lambdaParams (segBinOpLambda scan))+yParams scan =+ drop (length (segBinOpNeutral scan)) (lambdaParams (segBinOpLambda scan))++writeToScanValues :: [VName]+ -> ([PatElem KernelsMem], SegBinOp KernelsMem, [KernelResult])+ -> InKernelGen ()+writeToScanValues gtids (pes, scan, scan_res)+ | shapeRank (segBinOpShape scan) > 0 =+ forM_ (zip pes scan_res) $ \(pe, res) ->+ copyDWIMFix (patElemName pe) (map Imp.vi32 gtids)+ (kernelResultSubExp res) []+ | otherwise =+ forM_ (zip (yParams scan) scan_res) $ \(p, res) ->+ copyDWIMFix (paramName p) [] (kernelResultSubExp res) []++readToScanValues :: [Imp.Exp] -> [PatElem KernelsMem] -> SegBinOp KernelsMem+ -> InKernelGen ()+readToScanValues is pes scan+ | shapeRank (segBinOpShape scan) > 0 =+ forM_ (zip (yParams scan) pes) $ \(p, pe) ->+ copyDWIMFix (paramName p) [] (Var (patElemName pe)) is+ | otherwise =+ return ()++readCarries :: Imp.Exp -> [Imp.Exp] -> [Imp.Exp]+ -> [PatElem KernelsMem]+ -> SegBinOp KernelsMem+ -> InKernelGen ()+readCarries chunk_offset dims' vec_is pes scan+ | shapeRank (segBinOpShape scan) > 0 = do+ ltid <- kernelLocalThreadId . kernelConstants <$> askEnv+ -- We may have to reload the carries from the output of the+ -- previous chunk.+ sIf (chunk_offset .>. 0 .&&. ltid .==. 0)+ (do let is = unflattenIndex dims' $ chunk_offset - 1+ forM_ (zip (xParams scan) pes) $ \(p, pe) ->+ copyDWIMFix (paramName p) [] (Var (patElemName pe)) (is++vec_is))+ (forM_ (zip (xParams scan) (segBinOpNeutral scan)) $ \(p, ne) ->+ copyDWIMFix (paramName p) [] ne [])+ | otherwise =+ return ()+ -- | Produce partially scanned intervals; one per workgroup. scanStage1 :: Pattern KernelsMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace- -> Lambda KernelsMem -> [SubExp]+ -> [SegBinOp KernelsMem] -> KernelBody KernelsMem -> CallKernelGen (VName, Imp.Exp, CrossesSegment)-scanStage1 (Pattern _ pes) num_groups group_size space scan_op nes kbody = do+scanStage1 (Pattern _ all_pes) num_groups group_size space scans kbody = do num_groups' <- traverse toExp num_groups group_size' <- traverse toExp group_size num_threads <- dPrimV "num_threads" $ unCount num_groups' * unCount group_size' let (gtids, dims) = unzip $ unSegSpace space- rets = lambdaReturnType scan_op dims' <- mapM toExp dims let num_elements = product dims' elems_per_thread = num_elements `quotRoundingUp` Imp.vi32 num_threads elems_per_group = unCount group_size' * elems_per_thread - -- Squirrel away a copy of the operator with unique names that we- -- can pass to groupScan.- scan_op_renamed <- renameLambda scan_op- let crossesSegment = case reverse dims' of segment_size : _ : _ -> Just $ \from to ->@@ -79,16 +151,14 @@ sKernelThread "scan_stage1" num_groups' group_size' (segFlat space) $ do constants <- kernelConstants <$> askEnv- local_arrs <- makeLocalArrays group_size (Var num_threads) nes scan_op+ all_local_arrs <- makeLocalArrays group_size (Var num_threads) scans -- The variables from scan_op will be used for the carry and such -- in the big chunking loop.- dScope Nothing $ scopeOfLParams $ lambdaParams scan_op- let (scan_x_params, scan_y_params) =- splitAt (length nes) $ lambdaParams scan_op-- forM_ (zip scan_x_params nes) $ \(p, ne) ->- copyDWIMFix (paramName p) [] ne []+ forM_ scans $ \scan -> do+ dScope Nothing $ scopeOfLParams $ lambdaParams $ segBinOpLambda scan+ forM_ (zip (xParams scan) (segBinOpNeutral scan)) $ \(p, ne) ->+ copyDWIMFix (paramName p) [] ne [] sFor "j" elems_per_thread $ \j -> do chunk_offset <- dPrimV "chunk_offset" $@@ -97,92 +167,115 @@ flat_idx <- dPrimV "flat_idx" $ Imp.var chunk_offset int32 + kernelLocalThreadId constants -- Construct segment indices.- zipWithM_ dPrimV_ gtids $ unflattenIndex dims' $ Imp.var flat_idx int32+ zipWithM_ dPrimV_ gtids $ unflattenIndex dims' $ Imp.vi32 flat_idx - let in_bounds =- foldl1 (.&&.) $ zipWith (.<.) (map (`Imp.var` int32) gtids) dims'+ let per_scan_pes = segBinOpChunks scans all_pes++ in_bounds =+ foldl1 (.&&.) $ zipWith (.<.) (map Imp.vi32 gtids) dims'+ when_in_bounds = compileStms mempty (kernelBodyStms kbody) $ do- let (scan_res, map_res) = splitAt (length nes) $ kernelBodyResult kbody+ let (all_scan_res, map_res) =+ splitAt (segBinOpResults scans) $ kernelBodyResult kbody+ per_scan_res =+ segBinOpChunks scans all_scan_res+ sComment "write to-scan values to parameters" $- forM_ (zip scan_y_params scan_res) $ \(p, se) ->- copyDWIMFix (paramName p) [] (kernelResultSubExp se) []+ mapM_ (writeToScanValues gtids) $+ zip3 per_scan_pes scans per_scan_res+ sComment "write mapped values results to global memory" $- forM_ (zip (drop (length nes) pes) map_res) $ \(pe, se) ->- copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids)+ forM_ (zip (takeLast (length map_res) all_pes) map_res) $ \(pe, se) ->+ copyDWIMFix (patElemName pe) (map Imp.vi32 gtids) (kernelResultSubExp se) []- when_out_of_bounds = forM_ (zip scan_y_params nes) $ \(p, ne) ->- copyDWIMFix (paramName p) [] ne [] - sComment "threads in bounds read input; others get neutral element" $- sIf in_bounds when_in_bounds when_out_of_bounds+ sComment "threads in bounds read input" $+ sWhen in_bounds when_in_bounds - sComment "combine with carry and write to local memory" $- compileStms mempty (bodyStms $ lambdaBody scan_op) $- forM_ (zip3 rets local_arrs (bodyResult $ lambdaBody scan_op)) $ \(t, arr, se) ->- copyDWIMFix arr [localArrayIndex constants t] se []+ forM_ (zip3 per_scan_pes scans all_local_arrs) $+ \(pes, scan@(SegBinOp _ scan_op nes vec_shape), local_arrs) ->+ sComment "do one intra-group scan operation" $ do+ let rets = lambdaReturnType scan_op+ scan_x_params = xParams scan+ (array_scan, fence, barrier) = barrierFor scan_op - let crossesSegment' = do- f <- crossesSegment- Just $ \from to ->- let from' = from + Imp.var chunk_offset int32- to' = to + Imp.var chunk_offset int32- in f from' to'+ when array_scan barrier - sOp $ Imp.ErrorSync fence+ sLoopNest vec_shape $ \vec_is -> do+ sComment "maybe restore some to-scan values to parameters, or read neutral" $+ sIf in_bounds+ (do readToScanValues (map Imp.vi32 gtids++vec_is) pes scan+ readCarries (Imp.vi32 chunk_offset) dims' vec_is pes scan)+ (forM_ (zip (yParams scan) (segBinOpNeutral scan)) $ \(p, ne) ->+ copyDWIMFix (paramName p) [] ne []) - groupScan crossesSegment'- (Imp.vi32 num_threads)- (kernelGroupSize constants) scan_op_renamed local_arrs+ sComment "combine with carry and write to local memory" $+ compileStms mempty (bodyStms $ lambdaBody scan_op) $+ forM_ (zip3 rets local_arrs (bodyResult $ lambdaBody scan_op)) $+ \(t, arr, se) -> copyDWIMFix arr [localArrayIndex constants t] se [] - sComment "threads in bounds write partial scan result" $- sWhen in_bounds $ forM_ (zip3 rets pes local_arrs) $ \(t, pe, arr) ->- copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids)- (Var arr) [localArrayIndex constants t]+ let crossesSegment' = do+ f <- crossesSegment+ Just $ \from to ->+ let from' = from + Imp.var chunk_offset int32+ to' = to + Imp.var chunk_offset int32+ in f from' to' - barrier+ sOp $ Imp.ErrorSync fence - let load_carry =- forM_ (zip local_arrs scan_x_params) $ \(arr, p) ->- copyDWIMFix (paramName p) [] (Var arr)- [if primType $ paramType p- then kernelGroupSize constants - 1- else (kernelGroupId constants+1) * kernelGroupSize constants - 1]- load_neutral =- forM_ (zip nes scan_x_params) $ \(ne, p) ->- copyDWIMFix (paramName p) [] ne []+ -- We need to avoid parameter name clashes.+ scan_op_renamed <- renameLambda scan_op+ groupScan crossesSegment'+ (Imp.vi32 num_threads)+ (kernelGroupSize constants) scan_op_renamed local_arrs - sComment "first thread reads last element as carry-in for next iteration" $ do- crosses_segment <- dPrimVE "crosses_segment" $- case crossesSegment of- Nothing -> false- Just f -> f (Imp.var chunk_offset int32 +- kernelGroupSize constants-1)- (Imp.var chunk_offset int32 +- kernelGroupSize constants)- should_load_carry <- dPrimVE "should_load_carry" $- kernelLocalThreadId constants .==. 0 .&&. UnOpExp Not crosses_segment- sWhen should_load_carry load_carry- when array_scan barrier- sUnless should_load_carry load_neutral+ sComment "threads in bounds write partial scan result" $+ sWhen in_bounds $ forM_ (zip3 rets pes local_arrs) $ \(t, pe, arr) ->+ copyDWIMFix (patElemName pe) (map Imp.vi32 gtids++vec_is)+ (Var arr) [localArrayIndex constants t] - barrier+ barrier - return (num_threads, elems_per_group, crossesSegment)+ let load_carry =+ forM_ (zip local_arrs scan_x_params) $ \(arr, p) ->+ copyDWIMFix (paramName p) [] (Var arr)+ [if primType $ paramType p+ then kernelGroupSize constants - 1+ else (kernelGroupId constants+1) * kernelGroupSize constants - 1]+ load_neutral =+ forM_ (zip nes scan_x_params) $ \(ne, p) ->+ copyDWIMFix (paramName p) [] ne [] - where (array_scan, fence, barrier) = barrierFor scan_op+ sComment "first thread reads last element as carry-in for next iteration" $ do+ crosses_segment <- dPrimVE "crosses_segment" $+ case crossesSegment of+ Nothing -> false+ Just f -> f (Imp.var chunk_offset int32 ++ kernelGroupSize constants-1)+ (Imp.var chunk_offset int32 ++ kernelGroupSize constants)+ should_load_carry <- dPrimVE "should_load_carry" $+ kernelLocalThreadId constants .==. 0 .&&. UnOpExp Not crosses_segment+ sWhen should_load_carry load_carry+ when array_scan barrier+ sUnless should_load_carry load_neutral + barrier++ return (num_threads, elems_per_group, crossesSegment)+ scanStage2 :: Pattern KernelsMem -> VName -> Imp.Exp -> Count NumGroups SubExp -> CrossesSegment -> SegSpace- -> Lambda KernelsMem -> [SubExp]+ -> [SegBinOp KernelsMem] -> CallKernelGen ()-scanStage2 (Pattern _ pes) stage1_num_threads elems_per_group num_groups crossesSegment space scan_op nes = do+scanStage2 (Pattern _ all_pes) stage1_num_threads elems_per_group num_groups crossesSegment space scans = do+ let (gtids, dims) = unzip $ unSegSpace space+ dims' <- mapM toExp dims+ -- Our group size is the number of groups for the stage 1 kernel. let group_size = Count $ unCount num_groups group_size' <- traverse toExp group_size - let (gtids, dims) = unzip $ unSegSpace space- rets = lambdaReturnType scan_op- dims' <- mapM toExp dims let crossesSegment' = do f <- crossesSegment Just $ \from to ->@@ -190,42 +283,51 @@ sKernelThread "scan_stage2" 1 group_size' (segFlat space) $ do constants <- kernelConstants <$> askEnv- local_arrs <- makeLocalArrays group_size (Var stage1_num_threads) nes scan_op+ per_scan_local_arrs <- makeLocalArrays group_size (Var stage1_num_threads) scans+ let per_scan_rets = map (lambdaReturnType . segBinOpLambda) scans+ per_scan_pes = segBinOpChunks scans all_pes flat_idx <- dPrimV "flat_idx" $ (kernelLocalThreadId constants + 1) * elems_per_group - 1 -- Construct segment indices. zipWithM_ dPrimV_ gtids $ unflattenIndex dims' $ Imp.var flat_idx int32 - let in_bounds =- foldl1 (.&&.) $ zipWith (.<.) (map (`Imp.var` int32) gtids) dims'- when_in_bounds = forM_ (zip3 rets local_arrs pes) $ \(t, arr, pe) ->- copyDWIMFix arr [localArrayIndex constants t]- (Var $ patElemName pe) $ map (`Imp.var` int32) gtids- when_out_of_bounds = forM_ (zip3 rets local_arrs nes) $ \(t, arr, ne) ->- copyDWIMFix arr [localArrayIndex constants t] ne []+ forM_ (zip4 scans per_scan_local_arrs per_scan_rets per_scan_pes) $+ \(SegBinOp _ scan_op nes vec_shape, local_arrs, rets, pes) ->+ sLoopNest vec_shape $ \vec_is -> do+ let glob_is = map Imp.vi32 gtids ++ vec_is - sComment "threads in bound read carries; others get neutral element" $- sIf in_bounds when_in_bounds when_out_of_bounds+ in_bounds =+ foldl1 (.&&.) $ zipWith (.<.) (map Imp.vi32 gtids) dims' - barrier+ when_in_bounds = forM_ (zip3 rets local_arrs pes) $ \(t, arr, pe) ->+ copyDWIMFix arr [localArrayIndex constants t]+ (Var $ patElemName pe) glob_is - groupScan crossesSegment'- (Imp.vi32 stage1_num_threads) (kernelGroupSize constants) scan_op local_arrs+ when_out_of_bounds = forM_ (zip3 rets local_arrs nes) $ \(t, arr, ne) ->+ copyDWIMFix arr [localArrayIndex constants t] ne []+ (_, _, barrier) =+ barrierFor scan_op - sComment "threads in bounds write scanned carries" $- sWhen in_bounds $ forM_ (zip3 rets pes local_arrs) $ \(t, pe, arr) ->- copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids)- (Var arr) [localArrayIndex constants t]+ sComment "threads in bound read carries; others get neutral element" $+ sIf in_bounds when_in_bounds when_out_of_bounds - where (_, _, barrier) = barrierFor scan_op+ barrier + groupScan crossesSegment'+ (Imp.vi32 stage1_num_threads) (kernelGroupSize constants) scan_op local_arrs++ sComment "threads in bounds write scanned carries" $+ sWhen in_bounds $ forM_ (zip3 rets pes local_arrs) $ \(t, pe, arr) ->+ copyDWIMFix (patElemName pe) glob_is+ (Var arr) [localArrayIndex constants t]+ scanStage3 :: Pattern KernelsMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> Imp.Exp -> CrossesSegment -> SegSpace- -> Lambda KernelsMem -> [SubExp]+ -> [SegBinOp KernelsMem] -> CallKernelGen ()-scanStage3 (Pattern _ pes) num_groups group_size elems_per_group crossesSegment space scan_op nes = do+scanStage3 (Pattern _ all_pes) num_groups group_size elems_per_group crossesSegment space scans = do num_groups' <- traverse toExp num_groups group_size' <- traverse toExp group_size let (gtids, dims) = unzip $ unSegSpace space@@ -256,7 +358,7 @@ -- then the carry was updated in stage 2), and we are not crossing -- a segment boundary. let in_bounds =- foldl1 (.&&.) $ zipWith (.<.) (map (`Imp.var` int32) gtids) dims'+ foldl1 (.&&.) $ zipWith (.<.) (map Imp.vi32 gtids) dims' crosses_segment = fromMaybe false $ crossesSegment <*> pure (Imp.var carry_in_flat_idx int32) <*>@@ -265,34 +367,43 @@ (Imp.var orig_group int32 + 1) * elems_per_group - 1 no_carry_in = Imp.var orig_group int32 .==. 0 .||. is_a_carry .||. crosses_segment - sWhen in_bounds $ sUnless no_carry_in $ do- dScope Nothing $ scopeOfLParams $ lambdaParams scan_op- let (scan_x_params, scan_y_params) =- splitAt (length nes) $ lambdaParams scan_op- forM_ (zip scan_x_params pes) $ \(p, pe) ->- copyDWIMFix (paramName p) [] (Var $ patElemName pe) carry_in_idx- forM_ (zip scan_y_params pes) $ \(p, pe) ->- copyDWIMFix (paramName p) [] (Var $ patElemName pe) $ map (`Imp.var` int32) gtids- compileBody' scan_x_params $ lambdaBody scan_op- forM_ (zip scan_x_params pes) $ \(p, pe) ->- copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids) (Var $ paramName p) []+ let per_scan_pes = segBinOpChunks scans all_pes+ sWhen in_bounds $ sUnless no_carry_in $+ forM_ (zip per_scan_pes scans) $+ \(pes, SegBinOp _ scan_op nes vec_shape) -> do+ dScope Nothing $ scopeOfLParams $ lambdaParams scan_op+ let (scan_x_params, scan_y_params) =+ splitAt (length nes) $ lambdaParams scan_op + sLoopNest vec_shape $ \vec_is -> do+ forM_ (zip scan_x_params pes) $ \(p, pe) ->+ copyDWIMFix (paramName p) []+ (Var $ patElemName pe) (carry_in_idx++vec_is)++ forM_ (zip scan_y_params pes) $ \(p, pe) ->+ copyDWIMFix (paramName p) []+ (Var $ patElemName pe) (map Imp.vi32 gtids++vec_is)++ compileBody' scan_x_params $ lambdaBody scan_op++ forM_ (zip scan_x_params pes) $ \(p, pe) ->+ copyDWIMFix (patElemName pe) (map Imp.vi32 gtids++vec_is)+ (Var $ paramName p) []+ -- | Compile 'SegScan' instance to host-level code with calls to -- various kernels. compileSegScan :: Pattern KernelsMem -> SegLevel -> SegSpace- -> Lambda KernelsMem -> [SubExp]+ -> [SegBinOp KernelsMem] -> KernelBody KernelsMem -> CallKernelGen ()-compileSegScan pat lvl space scan_op nes kbody = do+compileSegScan pat lvl space scans kbody = do emit $ Imp.DebugPrint "\n# SegScan" Nothing (stage1_num_threads, elems_per_group, crossesSegment) <-- scanStage1 pat (segNumGroups lvl) (segGroupSize lvl) space scan_op nes kbody+ scanStage1 pat (segNumGroups lvl) (segGroupSize lvl) space scans kbody emit $ Imp.DebugPrint "elems_per_group" $ Just elems_per_group - scan_op' <- renameLambda scan_op- scan_op'' <- renameLambda scan_op- scanStage2 pat stage1_num_threads elems_per_group (segNumGroups lvl) crossesSegment space scan_op' nes- scanStage3 pat (segNumGroups lvl) (segGroupSize lvl) elems_per_group crossesSegment space scan_op'' nes+ scanStage2 pat stage1_num_threads elems_per_group (segNumGroups lvl) crossesSegment space scans+ scanStage3 pat (segNumGroups lvl) (segGroupSize lvl) elems_per_group crossesSegment space scans
src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs view
@@ -482,7 +482,7 @@ where has_communication = hasCommunication body fence FenceLocal = [C.cexp|CLK_LOCAL_MEM_FENCE|]- fence FenceGlobal = [C.cexp|CLK_GLOBAL_MEM_FENCE|]+ fence FenceGlobal = [C.cexp|CLK_GLOBAL_MEM_FENCE | CLK_LOCAL_MEM_FENCE|] kernelOps :: GenericC.OpCompiler KernelOp KernelState kernelOps (GetGroupId v i) =
src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs view
@@ -10,7 +10,6 @@ import Futhark.CodeGen.ImpCode.Kernels import Futhark.Representation.AST.Attributes.Types-import Futhark.Representation.AST.Attributes.Names (freeIn, namesToList) import Futhark.Util.IntegralExp (IntegralExp, quot, rem, quotRoundingUp) -- | Which form of transposition to generate code for.
src/Futhark/Compiler.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-} module Futhark.Compiler ( runPipelineOnProgram@@ -34,6 +36,10 @@ import Futhark.Util.Log import Futhark.Util.Pretty (prettyText) +-- | The compiler configuration. This only contains options related+-- to core compiler functionality, such as reading the initial program+-- and running passes. Options related to code generation are handled+-- elsewhere. data FutharkConfig = FutharkConfig { futharkVerbose :: (Verbosity, Maybe FilePath) , futharkWarn :: Bool -- ^ Warn if True.@@ -41,6 +47,7 @@ , futharkSafe :: Bool -- ^ If True, ignore @unsafe@. } +-- | The default compiler configuration. newFutharkConfig :: FutharkConfig newFutharkConfig = FutharkConfig { futharkVerbose = (NotVerbose, Nothing) , futharkWarn = True@@ -48,6 +55,9 @@ , futharkSafe = False } +-- | Print a compiler error to stdout. The 'FutharkConfig' controls+-- to which degree auxiliary information (e.g. the failing program) is+-- also printed. dumpError :: FutharkConfig -> CompilerError -> IO () dumpError config err = case err of@@ -69,6 +79,8 @@ maybe (T.hPutStr stderr) T.writeFile (snd (futharkVerbose config)) $ info <> "\n" +-- | Read a program from the given 'FilePath', run the given+-- 'Pipeline', and finish up with the given 'Action'. runCompilerOnProgram :: FutharkConfig -> Pipeline I.SOACS lore -> Action lore@@ -90,6 +102,8 @@ when ((>NotVerbose) . fst $ futharkVerbose config) $ logMsg ("Done." :: String) +-- | Read a program from the given 'FilePath', run the given+-- 'Pipeline', and return it. runPipelineOnProgram :: FutharkConfig -> Pipeline I.SOACS tolore -> FilePath
src/Futhark/Construct.hs view
@@ -25,6 +25,7 @@ , eRoundToMultipleOf , eSliceArray , eBlank+ , eAll , eOutOfBounds , eWriteArray@@ -211,7 +212,7 @@ eDivRoundingUp :: MonadBinder m => IntType -> m (Exp (Lore m)) -> m (Exp (Lore m)) -> m (Exp (Lore m)) eDivRoundingUp t x y =- eBinOp (SQuot t) (eBinOp (Add t) x (eBinOp (Sub t) y (eSubExp one))) y+ eBinOp (SQuot t) (eBinOp (Add t OverflowWrap) x (eBinOp (Sub t OverflowWrap) y (eSubExp one))) y where one = intConst t 1 eRoundToMultipleOf :: MonadBinder m =>@@ -219,8 +220,8 @@ eRoundToMultipleOf t x d = ePlus x (eMod (eMinus d (eMod x d)) d) where eMod = eBinOp (SMod t)- eMinus = eBinOp (Sub t)- ePlus = eBinOp (Add t)+ eMinus = eBinOp (Sub t OverflowWrap)+ ePlus = eBinOp (Add t OverflowWrap) -- | Construct an 'Index' expressions that slices an array with unit stride. eSliceArray :: MonadBinder m =>@@ -307,6 +308,11 @@ return $ BasicOp $ SubExp ne foldBinOp bop ne (e:es) = eBinOp bop (pure $ BasicOp $ SubExp e) (foldBinOp bop ne es)++-- | True if all operands are true.+eAll :: MonadBinder m => [SubExp] -> m (Exp (Lore m))+eAll [] = pure $ BasicOp $ SubExp $ constant True+eAll (x:xs) = foldBinOp LogAnd x xs -- | Create a two-parameter lambda whose body applies the given binary -- operation to its arguments. It is assumed that both argument and
src/Futhark/Internalise.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-} -- | -- -- This module implements a transformation from source to core@@ -321,7 +323,10 @@ arr_t_ext <- internaliseReturnType $ E.toStruct arr_t es' <- mapM (internaliseExp "arr_elem") es - let typeFromElements =+ rowtypes <-+ case mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext of+ Just ts -> pure ts+ Nothing -> -- XXX: the monomorphiser may create single-element array -- literals with an unknown row type. In those cases we -- need to look at the types of the actual elements.@@ -331,10 +336,6 @@ [] -> error $ "internaliseExp ArrayLit: existential type: " ++ pretty arr_t e':_ -> mapM subExpType e' - rowtypes <-- maybe typeFromElements pure $- mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext- let arraylit ks rt = do ks' <- mapM (ensureShape asserting "shape of element differs from shape of first element"@@ -397,7 +398,8 @@ (step, step_zero) <- case maybe_second' of Just second' -> do- subtracted_step <- letSubExp "subtracted_step" $ I.BasicOp $ I.BinOp (I.Sub it) second' start'+ subtracted_step <- letSubExp "subtracted_step" $+ I.BasicOp $ I.BinOp (I.Sub it I.OverflowWrap) second' start' step_zero <- letSubExp "step_zero" $ I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) start' second' return (subtracted_step, step_zero) Nothing ->@@ -416,13 +418,13 @@ step_wrong_dir <- letSubExp "step_wrong_dir" $ I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign one distance <- letSubExp "distance" $- I.BasicOp $ I.BinOp (Sub it) start' end'+ I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) start' end' distance_i32 <- asIntZ Int32 distance return (distance_i32, step_wrong_dir, bounds_invalid_downwards) UpToExclusive{} -> do step_wrong_dir <- letSubExp "step_wrong_dir" $ I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign negone- distance <- letSubExp "distance" $ I.BasicOp $ I.BinOp (Sub it) end' start'+ distance <- letSubExp "distance" $ I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) end' start' distance_i32 <- asIntZ Int32 distance return (distance_i32, step_wrong_dir, bounds_invalid_upwards) ToInclusive{} -> do@@ -430,10 +432,10 @@ I.BasicOp $ I.CmpOp (I.CmpEq $ IntType it) step_sign negone distance_downwards_exclusive <- letSubExp "distance_downwards_exclusive" $- I.BasicOp $ I.BinOp (Sub it) start' end'+ I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) start' end' distance_upwards_exclusive <- letSubExp "distance_upwards_exclusive" $- I.BasicOp $ I.BinOp (Sub it) end' start'+ I.BasicOp $ I.BinOp (Sub it I.OverflowWrap) end' start' bounds_invalid <- letSubExp "bounds_invalid" $ I.If downwards@@ -447,7 +449,7 @@ ifCommon [I.Prim $ IntType it] distance_exclusive_i32 <- asIntZ Int32 distance_exclusive distance <- letSubExp "distance" $- I.BasicOp $ I.BinOp (Add Int32)+ I.BasicOp $ I.BinOp (Add Int32 I.OverflowWrap) distance_exclusive_i32 (intConst Int32 1) return (distance, constant False, bounds_invalid) @@ -464,7 +466,7 @@ step_i32 <- asIntS Int32 step pos_step <- letSubExp "pos_step" $- I.BasicOp $ I.BinOp (Mul Int32) step_i32 step_sign_i32+ I.BasicOp $ I.BinOp (Mul Int32 I.OverflowWrap) step_i32 step_sign_i32 num_elems <- certifying cs $ letSubExp "num_elems" =<<@@ -492,7 +494,7 @@ e' <- internaliseExp1 "negate_arg" e et <- subExpType e' case et of I.Prim (I.IntType t) ->- letTupExp' desc $ I.BasicOp $ I.BinOp (I.Sub t) (I.intConst t 0) e'+ letTupExp' desc $ I.BasicOp $ I.BinOp (I.Sub t I.OverflowWrap) (I.intConst t 0) e' I.Prim (I.FloatType t) -> letTupExp' desc $ I.BasicOp $ I.BinOp (I.FSub t) (I.floatConst t 0) e' _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in Negate"@@ -854,7 +856,7 @@ generateCond :: E.Pattern -> [I.SubExp] -> InternaliseM (I.SubExp, [I.SubExp]) generateCond orig_p orig_ses = do (cmps, pertinent, _) <- compares orig_p orig_ses- cmp <- letSubExp "matches" =<< foldBinOp I.LogAnd (constant True) cmps+ cmp <- letSubExp "matches" =<< eAll cmps return (cmp, pertinent) where -- Literals are always primitive values.@@ -944,7 +946,7 @@ internaliseSlice loc dims idxs = do (idxs', oks, parts) <- unzip3 <$> zipWithM internaliseDimIndex dims idxs c <- assertingOne $ do- ok <- letSubExp "index_ok" =<< foldBinOp I.LogAnd (constant True) oks+ ok <- letSubExp "index_ok" =<< eAll oks let msg = errorMsg $ ["Index ["] ++ intercalate [", "] parts ++ ["] out of bounds for array of shape ["] ++ intersperse "][" (map ErrorInt32 $ take (length idxs) dims) ++ ["]."]@@ -965,7 +967,7 @@ s' <- maybe (return one) (fmap fst . internaliseDimExp "s") s s_sign <- letSubExp "s_sign" $ BasicOp $ I.UnOp (I.SSignum Int32) s' backwards <- letSubExp "backwards" $ I.BasicOp $ I.CmpOp (I.CmpEq int32) s_sign negone- w_minus_1 <- letSubExp "w_minus_1" $ BasicOp $ I.BinOp (Sub Int32) w one+ w_minus_1 <- letSubExp "w_minus_1" $ BasicOp $ I.BinOp (Sub Int32 I.OverflowWrap) w one let i_def = letSubExp "i_def" $ I.If backwards (resultBody [w_minus_1]) (resultBody [zero]) $ ifCommon [I.Prim int32]@@ -974,11 +976,12 @@ (resultBody [w]) $ ifCommon [I.Prim int32] i' <- maybe i_def (fmap fst . internaliseDimExp "i") i j' <- maybe j_def (fmap fst . internaliseDimExp "j") j- j_m_i <- letSubExp "j_m_i" $ BasicOp $ I.BinOp (Sub Int32) j' i'+ j_m_i <- letSubExp "j_m_i" $ BasicOp $ I.BinOp (Sub Int32 I.OverflowWrap) j' i' -- Something like a division-rounding-up, but accomodating negative -- operands. let divRounding x y =- eBinOp (SQuot Int32) (eBinOp (Add Int32) x (eBinOp (Sub Int32) y (eSignum $ toExp s'))) y+ eBinOp (SQuot Int32) (eBinOp (Add Int32 I.OverflowWrap) x+ (eBinOp (Sub Int32 I.OverflowWrap) y (eSignum $ toExp s'))) y n <- letSubExp "n" =<< divRounding (toExp j_m_i) (toExp s') -- Bounds checks depend on whether we are slicing forwards or@@ -987,9 +990,9 @@ -- i+n*s && i+(n-1)*s < w'. We only check if the slice is nonempty. empty_slice <- letSubExp "empty_slice" $ I.BasicOp $ I.CmpOp (CmpEq int32) n zero - m <- letSubExp "m" $ I.BasicOp $ I.BinOp (Sub Int32) n one- m_t_s <- letSubExp "m_t_s" $ I.BasicOp $ I.BinOp (Mul Int32) m s'- i_p_m_t_s <- letSubExp "i_p_m_t_s" $ I.BasicOp $ I.BinOp (Add Int32) i' m_t_s+ m <- letSubExp "m" $ I.BasicOp $ I.BinOp (Sub Int32 I.OverflowWrap) n one+ m_t_s <- letSubExp "m_t_s" $ I.BasicOp $ I.BinOp (Mul Int32 I.OverflowWrap) m s'+ i_p_m_t_s <- letSubExp "i_p_m_t_s" $ I.BasicOp $ I.BinOp (Add Int32 I.OverflowWrap) i' m_t_s zero_leq_i_p_m_t_s <- letSubExp "zero_leq_i_p_m_t_s" $ I.BasicOp $ I.CmpOp (I.CmpSle Int32) zero i_p_m_t_s i_p_m_t_s_leq_w <- letSubExp "i_p_m_t_s_leq_w" $@@ -1000,14 +1003,13 @@ zero_lte_i <- letSubExp "zero_lte_i" $ I.BasicOp $ I.CmpOp (I.CmpSle Int32) zero i' i_lte_j <- letSubExp "i_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int32) i' j' forwards_ok <- letSubExp "forwards_ok" =<<- foldBinOp I.LogAnd zero_lte_i- [zero_lte_i, i_lte_j, zero_leq_i_p_m_t_s, i_p_m_t_s_lth_w]+ eAll [zero_lte_i, zero_lte_i, i_lte_j, zero_leq_i_p_m_t_s, i_p_m_t_s_lth_w] negone_lte_j <- letSubExp "negone_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int32) negone j' j_lte_i <- letSubExp "j_lte_i" $ I.BasicOp $ I.CmpOp (I.CmpSle Int32) j' i' backwards_ok <- letSubExp "backwards_ok" =<<- foldBinOp I.LogAnd negone_lte_j- [negone_lte_j, j_lte_i, zero_leq_i_p_m_t_s, i_p_m_t_s_leq_w]+ eAll+ [negone_lte_j, negone_lte_j, j_lte_i, zero_leq_i_p_m_t_s, i_p_m_t_s_leq_w] slice_ok <- letSubExp "slice_ok" $ I.If backwards (resultBody [backwards_ok])@@ -1226,21 +1228,21 @@ -> E.PrimType -> InternaliseM [I.SubExp] internaliseBinOp _ desc E.Plus x y (E.Signed t) _ =- simpleBinOp desc (I.Add t) x y+ simpleBinOp desc (I.Add t I.OverflowWrap) x y internaliseBinOp _ desc E.Plus x y (E.Unsigned t) _ =- simpleBinOp desc (I.Add t) x y+ simpleBinOp desc (I.Add t I.OverflowWrap) x y internaliseBinOp _ desc E.Plus x y (E.FloatType t) _ = simpleBinOp desc (I.FAdd t) x y internaliseBinOp _ desc E.Minus x y (E.Signed t) _ =- simpleBinOp desc (I.Sub t) x y+ simpleBinOp desc (I.Sub t I.OverflowWrap) x y internaliseBinOp _ desc E.Minus x y (E.Unsigned t) _ =- simpleBinOp desc (I.Sub t) x y+ simpleBinOp desc (I.Sub t I.OverflowWrap) x y internaliseBinOp _ desc E.Minus x y (E.FloatType t) _ = simpleBinOp desc (I.FSub t) x y internaliseBinOp _ desc E.Times x y (E.Signed t) _ =- simpleBinOp desc (I.Mul t) x y+ simpleBinOp desc (I.Mul t I.OverflowWrap) x y internaliseBinOp _ desc E.Times x y (E.Unsigned t) _ =- simpleBinOp desc (I.Mul t) x y+ simpleBinOp desc (I.Mul t I.OverflowWrap) x y internaliseBinOp _ desc E.Times x y (E.FloatType t) _ = simpleBinOp desc (I.FMul t) x y internaliseBinOp loc desc E.Divide x y (E.Signed t) _ =@@ -1441,7 +1443,7 @@ xe' <- internaliseExp "x" xe ye' <- internaliseExp "y" ye rs <- zipWithM (doComparison desc) xe' ye'- cmp_f desc =<< letSubExp "eq" =<< foldBinOp I.LogAnd (constant True) rs+ cmp_f desc =<< letSubExp "eq" =<< eAll rs where isEqlOp "!=" = Just $ \desc eq -> letTupExp' desc $ I.BasicOp $ I.UnOp I.Not eq isEqlOp "==" = Just $ \_ eq ->@@ -1458,12 +1460,11 @@ y_dims = I.arrayDims y_t dims_match <- forM (zip x_dims y_dims) $ \(x_dim, y_dim) -> letSubExp "dim_eq" $ I.BasicOp $ I.CmpOp (I.CmpEq int32) x_dim y_dim- shapes_match <- letSubExp "shapes_match" =<<- foldBinOp I.LogAnd (constant True) dims_match+ shapes_match <- letSubExp "shapes_match" =<< eAll dims_match compare_elems_body <- runBodyBinder $ do -- Flatten both x and y. x_num_elems <- letSubExp "x_num_elems" =<<- foldBinOp (I.Mul Int32) (constant (1::Int32)) x_dims+ foldBinOp (I.Mul Int32 I.OverflowUndef) (constant (1::Int32)) x_dims x' <- letExp "x" $ I.BasicOp $ I.SubExp x y' <- letExp "x" $ I.BasicOp $ I.SubExp y x_flat <- letExp "x_flat" $ I.BasicOp $ I.Reshape [I.DimNew x_num_elems] x'@@ -1503,11 +1504,6 @@ letTupExp' desc $ I.Op $ I.Screma w (I.mapSOAC lam') arr' - handleSOACs [TupLit [lam, arr] _] "filter" = Just $ \_desc -> do- arrs <- internaliseExpToVars "filter_input" arr- lam' <- internalisePartitionLambda internaliseLambda 1 lam $ map I.Var arrs- uncurry (++) <$> partitionWithSOACS 1 lam' arrs- handleSOACs [TupLit [k, lam, arr] _] "partition" = do k' <- fromIntegral <$> isInt32 k Just $ \_desc -> do@@ -1533,7 +1529,7 @@ handleSOACs [TupLit [lam, ne, arr] _] "scan" = Just $ \desc -> internaliseScanOrReduce desc "scan" reduce (lam, ne, arr, loc) where reduce w scan_lam nes arrs =- I.Screma w <$> I.scanSOAC scan_lam nes <*> pure arrs+ I.Screma w <$> I.scanSOAC [Scan scan_lam nes] <*> pure arrs handleSOACs [TupLit [op, f, arr] _] "reduce_stream" = Just $ \desc -> internaliseStreamRed desc InOrder Noncommutative op f arr@@ -1568,7 +1564,7 @@ old_dim <- I.arraysSize 0 <$> mapM lookupType arrs dim_ok <- assertingOne $ letExp "dim_ok" =<< eAssert (eCmpOp (I.CmpEq I.int32)- (eBinOp (I.Mul Int32) (eSubExp n') (eSubExp m'))+ (eBinOp (I.Mul Int32 I.OverflowUndef) (eSubExp n') (eSubExp m')) (eSubExp old_dim)) "new shape has different number of elements than old shape" loc certifying dim_ok $ forM arrs $ \arr' -> do@@ -1582,7 +1578,7 @@ arr_t <- lookupType arr' let n = arraySize 0 arr_t m = arraySize 1 arr_t- k <- letSubExp "flat_dim" $ I.BasicOp $ I.BinOp (Mul Int32) n m+ k <- letSubExp "flat_dim" $ I.BasicOp $ I.BinOp (Mul Int32 I.OverflowUndef) n m letSubExp desc $ I.BasicOp $ I.Reshape (reshapeOuter [DimNew k] 2 $ I.arrayShape arr_t) arr' @@ -1591,7 +1587,7 @@ ys <- internaliseExpToVars "concat_y" y outer_size <- arraysSize 0 <$> mapM lookupType xs let sumdims xsize ysize = letSubExp "conc_tmp" $ I.BasicOp $- I.BinOp (I.Add I.Int32) xsize ysize+ I.BinOp (I.Add I.Int32 I.OverflowUndef) xsize ysize ressize <- foldM sumdims outer_size =<< mapM (fmap (arraysSize 0) . mapM lookupType) [ys] @@ -1782,7 +1778,7 @@ add_lam_body <- runBodyBinder $ localScope (scopeOfLParams $ add_lam_x_params++add_lam_y_params) $ fmap resultBody $ forM (zip add_lam_x_params add_lam_y_params) $ \(x,y) ->- letSubExp "z" $ I.BasicOp $ I.BinOp (I.Add Int32)+ letSubExp "z" $ I.BasicOp $ I.BinOp (I.Add Int32 I.OverflowUndef) (I.Var $ I.paramName x) (I.Var $ I.paramName y) let add_lam = I.Lambda { I.lambdaBody = add_lam_body , I.lambdaParams = add_lam_x_params ++ add_lam_y_params@@ -1790,13 +1786,13 @@ } nes = replicate (length increments) $ constant (0::Int32) - scan <- I.scanSOAC add_lam nes+ scan <- I.scanSOAC [I.Scan add_lam nes] all_offsets <- letTupExp "offsets" $ I.Op $ I.Screma w scan increments -- We have the offsets for each of the partitions, but we also need -- the total sizes, which are the last elements in the offests. We -- just have to be careful in case the array is empty.- last_index <- letSubExp "last_index" $ I.BasicOp $ I.BinOp (I.Sub Int32) w $ constant (1::Int32)+ last_index <- letSubExp "last_index" $ I.BasicOp $ I.BinOp (I.Sub Int32 OverflowUndef) w $ constant (1::Int32) nonempty_body <- runBodyBinder $ fmap resultBody $ forM all_offsets $ \offset_array -> letSubExp "last_offset" $ I.BasicOp $ I.Index offset_array [I.DimFix last_index] let empty_body = resultBody $ replicate k $ constant (0::Int32)@@ -1805,14 +1801,13 @@ I.If is_empty empty_body nonempty_body $ ifCommon $ replicate k $ I.Prim int32 - -- Compute total size of all partitions.- sum_of_partition_sizes <- letSubExp "sum_of_partition_sizes" =<<- foldBinOp (Add Int32) (constant (0::Int32)) (map I.Var sizes)+ -- The total size of all partitions must necessarily be equal to the+ -- size of the input array. -- Create scratch arrays for the result. blanks <- forM arr_ts $ \arr_t -> letExp "partition_dest" $ I.BasicOp $- Scratch (elemType arr_t) (sum_of_partition_sizes : drop 1 (I.arrayDims arr_t))+ Scratch (elemType arr_t) (w : drop 1 (I.arrayDims arr_t)) -- Now write into the result. write_lam <- do@@ -1831,7 +1826,7 @@ } results <- letTupExp "partition_res" $ I.Op $ I.Scatter w write_lam (classes : all_offsets ++ arrs) $- zip3 (repeat sum_of_partition_sizes) (repeat 1) blanks+ zip3 (repeat w) (repeat 1) blanks sizes' <- letSubExp "partition_sizes" $ I.BasicOp $ I.ArrayLit (map I.Var sizes) $ I.Prim int32 return (map I.Var results, [sizes'])@@ -1847,7 +1842,7 @@ is_this_one <- letSubExp "is_this_one" $ I.BasicOp $ I.CmpOp (CmpEq int32) c (constant i) next_one <- mkOffsetLambdaBody sizes c (i+1) ps this_one <- letSubExp "this_offset" =<<- foldBinOp (Add Int32) (constant (-1::Int32))+ foldBinOp (Add Int32 OverflowUndef) (constant (-1::Int32)) (I.Var (I.paramName p) : take i sizes) letSubExp "total_res" $ I.If is_this_one (resultBody [this_one]) (resultBody [next_one]) $ ifCommon [I.Prim int32]
src/Futhark/Internalise/AccurateSizes.hs view
@@ -114,7 +114,7 @@ else do certs <- asserting $ do matches <- zipWithM checkDim newdims olddims- all_match <- letSubExp "match" =<< foldBinOp LogAnd (constant True) matches+ all_match <- letSubExp "match" =<< eAll matches Certificates . pure <$> letExp "empty_or_match_cert" (BasicOp $ Assert all_match msg (loc, [])) certifying certs $ letExp name $ shapeCoerce newdims v
src/Futhark/Internalise/Lambdas.hs view
@@ -9,16 +9,13 @@ ) where -import Control.Monad import Data.Loc import Language.Futhark as E import Futhark.Representation.SOACS as I import Futhark.MonadFreshNames- import Futhark.Internalise.Monad import Futhark.Internalise.AccurateSizes-import Futhark.Representation.SOACS.Simplify (simplifyLambda) -- | A function for internalising lambdas. type InternaliseLambda =@@ -32,20 +29,12 @@ argtypes <- mapM I.subExpType args let rowtypes = map I.rowType argtypes (params, body, rettype) <- internaliseLambda lam rowtypes- (rettype', inner_shapes) <- instantiateShapes' rettype- let outer_shape = arraysSize 0 argtypes- shapefun <- makeShapeFun params body rettype' inner_shapes- bindMapShapes index0 [] inner_shapes shapefun args outer_shape+ (rettype', _) <- instantiateShapes' rettype body' <- localScope (scopeOfLParams params) $ ensureResultShape asserting (ErrorMsg [ErrorString "not all iterations produce same shape"]) (srclocOf lam) rettype' body return $ I.Lambda params body' rettype'- where index0 arg = do- arg' <- letExp "arg" $ I.BasicOp $ I.SubExp arg- arg_t <- lookupType arg'- return $ I.BasicOp $ I.Index arg' $ fullSlice arg_t [I.DimFix zero]- zero = constant (0::I.Int32) internaliseStreamMapLambda :: InternaliseLambda -> E.Exp@@ -63,68 +52,13 @@ body <- runBodyBinder $ do letBindNames_ [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size return orig_body- (rettype', inner_shapes) <- instantiateShapes' rettype- let outer_shape = arraysSize 0 argtypes- shapefun <- makeShapeFun (chunk_param:params) body rettype' inner_shapes- bindMapShapes (slice0 chunk_size) [zero] inner_shapes shapefun args outer_shape+ (rettype', _) <- instantiateShapes' rettype body' <- localScope (scopeOfLParams params) $ insertStmsM $ do letBindNames_ [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size ensureResultShape asserting (ErrorMsg [ErrorString "not all iterations produce same shape"]) (srclocOf lam) (map outer rettype') body return $ I.Lambda (chunk_param:params) body' (map outer rettype')- where slice0 chunk_size arg = do- arg' <- letExp "arg" $ I.BasicOp $ I.SubExp arg- arg_t <- lookupType arg'- return $ I.BasicOp $ I.Index arg' $- fullSlice arg_t [I.DimSlice zero (I.Var chunk_size) one]- zero = constant (0::I.Int32)- one = constant (1::I.Int32)--makeShapeFun :: [I.LParam] -> I.Body -> [Type] -> [I.Ident]- -> InternaliseM I.Lambda-makeShapeFun params body val_rettype inner_shapes = do- -- Some of 'params' may be unique, which means that the shape slice- -- would consume its input. This is not acceptable - that input is- -- needed for the value function! Hence, for all unique parameters,- -- we create a substitute non-unique parameter, and insert a- -- copy-binding in the body of the function.- (params', copystms) <- nonuniqueParams params- shape_body <- runBodyBinder $ localScope (scopeOfLParams params') $ do- mapM_ addStm copystms- shapeBody (map I.identName inner_shapes) val_rettype body- return $ I.Lambda params' shape_body rettype- where rettype = replicate (length inner_shapes) $ I.Prim int32--bindMapShapes :: (SubExp -> InternaliseM I.Exp) -> [SubExp]- -> [I.Ident] -> I.Lambda -> [I.SubExp] -> SubExp- -> InternaliseM ()-bindMapShapes indexArg extra_args inner_shapes sizefun args outer_shape- | null $ I.lambdaReturnType sizefun = return ()- | otherwise = do- let size_args = replicate (length $ lambdaParams sizefun) Nothing- sizefun' <- simplifyLambda sizefun size_args- let sizefun_safe =- all (I.safeExp . I.stmExp) $ I.bodyStms $ I.lambdaBody sizefun'- sizefun_arg_invariant =- not $ any ((`nameIn` freeIn (I.lambdaBody sizefun')) . I.paramName) $- lambdaParams sizefun'- if sizefun_safe && sizefun_arg_invariant- then do ses <- bodyBind $ lambdaBody sizefun'- forM_ (zip inner_shapes ses) $ \(v, se) ->- letBind_ (basicPattern [] [v]) $ I.BasicOp $ I.SubExp se- else letBind_ (basicPattern [] inner_shapes) =<<- eIf' isnonempty nonemptybranch emptybranch IfFallback-- where emptybranch =- pure $ resultBody (map (const zero) $ I.lambdaReturnType sizefun)- nonemptybranch = insertStmsM $- resultBody <$> (eLambda sizefun . (map eSubExp extra_args++) $ map indexArg args)-- isnonempty = eNot $ eCmpOp (I.CmpEq I.int32)- (pure $ I.BasicOp $ I.SubExp outer_shape)- (pure $ I.BasicOp $ SubExp zero)- zero = constant (0::I.Int32) internaliseFoldLambda :: InternaliseLambda -> E.Exp
src/Futhark/Internalise/Monomorphise.hs view
@@ -721,8 +721,6 @@ tbinding = TypeAbbr l tparams tp return mempty { envTypeBindings = M.singleton name tbinding } --- | Monomorphise a list of top-level declarations. A module-free input program--- is expected, so only value declarations and type declaration are accepted. transformDecs :: [Dec] -> MonoM () transformDecs [] = return () transformDecs (ValDec valbind : ds) = do@@ -737,6 +735,8 @@ error $ "The monomorphization module expects a module-free " ++ "input program, but received: " ++ pretty dec +-- | Monomorphise a list of top-level declarations. A module-free input program+-- is expected, so only value declarations and type declaration are accepted. transformProg :: MonadFreshNames m => [Dec] -> m [ValBind] transformProg decs = fmap (toList . fmap snd . snd) $ modifyNameSource $ \namesrc ->
src/Futhark/Optimise/Fusion.hs view
@@ -444,8 +444,8 @@ infusible_nms = namesFromList $ filter (`nameIn` infusible res) out_nms out_arr_nms = case soac of -- the accumulator result cannot be fused!- SOAC.Screma _ (ScremaForm (_, scan_nes) reds _) _ ->- drop (length scan_nes + redResults reds) out_nms+ SOAC.Screma _ (ScremaForm scans reds _) _ ->+ drop (scanResults scans + redResults reds) out_nms SOAC.Stream _ frm _ _ -> drop (length $ getStreamAccums frm) out_nms _ -> out_nms to_fuse_knms1 = S.toList $ getKersWithInpArrs res (out_arr_nms++inp_nms)@@ -594,12 +594,12 @@ forM_ (zip loop_params chunked_params) $ \(p,a_p) -> letBindNames_ [paramName p] $ BasicOp $ Index (paramName a_p) $ fullSlice (paramType a_p) [DimFix $ Futhark.Var j]- letBindNames_ [i] $ BasicOp $ BinOp (Add it) (Futhark.Var offset) (Futhark.Var j)+ letBindNames_ [i] $ BasicOp $ BinOp (Add it OverflowUndef) (Futhark.Var offset) (Futhark.Var j) return body eBody [pure $ DoLoop [] merge' (ForLoop j it (Futhark.Var chunk_size) []) loop_body, pure $- BasicOp $ BinOp (Add Int32) (Futhark.Var offset) (Futhark.Var chunk_size)]+ BasicOp $ BinOp (Add Int32 OverflowUndef) (Futhark.Var offset) (Futhark.Var chunk_size)] let lam = Lambda { lambdaParams = lam_params , lambdaBody = lam_body , lambdaReturnType = map paramType $ acc_params ++ [offset_param]@@ -632,9 +632,9 @@ fres' <- addNamesToInfusible fres $ namesFromList $ patternNames pat mapLike fres' soac lam - Right soac@(SOAC.Screma _ (ScremaForm (scan_lam, scan_nes) reds map_lam) _) ->- reduceLike soac (map redLambda reds ++ [scan_lam, map_lam]) $- scan_nes <> concatMap redNeutral reds+ Right soac@(SOAC.Screma _ (ScremaForm scans reds map_lam) _) ->+ reduceLike soac (map scanLambda scans <> map redLambda reds <> [map_lam]) $+ concatMap scanNeutral scans <> concatMap redNeutral reds Right soac@(SOAC.Stream _ form lam _) -> do -- a redomap does not neccessarily start a new kernel, e.g.,@@ -835,13 +835,18 @@ finaliseSOAC :: SOAC.SOAC SOACS -> FusionGM (SOAC.SOAC SOACS) finaliseSOAC new_soac = case new_soac of- SOAC.Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs -> do- scan_lam' <- simplifyAndFuseInLambda scan_lam+ SOAC.Screma w (ScremaForm scans reds map_lam) arrs -> do+ scans' <- forM scans $ \(Scan scan_lam scan_nes) -> do+ scan_lam' <- simplifyAndFuseInLambda scan_lam+ return $ Scan scan_lam' scan_nes+ reds' <- forM reds $ \(Reduce comm red_lam red_nes) -> do red_lam' <- simplifyAndFuseInLambda red_lam return $ Reduce comm red_lam' red_nes+ map_lam' <- simplifyAndFuseInLambda map_lam- return $ SOAC.Screma w (ScremaForm (scan_lam', scan_nes) reds' map_lam') arrs++ return $ SOAC.Screma w (ScremaForm scans' reds' map_lam') arrs SOAC.Scatter w lam inps dests -> do lam' <- simplifyAndFuseInLambda lam return $ SOAC.Scatter w lam' inps dests@@ -865,7 +870,7 @@ -> Binder SOACS (Futhark.SOAC SOACS) copyNewlyConsumed was_consumed soac = case soac of- Futhark.Screma w (Futhark.ScremaForm (scan_lam, scan_nes) reds map_lam) arrs -> do+ Futhark.Screma w (Futhark.ScremaForm scans reds map_lam) arrs -> do -- Copy any arrays that are consumed now, but were not in the -- constituents. arrs' <- mapM copyConsumedArr arrs@@ -873,12 +878,18 @@ -- lambda, and we have to substitute the name of the copy for -- the original. map_lam' <- copyFreeInLambda map_lam++ let scans' = map (\scan -> scan { scanLambda =+ Aliases.removeLambdaAliases+ (scanLambda scan)})+ scans+ let reds' = map (\red -> red { redLambda = Aliases.removeLambdaAliases (redLambda red)}) reds- return $ Futhark.Screma w- (Futhark.ScremaForm (Aliases.removeLambdaAliases scan_lam, scan_nes) reds' map_lam') arrs'++ return $ Futhark.Screma w (Futhark.ScremaForm scans' reds' map_lam') arrs' _ -> return $ removeOpAliases soac where consumed = consumedInOp soac
src/Futhark/Optimise/Fusion/LoopKernel.hs view
@@ -283,12 +283,14 @@ case (soac_c, soac_p) of _ | SOAC.width soac_p /= SOAC.width soac_c -> fail "SOAC widths must match." - (SOAC.Screma _ (ScremaForm (scan_lam_c, scan_nes_c) reds_c _) _,- SOAC.Screma _ (ScremaForm (scan_lam_p, scan_nes_p) reds_p _) _)- | mapFusionOK (drop (length scan_nes_p+Futhark.redResults reds_p) outVars) ker+ (SOAC.Screma _ (ScremaForm scans_c reds_c _) _,+ SOAC.Screma _ (ScremaForm scans_p reds_p _) _)+ | mapFusionOK (drop (Futhark.scanResults scans_p+Futhark.redResults reds_p) outVars) ker || horizFuse -> do let red_nes_p = concatMap redNeutral reds_p red_nes_c = concatMap redNeutral reds_c+ scan_nes_p = concatMap scanNeutral scans_p+ scan_nes_c = concatMap scanNeutral scans_c (res_lam', new_inp) = fuseRedomap unfus_set outVars lam_p scan_nes_p red_nes_p inp_p_arr outPairs@@ -298,11 +300,10 @@ (soac_c_scanout, soac_c_redout, soac_c_mapout) = splitAt3 (length scan_nes_c) (length red_nes_c) $ outNames ker unfus_arrs = returned_outvars \\ (soac_p_scanout++soac_p_redout)- scan_lam' = mergeReduceOps scan_lam_p scan_lam_c success (soac_p_scanout ++ soac_c_scanout ++ soac_p_redout ++ soac_c_redout ++ soac_c_mapout ++ unfus_arrs) $- SOAC.Screma w (ScremaForm (scan_lam', scan_nes_p++scan_nes_c) (reds_p ++ reds_c) res_lam')+ SOAC.Screma w (ScremaForm (scans_p ++ scans_c) (reds_p ++ reds_c) res_lam') new_inp ------------------@@ -549,7 +550,7 @@ iswim :: Maybe [VName] -> SOAC -> SOAC.ArrayTransforms -> TryFusion (SOAC, SOAC.ArrayTransforms) iswim _ (SOAC.Screma w form arrs) ots- | Just (scan_fun, nes) <- Futhark.isScanSOAC form,+ | Just [Futhark.Scan scan_fun nes] <- Futhark.isScanSOAC form, Just (map_pat, map_cs, map_w, map_fun) <- rwimPossible scan_fun, Just nes_names <- mapM subExpVar nes = do @@ -569,18 +570,18 @@ nes' = map Var $ take (length map_nes) $ map paramName map_params arrs' = drop (length map_nes) $ map paramName map_params - id_map_lam <- mkIdentityLambda $ lambdaReturnType scan_fun'+ scan_form <- scanSOAC [Futhark.Scan scan_fun' nes'] let map_body = mkBody (oneStm $ Let (setPatternOuterDimTo w map_pat) (defAux ()) $- Op $ Futhark.Screma w (ScremaForm (scan_fun', nes') [] id_map_lam) arrs') $+ Op $ Futhark.Screma w scan_form arrs') $ map Var $ patternNames map_pat map_fun' = Lambda map_params map_body map_rettype perm = case lambdaReturnType map_fun of [] -> [] t:_ -> 1 : 0 : [2..arrayRank t] - return (SOAC.Screma map_w (ScremaForm (nilFn, mempty) [] map_fun') map_arrs',+ return (SOAC.Screma map_w (ScremaForm [] [] map_fun') map_arrs', ots SOAC.|> SOAC.Rearrange map_cs perm) iswim _ _ _ =
src/Futhark/Optimise/InPlaceLowering.hs view
@@ -79,7 +79,6 @@ import Futhark.MonadFreshNames import Futhark.Binder import Futhark.Pass-import Futhark.Tools (fullSlice) -- | Apply the in-place lowering optimisation to the given program. inPlaceLoweringKernels :: Pass Kernels Kernels@@ -130,35 +129,36 @@ optimiseStms (bnd:bnds) m = do (bnds', bup) <- tapBottomUp $ bindingStm bnd $ optimiseStms bnds m bnd' <- optimiseInStm bnd- case filter ((`elem` boundHere) . updateValue) $- forwardThese bup of- [] -> checkIfForwardableUpdate bnd' bnds'+ case filter ((`elem` boundHere) . updateValue) $ forwardThese bup of+ [] -> do checkIfForwardableUpdate bnd'+ return $ bnd':bnds' updates -> do- let updateStms = map updateStm updates lower <- asks topLowerUpdate scope <- askScope++ -- If we forward any updates, we need to remove them from bnds'.+ let updated_names =+ map updateName updates+ notUpdated =+ not . any (`elem` updated_names) . patternNames . stmPattern+ -- Condition (5) and (7) are assumed to be checked by -- lowerUpdate. case lower scope bnd' updates of Just lowering -> do new_bnds <- lowering new_bnds' <- optimiseStms new_bnds $ tell bup { forwardThese = [] }- return $ new_bnds' ++ bnds'- Nothing -> checkIfForwardableUpdate bnd' $- updateStms ++ bnds'+ return $ new_bnds' ++ filter notUpdated bnds'+ Nothing -> do checkIfForwardableUpdate bnd'+ return $ bnd':bnds' where boundHere = patternNames $ stmPattern bnd - checkIfForwardableUpdate bnd'@(Let (Pattern [] [PatElem v attr])- (StmAux cs _) e) bnds'- | BasicOp (Update src (DimFix i:slice) (Var ve)) <- e,- slice == drop 1 (fullSlice (typeOf attr) [DimFix i]) = do- forwarded <- maybeForward ve v attr cs src i- return $ if forwarded- then bnds'- else bnd' : bnds'- checkIfForwardableUpdate bnd' bnds' =- return $ bnd' : bnds'+ checkIfForwardableUpdate (Let pat (StmAux cs _) e)+ | Pattern [] [PatElem v attr] <- pat,+ BasicOp (Update src slice (Var ve)) <- e =+ maybeForward ve v attr cs src slice+ checkIfForwardableUpdate _ = return () optimiseInStm :: Constraints lore => Stm (Aliases lore) -> ForwardingM lore (Stm (Aliases lore)) optimiseInStm (Let pat attr e) =@@ -215,13 +215,6 @@ instance Monoid (BottomUp lore) where mempty = BottomUp mempty mempty -updateStm :: Constraints lore => DesiredUpdate (LetAttr (Aliases lore)) -> Stm (Aliases lore)-updateStm fwd =- mkLet [] [Ident (updateName fwd) $ typeOf $ updateType fwd] $- BasicOp $ Update (updateSource fwd)- (fullSlice (typeOf $ updateType fwd) $ updateIndices fwd) $- Var $ updateValue fwd- newtype ForwardingM lore a = ForwardingM (RWS (TopDown lore) (BottomUp lore) VNameSource a) deriving (Monad, Applicative, Functor, MonadReader (TopDown lore),@@ -293,10 +286,10 @@ deepen :: ForwardingM lore a -> ForwardingM lore a deepen = local $ \env -> env { topDownDepth = topDownDepth env + 1 } -areAvailableBefore :: [SubExp] -> VName -> ForwardingM lore Bool-areAvailableBefore ses point = do+areAvailableBefore :: Names -> VName -> ForwardingM lore Bool+areAvailableBefore names point = do pointN <- bindingNumber point- nameNs <- mapM bindingNumber $ subExpVars ses+ nameNs <- mapM bindingNumber $ namesToList names return $ all (< pointN) nameNs isInCurrentBody :: VName -> ForwardingM lore Bool@@ -327,20 +320,18 @@ maybeForward :: Constraints lore => VName- -> VName -> LetAttr (Aliases lore) -> Certificates -> VName -> SubExp- -> ForwardingM lore Bool-maybeForward v dest_nm dest_attr cs src i = do+ -> VName -> LetAttr (Aliases lore)+ -> Certificates -> VName -> Slice SubExp+ -> ForwardingM lore ()+maybeForward v dest_nm dest_attr cs src slice = do -- Checks condition (2)- available <- [i,Var src] `areAvailableBefore` v- -- ...subcondition, the certificates must also.- certs_available <- map Var (namesToList $ freeIn cs) `areAvailableBefore` v+ available <- (freeIn src <> freeIn slice <> freeIn cs)+ `areAvailableBefore` v -- Check condition (3) samebody <- isInCurrentBody v -- Check condition (6) optimisable <- isOptimisable v not_prim <- not . primType <$> lookupType v- if available && certs_available && samebody && optimisable && not_prim then do- let fwd = DesiredUpdate dest_nm dest_attr cs src [DimFix i] v+ when (available && samebody && optimisable && not_prim) $ do+ let fwd = DesiredUpdate dest_nm dest_attr cs src slice v tell mempty { forwardThese = [fwd] }- return True- else return False
src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs view
@@ -64,28 +64,51 @@ lowerUpdateKernels :: MonadFreshNames m => LowerUpdate Kernels m lowerUpdateKernels _- (Let (Pattern [] [PatElem v v_attr]) aux (Op (SegOp (SegMap lvl space ts kbody))))- [update@(DesiredUpdate bindee_nm bindee_attr cs _src is val)]- | v == val = do- kbody' <- lowerUpdateIntoKernel update space kbody- let is' = fullSlice (typeOf bindee_attr) is- Just $ return [certify (stmAuxCerts aux <> cs) $- mkLet [] [Ident bindee_nm $ typeOf bindee_attr] $- Op $ SegOp $ SegMap lvl space ts kbody',- mkLet [] [Ident v $ typeOf v_attr] $ BasicOp $ Index bindee_nm is']+ (Let pat aux (Op (SegOp (SegMap lvl space ts kbody)))) updates+ | all ((`elem` patternNames pat) . updateValue) updates = do+ (pat', kbody', poststms) <-+ lowerUpdatesIntoSegMap pat updates space kbody+ let cs = stmAuxCerts aux <> foldMap updateCertificates updates+ Just $ return $+ certify cs (Let pat' aux $ Op $ SegOp $ SegMap lvl space ts kbody') :+ stmsToList poststms lowerUpdateKernels scope stm updates = lowerUpdate scope stm updates -lowerUpdateIntoKernel :: DesiredUpdate (LetAttr (Aliases Kernels))- -> SegSpace -> KernelBody (Aliases Kernels)- -> Maybe (KernelBody (Aliases Kernels))-lowerUpdateIntoKernel update kspace kbody = do- [Returns _ se] <- Just $ kernelBodyResult kbody- is' <- mapM dimFix is- let ret = WriteReturns (arrayDims $ snd bindee_attr) src [(is'++map Var gtids, se)]- return kbody { kernelBodyResult = [ret] }- where DesiredUpdate _bindee_nm bindee_attr _cs src is _val = update- gtids = map fst $ unSegSpace kspace+lowerUpdatesIntoSegMap :: Pattern (Aliases Kernels)+ -> [DesiredUpdate (LetAttr (Aliases Kernels))]+ -> SegSpace+ -> KernelBody (Aliases Kernels)+ -> Maybe (Pattern (Aliases Kernels),+ KernelBody (Aliases Kernels),+ Stms (Aliases Kernels))+lowerUpdatesIntoSegMap pat updates kspace kbody = do+ -- The updates are all-or-nothing. Being more liberal would require+ -- changes to the in-place-lowering pass itself.+ (pes, krets, poststms) <-+ unzip3 <$> zipWithM onRet (patternElements pat) (kernelBodyResult kbody)+ return (Pattern [] pes,+ kbody { kernelBodyResult = krets },+ mconcat poststms) + where (gtids, dims) = unzip $ unSegSpace kspace++ onRet (PatElem v v_attr) (Returns _ se)+ | Just (DesiredUpdate bindee_nm bindee_attr _cs src is _val) <-+ find ((==v) . updateValue) updates = do++ guard $ sliceDims is == dims++ let ret = WriteReturns (arrayDims $ snd bindee_attr) src+ [(map Var gtids, se)]++ return (PatElem bindee_nm bindee_attr,+ ret,+ oneStm $ mkLet [] [Ident v $ typeOf v_attr] $+ BasicOp $ Index bindee_nm is)++ onRet pe ret =+ return (pe, ret, mempty)+ lowerUpdateIntoLoop :: (Bindable lore, BinderOps lore, Aliased lore, LetAttr lore ~ (als, Type), MonadFreshNames m) =>@@ -163,13 +186,16 @@ | Just (update, mergename, mergeattr) <- relatedUpdate summary = do source <- newVName "modified_source" let source_t = snd $ updateType update- elmident = Ident (updateValue update) $ rowType source_t+ elmident = Ident+ (updateValue update)+ (source_t `setArrayDims` sliceDims (updateIndices update)) tell ([mkLet [] [Ident source source_t] $ BasicOp $ Update (updateSource update) (fullSlice source_t $ updateIndices update) $ snd $ mergeParam summary], [mkLet [] [elmident] $ BasicOp $ Index- (updateName update) (fullSlice (typeOf $ updateType update) $ updateIndices update)])+ (updateName update)+ (fullSlice source_t $ updateIndices update)]) return $ Right (Param mergename (toDecl (typeOf mergeattr) Unique),
src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs view
@@ -86,7 +86,8 @@ return $ update v v (mempty, row_copy, src2attr `setType`- stripArray (length is2) (typeOf src2attr),+ (typeOf src2attr `setArrayDims`+ sliceDims is2), []) substs' consumingSubst substs' _ = return substs'@@ -96,8 +97,10 @@ IndexSubstitutions (LetAttr (Lore m)) -> SubExp -> m SubExp-substituteIndicesInSubExp substs (Var v) = Var <$> substituteIndicesInVar substs v-substituteIndicesInSubExp _ se = return se+substituteIndicesInSubExp substs (Var v) =+ Var <$> substituteIndicesInVar substs v+substituteIndicesInSubExp _ se =+ return se substituteIndicesInVar :: MonadBinder m => IndexSubstitutions (LetAttr (Lore m))@@ -105,7 +108,8 @@ -> m VName substituteIndicesInVar substs v | Just (cs2, src2, _, []) <- lookup v substs =- certifying cs2 $ letExp (baseString src2) $ BasicOp $ SubExp $ Var src2+ certifying cs2 $+ letExp (baseString src2) $ BasicOp $ SubExp $ Var src2 | Just (cs2, src2, src2_attr, is2) <- lookup v substs = certifying cs2 $ letExp "idx" $ BasicOp $ Index src2 $ fullSlice (typeOf src2_attr) is2@@ -116,13 +120,12 @@ IndexSubstitutions (LetAttr (Lore m)) -> Body (Lore m) -> m (Body (Lore m))-substituteIndicesInBody substs body = do- (substs', bnds') <- inScopeOf bnds $- collectStms $ substituteIndicesInStms substs bnds- (ses, ses_bnds) <- inScopeOf bnds' $- collectStms $ mapM (substituteIndicesInSubExp substs') $ bodyResult body- mkBodyM (bnds'<>ses_bnds) ses- where bnds = bodyStms body+substituteIndicesInBody substs (Body _ stms res) = do+ (substs', stms') <- inScopeOf stms $+ collectStms $ substituteIndicesInStms substs stms+ (res', res_stms) <- inScopeOf stms' $+ collectStms $ mapM (substituteIndicesInSubExp substs') res+ mkBodyM (stms'<>res_stms) res' update :: VName -> VName -> IndexSubstitution attr -> IndexSubstitutions attr -> IndexSubstitutions attr
src/Futhark/Optimise/Simplify.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-} module Futhark.Optimise.Simplify ( simplifyProg , simplifySomething
src/Futhark/Optimise/Simplify/ClosedForm.hs view
@@ -127,11 +127,11 @@ case bop of LogAnd -> letBindNames_ [p] $ BasicOp $ BinOp LogAnd this el- Add t | Just properly_typed_size <- properIntSize t -> do- size' <- properly_typed_size- letBindNames_ [p] =<<- eBinOp (Add t) (eSubExp this)- (pure $ BasicOp $ BinOp (Mul t) el size')+ Add t w | Just properly_typed_size <- properIntSize t -> do+ size' <- properly_typed_size+ letBindNames_ [p] =<<+ eBinOp (Add t w) (eSubExp this)+ (pure $ BasicOp $ BinOp (Mul t w) el size') FAdd t | Just properly_typed_size <- properFloatSize t -> do size' <- properly_typed_size letBindNames_ [p] =<<
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -793,6 +793,9 @@ simplifyParam simplifyAttribute (Param name attr) = Param name <$> simplifyAttribute attr +instance Simplifiable () where+ simplify = pure+ instance Simplifiable VName where simplify v = do se <- ST.lookupSubExp v <$> askVtable
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -646,14 +646,14 @@ primExpFromSubExp (IntType to_it) s * primExpFromSubExp (IntType to_it) i_offset' i_stride'' <- letSubExp "iota_offset" $- BasicOp $ BinOp (Mul Int32) s i_stride'+ BasicOp $ BinOp (Mul Int32 OverflowWrap) s i_stride' fmap (SubExpResult cs) $ letSubExp "slice_iota" $ BasicOp $ Iota i_n i_offset'' i_stride'' to_it Just (Rotate offsets a, cs) -> Just $ do dims <- arrayDims <$> lookupType a let adjustI i o d = do- i_p_o <- letSubExp "i_p_o" $ BasicOp $ BinOp (Add Int32) i o+ i_p_o <- letSubExp "i_p_o" $ BasicOp $ BinOp (Add Int32 OverflowWrap) i o letSubExp "rot_i" (BasicOp $ BinOp (SMod Int32) i_p_o d) adjust (DimFix i, o, d) = DimFix <$> adjustI i o d@@ -719,7 +719,7 @@ xs_lens <- mapM (fmap (arraySize d) . lookupType) xs let add n m = do- added <- letSubExp "index_concat_add" $ BasicOp $ BinOp (Add Int32) n m+ added <- letSubExp "index_concat_add" $ BasicOp $ BinOp (Add Int32 OverflowWrap) n m return (added, n) (_, starts) <- mapAccumLM add x_len xs_lens let xs_and_starts = reverse $ zip xs starts@@ -729,7 +729,7 @@ mkBranch ((x', start):xs_and_starts') = do cmp <- letSubExp "index_concat_cmp" $ BasicOp $ CmpOp (CmpSle Int32) start i (thisres, thisbnds) <- collectStms $ do- i' <- letSubExp "index_concat_i" $ BasicOp $ BinOp (Sub Int32) i start+ i' <- letSubExp "index_concat_i" $ BasicOp $ BinOp (Sub Int32 OverflowWrap) i start letSubExp "index_concat" $ BasicOp $ Index x' $ ibef ++ DimFix i' : iaft thisbody <- mkBodyM thisbnds [thisres] (altres, altbnds) <- collectStms $ mkBranch xs_and_starts'@@ -776,12 +776,12 @@ [DimIndex SubExp] -> [DimIndex SubExp] -> m [DimIndex SubExp] sliceSlice (DimFix j:js') is' = (DimFix j:) <$> sliceSlice js' is' sliceSlice (DimSlice j _ s:js') (DimFix i:is') = do- i_t_s <- letSubExp "j_t_s" $ BasicOp $ BinOp (Mul Int32) i s- j_p_i_t_s <- letSubExp "j_p_i_t_s" $ BasicOp $ BinOp (Add Int32) j i_t_s+ i_t_s <- letSubExp "j_t_s" $ BasicOp $ BinOp (Mul Int32 OverflowWrap) i s+ j_p_i_t_s <- letSubExp "j_p_i_t_s" $ BasicOp $ BinOp (Add Int32 OverflowWrap) j i_t_s (DimFix j_p_i_t_s:) <$> sliceSlice js' is' sliceSlice (DimSlice j _ s0:js') (DimSlice i n s1:is') = do- s0_t_i <- letSubExp "s0_t_i" $ BasicOp $ BinOp (Mul Int32) s0 i- j_p_s0_t_i <- letSubExp "j_p_s0_t_i" $ BasicOp $ BinOp (Add Int32) j s0_t_i+ s0_t_i <- letSubExp "s0_t_i" $ BasicOp $ BinOp (Mul Int32 OverflowWrap) s0 i+ j_p_s0_t_i <- letSubExp "j_p_s0_t_i" $ BasicOp $ BinOp (Add Int32 OverflowWrap) j s0_t_i (DimSlice j_p_s0_t_i n s1:) <$> sliceSlice js' is' sliceSlice _ _ = return [] @@ -1203,7 +1203,7 @@ | Just (BasicOp (Rearrange perm v2), v_cs) <- ST.lookupExp v vtable, Just (BasicOp (Rotate offsets2 v3), v2_cs) <- ST.lookupExp v2 vtable = Simplify $ do let offsets2' = rearrangeShape (rearrangeInverse perm) offsets2- addOffsets x y = letSubExp "summed_offset" $ BasicOp $ BinOp (Add Int32) x y+ addOffsets x y = letSubExp "summed_offset" $ BasicOp $ BinOp (Add Int32 OverflowWrap) x y offsets' <- zipWithM addOffsets offsets offsets2' rotate_rearrange <- certifying cs $ letExp "rotate_rearrange" $ BasicOp $ Rearrange perm v3@@ -1216,7 +1216,7 @@ offsets <- zipWithM add offsets1 offsets2 certifying (cs<>v_cs) $ letBind_ pat $ BasicOp $ Rotate offsets v2- where add x y = letSubExp "offset" $ BasicOp $ BinOp (Add Int32) x y+ where add x y = letSubExp "offset" $ BasicOp $ BinOp (Add Int32 OverflowWrap) x y -- If we see an Update with a scalar where the value to be written is -- the result of indexing some other array, then we convert it into an
src/Futhark/Optimise/TileLoops.hs view
@@ -662,7 +662,7 @@ eDivRoundingUp Int32 (eSubExp kdim) (eSubExp group_size) num_groups <- letSubExp "computed_num_groups" =<<- foldBinOp (Mul Int32) ldim (map snd dims_on_top)+ foldBinOp (Mul Int32 OverflowUndef) ldim (map snd dims_on_top) return (SegGroup (Count num_groups) (Count group_size) SegNoVirt, SegSpace gid_flat $ dims_on_top ++ [(gid, ldim)])@@ -745,7 +745,7 @@ -> [(VName, [Int])] -> Binder Kernels [VName] readTile2D (kdim_x, kdim_y) (gtid_x, gtid_y) (gid_x, gid_y) tile_size num_groups group_size kind privstms tile_id arrs_and_perms =- segMap2D "full_tile" (SegThread num_groups group_size SegNoVirt)+ segMap2D "full_tile" (SegThread num_groups group_size SegNoVirtFull) ResultNoSimplify (tile_size, tile_size) $ \(ltid_x, ltid_y) -> do i <- letSubExp "i" =<< toExp (primExpFromSubExp int32 tile_id *@@ -799,7 +799,7 @@ -- Might be truncated in case of a partial tile. actual_tile_size <- arraysSize 0 <$> mapM (lookupType . fst) tiles_and_perms - segMap2D "acc" (SegThread num_groups group_size SegNoVirt)+ segMap2D "acc" (SegThread num_groups group_size SegNoVirtFull) ResultPrivate (tile_size, tile_size) $ \(ltid_x, ltid_y) -> do reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y) @@ -868,7 +868,7 @@ tile_size_key <- nameFromString . pretty <$> newVName "tile_size" tile_size <- letSubExp "tile_size" $ Op $ SizeOp $ GetSize tile_size_key SizeTile- group_size <- letSubExp "group_size" $ BasicOp $ BinOp (Mul Int32) tile_size tile_size+ group_size <- letSubExp "group_size" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) tile_size tile_size num_groups_x <- letSubExp "num_groups_x" =<< eDivRoundingUp Int32 (eSubExp kdim_x) (eSubExp tile_size)@@ -876,11 +876,11 @@ eDivRoundingUp Int32 (eSubExp kdim_y) (eSubExp tile_size) num_groups <- letSubExp "num_groups_top" =<<- foldBinOp (Mul Int32) num_groups_x+ foldBinOp (Mul Int32 OverflowUndef) num_groups_x (num_groups_y : map snd dims_on_top) gid_flat <- newVName "gid_flat"- let lvl = SegGroup (Count num_groups) (Count group_size) SegNoVirt+ let lvl = SegGroup (Count num_groups) (Count group_size) SegNoVirtFull space = SegSpace gid_flat $ dims_on_top ++ [(gid_x, num_groups_x), (gid_y, num_groups_y)]
src/Futhark/Pass.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-} -- | Definition of a polymorphic (generic) pass that can work with programs of any -- lore. module Futhark.Pass
src/Futhark/Pass/ExpandAllocations.hs view
@@ -22,7 +22,6 @@ import Futhark.Pass import Futhark.Representation.AST import Futhark.Representation.KernelsMem-import qualified Futhark.Representation.Kernels as Kernels import Futhark.Representation.Kernels.Simplify as Kernels import qualified Futhark.Representation.Mem.IxFun as IxFun import Futhark.Pass.ExtractKernels.BlockedKernel (nonSegRed)@@ -30,6 +29,8 @@ import Futhark.Pass.ExplicitAllocations.Kernels (explicitAllocationsInStms) import Futhark.Transform.Rename (renameStm) import Futhark.Transform.CopyPropagate (copyPropagateInFun)+import Futhark.Optimise.Simplify.Lore (addScopeWisdom)+import qualified Futhark.Analysis.SymbolTable as ST import Futhark.Util.IntegralExp import Futhark.Util (mapAccumLM) @@ -55,7 +56,7 @@ transformFunDef scope fundec = do body' <- modifyNameSource $ limitationOnLeft . runStateT (runReaderT m mempty) copyPropagateInFun simpleKernelsMem- mempty fundec { funDefBody = body' }+ (ST.fromScope (addScopeWisdom scope)) fundec { funDefBody = body' } where m = localScope scope $ inScopeOf fundec $ transformBody $ funDefBody fundec @@ -111,15 +112,17 @@ transformExp (Op (Inner (SegOp (SegRed lvl space reds ts kbody)))) = do (alloc_stms, (lams, kbody')) <-- transformScanRed lvl space (map segRedLambda reds) kbody- let reds' = zipWith (\red lam -> red { segRedLambda = lam }) reds lams+ transformScanRed lvl space (map segBinOpLambda reds) kbody+ let reds' = zipWith (\red lam -> red { segBinOpLambda = lam }) reds lams return (alloc_stms, Op $ Inner $ SegOp $ SegRed lvl space reds' ts kbody') -transformExp (Op (Inner (SegOp (SegScan lvl space scan_op nes ts kbody)))) = do- (alloc_stms, (scan_op', kbody')) <- transformScanRed lvl space [scan_op] kbody+transformExp (Op (Inner (SegOp (SegScan lvl space scans ts kbody)))) = do+ (alloc_stms, (lams, kbody')) <-+ transformScanRed lvl space (map segBinOpLambda scans) kbody+ let scans' = zipWith (\red lam -> red { segBinOpLambda = lam }) scans lams return (alloc_stms,- Op $ Inner $ SegOp $ SegScan lvl space (head scan_op') nes ts kbody')+ Op $ Inner $ SegOp $ SegScan lvl space scans' ts kbody') transformExp (Op (Inner (SegOp (SegHist lvl space ops ts kbody)))) = do (alloc_stms, (lams', kbody')) <- transformScanRed lvl space lams kbody@@ -185,7 +188,7 @@ -> ExpandM (RebaseMap, Stms KernelsMem) memoryRequirements lvl space kstms variant_allocs invariant_allocs = do ((num_threads, num_threads64), num_threads_stms) <- runBinder $ do- num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32)+ num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) (unCount $ segNumGroups lvl) (unCount $ segGroupSize lvl) num_threads64 <- letSubExp "num_threads64" $ BasicOp $ ConvOp (SExt Int32 Int64) num_threads return (num_threads, num_threads64)@@ -299,7 +302,7 @@ allocpat = Pattern [] [PatElem mem $ MemMem space] return (stmsFromList [Let sizepat (defAux ()) $- BasicOp $ BinOp (Mul Int64) num_threads64 per_thread_size,+ BasicOp $ BinOp (Mul Int64 OverflowUndef) num_threads64 per_thread_size, Let allocpat (defAux ()) $ Op $ Alloc (Var total_size) space], M.singleton mem newBase)@@ -621,11 +624,11 @@ (newIdent "max_per_thread" $ Prim int64) w <- letSubExp "size_slice_w" =<<- foldBinOp (Mul Int32) (intConst Int32 1) (segSpaceDims space)+ foldBinOp (Mul Int32 OverflowUndef) (intConst Int32 1) (segSpaceDims space) thread_space_iota <- letExp "thread_space_iota" $ BasicOp $ Iota w (intConst Int32 0) (intConst Int32 1) Int32- let red_op = SegRedOp Commutative max_lam+ let red_op = SegBinOp Commutative max_lam (replicate num_sizes $ intConst Int64 0) mempty lvl <- segThread "segred" @@ -634,7 +637,7 @@ size_sums <- forM (patternNames pat) $ \threads_max -> letExp "size_sum" $- BasicOp $ BinOp (Mul Int64) (Var threads_max) num_threads_64+ BasicOp $ BinOp (Mul Int64 OverflowUndef) (Var threads_max) num_threads_64 return (patternNames pat, size_sums)
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -104,6 +104,9 @@ dimAllocationSize size = return size + -- | Get those names that are known to be constants at run-time.+ askConsts :: m (S.Set VName)+ expHints :: Exp lore -> m [ExpHint] expHints = defaultExpHints @@ -149,14 +152,13 @@ -- ^ When allocating memory, put it in this memory space. -- This is primarily used to ensure that group-wide -- statements store their results in local memory.+ , envConsts :: S.Set VName+ -- ^ The set of names that are known to be constants at+ -- kernel compile time. , allocInOp :: Op fromlore -> AllocM fromlore tolore (Op tolore) , envExpHints :: Exp tolore -> AllocM fromlore tolore [ExpHint] } -boundDims :: ChunkMap -> AllocEnv fromlore tolore- -> AllocEnv fromlore tolore-boundDims m env = env { chunkMap = m <> chunkMap env }- -- | Monad for adding allocations to an entire program. newtype AllocM fromlore tolore a = AllocM (BinderT tolore (ReaderT (AllocEnv fromlore tolore) (State VNameSource)) a)@@ -189,13 +191,21 @@ f e askDefaultSpace = asks allocSpace + askConsts = asks envConsts+ runAllocM :: MonadFreshNames m => (Op fromlore -> AllocM fromlore tolore (Op tolore)) -> (Exp tolore -> AllocM fromlore tolore [ExpHint]) -> AllocM fromlore tolore a -> m a runAllocM handleOp hints (AllocM m) = fmap fst $ modifyNameSource $ runState $ runReaderT (runBinderT m mempty) env- where env = AllocEnv mempty False DefaultSpace handleOp hints+ where env = AllocEnv { chunkMap = mempty+ , aggressiveReuse = False+ , allocSpace = DefaultSpace+ , envConsts = mempty+ , allocInOp = handleOp+ , envExpHints = hints+ } -- | Monad for adding allocations to a single pattern. newtype PatAllocM lore a = PatAllocM (RWS@@ -212,6 +222,7 @@ addAllocStm = tell . pure dimAllocationSize = return askDefaultSpace = return DefaultSpace+ askConsts = pure mempty runPatAllocM :: MonadFreshNames m => PatAllocM lore a -> Scope lore@@ -604,17 +615,21 @@ allocInStms :: (Allocable fromlore tolore) => Stms fromlore -> (Stms tolore -> AllocM fromlore tolore a) -> AllocM fromlore tolore a-allocInStms origbnds m = allocInStms' (stmsToList origbnds) mempty- where allocInStms' [] bnds' =- m bnds'- allocInStms' (x:xs) bnds' = do- allocbnds <- allocInStm' x- localScope (scopeOf allocbnds) $- local (boundDims $ mconcat $ map sizeSubst $ stmsToList allocbnds) $- allocInStms' xs (bnds'<>allocbnds)+allocInStms origstms m = allocInStms' (stmsToList origstms) mempty+ where allocInStms' [] stms' =+ m stms'+ allocInStms' (x:xs) stms' = do+ allocstms <- allocInStm' x+ localScope (scopeOf allocstms) $ do+ let stms_substs = foldMap sizeSubst allocstms+ stms_consts = foldMap stmConsts allocstms+ f env = env { chunkMap = stms_substs <> chunkMap env+ , envConsts = stms_consts <> envConsts env+ }+ local f $ allocInStms' xs (stms'<>allocstms) allocInStm' bnd = do- ((),bnds') <- collectStms $ certifying (stmCerts bnd) $ allocInStm bnd- return bnds'+ ((),stms') <- collectStms $ certifying (stmCerts bnd) $ allocInStm bnd+ return stms' allocInStm :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => Stm fromlore -> AllocM fromlore tolore ()@@ -828,6 +843,8 @@ class SizeSubst op where opSizeSubst :: PatternT attr -> op -> ChunkMap+ opIsConst :: op -> Bool+ opIsConst = const False instance SizeSubst () where opSizeSubst _ _ = mempty@@ -836,9 +853,17 @@ opSizeSubst pat (Inner op) = opSizeSubst pat op opSizeSubst _ _ = mempty + opIsConst (Inner op) = opIsConst op+ opIsConst _ = False+ sizeSubst :: SizeSubst (Op lore) => Stm lore -> ChunkMap sizeSubst (Let pat _ (Op op)) = opSizeSubst pat op sizeSubst _ = mempty++stmConsts :: SizeSubst (Op lore) => Stm lore -> S.Set VName+stmConsts (Let pat _ (Op op))+ | opIsConst op = S.fromList $ patternNames pat+stmConsts _ = mempty mkLetNamesB' :: (Op (Lore m) ~ MemOp inner, MonadBinder m, ExpAttr (Lore m) ~ (),
src/Futhark/Pass/ExplicitAllocations/Kernels.hs view
@@ -9,6 +9,7 @@ where import qualified Data.Map as M+import qualified Data.Set as S import qualified Futhark.Representation.Mem.IxFun as IxFun import Futhark.Representation.KernelsMem@@ -21,6 +22,10 @@ M.singleton (patElemName size) elems_per_thread opSizeSubst _ _ = mempty + opIsConst (SizeOp GetSize{}) = True+ opIsConst (SizeOp GetSizeMax{}) = True+ opIsConst _ = False+ instance SizeSubst (SegOp lvl lore) where opSizeSubst _ _ = mempty @@ -34,7 +39,7 @@ handleSegOp :: SegOp SegLevel Kernels -> AllocM Kernels KernelsMem (SegOp SegLevel KernelsMem) handleSegOp op = do- num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32)+ num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) (unCount (segNumGroups lvl)) (unCount (segGroupSize lvl)) allocAtLevel lvl $ mapSegOpM (mapper num_threads) op where scope = scopeOfSegSpace $ segSpace op@@ -75,7 +80,7 @@ kernelExpHints (Op (Inner (SegOp (SegRed lvl@SegThread{} space reds ts body)))) = (map (const NoHint) red_res <>) <$> zipWithM (mapResultHint lvl space) (drop num_reds ts) map_res- where num_reds = segRedResults reds+ where num_reds = segBinOpResults reds (red_res, map_res) = splitAt num_reds $ kernelBodyResult body kernelExpHints e =@@ -141,19 +146,20 @@ inGroupExpHints e = return $ replicate (expExtTypeSize e) NoHint inThreadExpHints :: Allocator KernelsMem m => Exp KernelsMem -> m [ExpHint]-inThreadExpHints e =- mapM maybePrivate =<< expExtType e- where maybePrivate t+inThreadExpHints e = do+ consts <- askConsts+ mapM (maybePrivate consts) =<< expExtType e+ where maybePrivate consts t | Just (Array pt shape _) <- hasStaticShape t,- all semiStatic $ shapeDims shape = do+ all (semiStatic consts) $ shapeDims shape = do let ixfun = IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape return $ Hint ixfun $ ScalarSpace (shapeDims shape) pt | otherwise = return NoHint - semiStatic Constant{} = True- semiStatic _ = False+ semiStatic _ Constant{} = True+ semiStatic consts (Var v) = v `S.member` consts explicitAllocations :: Pass Kernels KernelsMem explicitAllocations = explicitAllocationsGeneric handleHostOp kernelExpHints
src/Futhark/Pass/ExplicitAllocations/SegOp.hs view
@@ -38,7 +38,7 @@ Array bt shape u -> do twice_num_threads <- letSubExp "twice_num_threads" $- BasicOp $ BinOp (Mul Int32) num_threads $ intConst Int32 2+ BasicOp $ BinOp (Mul Int32 OverflowUndef) num_threads $ intConst Int32 2 let t = paramType x `arrayOfRow` twice_num_threads mem <- allocForArray t DefaultSpace -- XXX: this iota ixfun is a bit inefficient; leading to
src/Futhark/Pass/ExtractKernels.hs view
@@ -300,7 +300,7 @@ let size_key = nameFromString $ desc ++ "_" ++ show x runBinder $ do to_what' <- letSubExp "comparatee" =<<- foldBinOp (Mul Int32) (intConst Int32 1) to_what+ foldBinOp (Mul Int32 OverflowUndef) (intConst Int32 1) to_what cmp_res <- letSubExp desc $ Op $ SizeOp $ CmpSizeLe size_key size_class to_what' return (cmp_res, size_key) @@ -347,11 +347,23 @@ onMap path $ MapLoop pat cs w lam arrs transformStm path (Let res_pat (StmAux cs _) (Op (Screma w form arrs)))- | Just (scan_lam, nes) <- isScanSOAC form,+ | Just scans <- isScanSOAC form,+ Scan scan_lam nes <- singleScan scans, Just do_iswim <- iswim res_pat w scan_lam $ zip nes arrs = do types <- asksScope scopeForSOACs transformStms path =<< (stmsToList . snd <$> runBinderT (certifying cs do_iswim) types) + | Just (scans, map_lam) <- isScanomapSOAC form = runBinder_ $ do+ scan_ops <- forM scans $ \(Scan scan_lam nes) -> do+ (scan_lam', nes', shape) <- determineReduceOp scan_lam nes+ let scan_lam'' = soacsLambdaToKernels scan_lam'+ return $ SegBinOp Noncommutative scan_lam'' nes' shape+ let map_lam_sequential = soacsLambdaToKernels map_lam+ lvl <- segThreadCapped [w] "segscan" $ NoRecommendation SegNoVirt+ addStms =<<+ (fmap (certify cs) <$>+ segScan lvl res_pat w scan_ops map_lam_sequential arrs [] [])+ -- We are only willing to generate code for scanomaps that do not -- involve array accumulators, and do not have parallelism in their -- map function. Such cases will fall through to the@@ -359,13 +371,17 @@ -- Hopefully, the scan then triggers the ISWIM case above (otherwise -- we will still crash in code generation). However, if the map -- lambda is already identity, let's just go ahead here.- | Just (scan_lam, nes, map_lam) <- isScanomapSOAC form,- (all primType (lambdaReturnType scan_lam) &&+ | Just (scans, map_lam) <- isScanomapSOAC form,+ (all primType (concatMap (lambdaReturnType . scanLambda) scans) && not (lambdaContainsParallelism map_lam)) || isIdentityLambda map_lam = runBinder_ $ do- let scan_lam' = soacsLambdaToKernels scan_lam- map_lam' = soacsLambdaToKernels map_lam++ scan_ops <- forM scans $ \(Scan scan_lam nes) -> do+ let scan_lam' = soacsLambdaToKernels scan_lam+ return $ SegBinOp Noncommutative scan_lam' nes mempty++ let map_lam' = soacsLambdaToKernels map_lam lvl <- segThreadCapped [w] "segscan" $ NoRecommendation SegNoVirt- addStms =<< segScan lvl res_pat w scan_lam' map_lam' nes arrs [] []+ addStms =<< segScan lvl res_pat w scan_ops map_lam' arrs [] [] transformStm path (Let res_pat (StmAux cs _) (Op (Screma w form arrs))) | Just [Reduce comm red_fun nes] <- isReduceSOAC form,@@ -385,7 +401,7 @@ let comm' | commutativeLambda red_lam' = Commutative | otherwise = comm red_lam'' = soacsLambdaToKernels red_lam'- return $ SegRedOp comm' red_lam'' nes' shape+ return $ SegBinOp comm' red_lam'' nes' shape let map_lam_sequential = soacsLambdaToKernels map_lam lvl <- segThreadCapped [w] "segred" $ NoRecommendation SegNoVirt addStms =<<
src/Futhark/Pass/ExtractKernels/BlockedKernel.hs view
@@ -72,7 +72,7 @@ SegOpLevel lore -> Pattern lore -> SubExp -- segment size- -> [SegRedOp lore]+ -> [SegBinOp lore] -> Lambda lore -> [VName] -> [(VName, SubExp)] -- ispace = pair of (gtid, size) for the maps on "top" of this reduction@@ -87,15 +87,15 @@ SegOpLevel lore -> Pattern lore -> SubExp -- segment size- -> Lambda lore -> Lambda lore- -> [SubExp] -> [VName]+ -> [SegBinOp lore] -> Lambda lore+ -> [VName] -> [(VName, SubExp)] -- ispace = pair of (gtid, size) for the maps on "top" of this scan -> [KernelInput] -- inps = inputs that can be looked up by using the gtids from ispace -> m (Stms lore)-segScan lvl pat w scan_lam map_lam nes arrs ispace inps = runBinder_ $ do+segScan lvl pat w ops map_lam arrs ispace inps = runBinder_ $ do (kspace, kbody) <- prepareRedOrScan w map_lam arrs ispace inps letBind_ pat $ Op $ segOp $- SegScan lvl kspace scan_lam nes (lambdaReturnType map_lam) kbody+ SegScan lvl kspace ops (lambdaReturnType map_lam) kbody segMap :: (MonadFreshNames m, DistLore lore, HasScope lore m) => SegOpLevel lore@@ -136,7 +136,7 @@ SegOpLevel lore -> Pattern lore -> SubExp- -> [SegRedOp lore]+ -> [SegBinOp lore] -> Lambda lore -> [VName] -> m (Stms lore)
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -362,7 +362,8 @@ -- If the scan cannot be distributed by itself, it will be -- sequentialised in the default case for this function. maybeDistributeStm bnd@(Let pat (StmAux cs _) (Op (Screma w form arrs))) acc- | Just (lam, nes, map_lam) <- isScanomapSOAC form =+ | Just (scans, map_lam) <- isScanomapSOAC form,+ Scan lam nes <- singleScan scans = distributeSingleStm acc bnd >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res ->@@ -825,9 +826,10 @@ mk_lvl <- asks distSegLevel isSegmentedOp nest perm segment_size (freeIn lam) (freeIn map_lam) nes arrs $ \pat ispace inps nes' _ _ -> do+ let scan_op = SegBinOp Noncommutative lam nes' mempty lvl <- mk_lvl (segment_size : map snd ispace) "segscan" $ NoRecommendation SegNoVirt addStms =<< traverse renameStm =<<- segScan lvl pat segment_size lam map_lam nes' arrs ispace inps+ segScan lvl pat segment_size [scan_op] map_lam arrs ispace inps regularSegmentedRedomapKernel :: (MonadFreshNames m, DistLore lore) => KernelNest@@ -840,7 +842,7 @@ mk_lvl <- asks distSegLevel isSegmentedOp nest perm segment_size (freeIn lam) (freeIn map_lam) nes arrs $ \pat ispace inps nes' _ _ -> do- let red_op = SegRedOp comm lam nes' mempty+ let red_op = SegBinOp comm lam nes' mempty lvl <- mk_lvl (segment_size : map snd ispace) "segred" $ NoRecommendation SegNoVirt addStms =<< traverse renameStm =<< segRed lvl pat segment_size [red_op] map_lam arrs ispace inps@@ -906,7 +908,7 @@ -- segment_size*nesting_size. total_num_elements <- letSubExp "total_num_elements" =<<- foldBinOp (Mul Int32) segment_size (map snd ispace)+ foldBinOp (Mul Int32 OverflowUndef) segment_size (map snd ispace) let flatten arr = do arr_shape <- arrayShape <$> lookupType arr
src/Futhark/Pass/ExtractKernels/ISRWIM.hs view
@@ -43,7 +43,7 @@ uncurry zip $ splitAt (length arrs') $ map paramName map_params (nes', scan_arrs) = unzip scan_input' - scan_soac <- scanSOAC scan_fun' nes'+ scan_soac <- scanSOAC [Scan scan_fun' nes'] let map_body = mkBody (oneStm $ Let (setPatternOuterDimTo w map_pat) (defAux ()) $ Op $ Screma w scan_soac scan_arrs) $ map Var $ patternNames map_pat@@ -54,7 +54,7 @@ patternValueIdents res_pat addStm $ Let res_pat' (StmAux map_cs ()) $ Op $ Screma map_w- (ScremaForm (nilFn, mempty) [] map_fun') map_arrs'+ (mapSOAC map_fun') map_arrs' forM_ (zip (patternValueIdents res_pat) (patternValueIdents res_pat')) $ \(to, from) -> do
src/Futhark/Pass/ExtractKernels/Intragroup.hs view
@@ -49,7 +49,7 @@ (num_groups, w_stms) <- lift $ runBinder $ letSubExp "intra_num_groups" =<<- foldBinOp (Mul Int32) (intConst Int32 1) (map snd ispace)+ foldBinOp (Mul Int32 OverflowUndef) (intConst Int32 1) (map snd ispace) let body = lambdaBody lam @@ -68,9 +68,9 @@ ((intra_avail_par, kspace, read_input_stms), prelude_stms) <- lift $ runBinder $ do let foldBinOp' _ [] = eSubExp $ intConst Int32 0 foldBinOp' bop (x:xs) = foldBinOp bop x xs- ws_min <- mapM (letSubExp "one_intra_par_min" <=< foldBinOp' (Mul Int32)) $+ ws_min <- mapM (letSubExp "one_intra_par_min" <=< foldBinOp' (Mul Int32 OverflowUndef)) $ filter (not . null) wss_min- ws_avail <- mapM (letSubExp "one_intra_par_avail" <=< foldBinOp' (Mul Int32)) $+ ws_avail <- mapM (letSubExp "one_intra_par_avail" <=< foldBinOp' (Mul Int32 OverflowUndef)) $ filter (not . null) wss_avail -- The amount of parallelism available *in the worst case* is@@ -194,11 +194,12 @@ runDistNestT env (distributeMapBodyStms acc (bodyStms $ lambdaBody lam)) Op (Screma w form arrs)- | Just (scanfun, nes, mapfun) <- isScanomapSOAC form -> do+ | Just (scans, mapfun) <- isScanomapSOAC form,+ Scan scanfun nes <- singleScan scans -> do let scanfun' = soacsLambdaToKernels scanfun mapfun' = soacsLambdaToKernels mapfun certifying (stmAuxCerts aux) $- addStms =<< segScan lvl' pat w scanfun' mapfun' nes arrs [] []+ addStms =<< segScan lvl' pat w [SegBinOp Noncommutative scanfun' nes mempty] mapfun' arrs [] [] parallelMin [w] Op (Screma w form arrs)@@ -207,7 +208,7 @@ let red_lam' = soacsLambdaToKernels red_lam map_lam' = soacsLambdaToKernels map_lam certifying (stmAuxCerts aux) $- addStms =<< segRed lvl' pat w [SegRedOp comm red_lam' nes mempty] map_lam' arrs [] []+ addStms =<< segRed lvl' pat w [SegBinOp comm red_lam' nes mempty] map_lam' arrs [] [] parallelMin [w]
src/Futhark/Pass/ExtractKernels/StreamKernel.hs view
@@ -37,7 +37,7 @@ max_num_groups_key <- nameFromString . pretty <$> newVName (desc ++ "_num_groups") num_groups <- letSubExp "num_groups" $ Op $ SizeOp $ CalcNumGroups w64 max_num_groups_key group_size- num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32) num_groups group_size+ num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) num_groups group_size return (num_groups, num_threads) blockedKernelSize :: (MonadBinder m, Lore m ~ Kernels) =>@@ -62,7 +62,7 @@ letBindNames_ [chunk_size] $ Op $ SizeOp $ SplitSpace ordering w i elems_per_i case ordering of SplitContiguous -> do- offset <- letSubExp "slice_offset" $ BasicOp $ BinOp (Mul Int32) i elems_per_i+ offset <- letSubExp "slice_offset" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) i elems_per_i zipWithM_ (contiguousSlice offset) split_bound arrs SplitStrided stride -> zipWithM_ (stridedSlice stride) split_bound arrs where contiguousSlice offset slice_name arr = do@@ -195,7 +195,7 @@ lvl <- mk_lvl [w] "stream_red" $ NoRecommendation SegNoVirt letBind_ pat' $ Op $ SegOp $ SegRed lvl kspace- [SegRedOp comm red_lam nes mempty] ts kbody+ [SegBinOp comm red_lam nes mempty] ts kbody read_dummy @@ -227,7 +227,7 @@ segThreadCapped :: MonadFreshNames m => MkSegLevel Kernels m segThreadCapped ws desc r = do w64 <- letSubExp "nest_size" =<<- foldBinOp (Mul Int64) (intConst Int64 1) =<<+ foldBinOp (Mul Int64 OverflowUndef) (intConst Int64 1) =<< mapM (asIntS Int64) ws group_size <- getSize (desc ++ "_group_size") SizeGroup
src/Futhark/Pass/KernelBabysitting.hs view
@@ -94,7 +94,7 @@ let thread_gids = map fst $ unSegSpace space thread_local = namesFromList $ segFlat space : thread_gids free_ker_vars = freeIn kbody `namesSubtract` getKerVariantIds space- num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32)+ num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) (unCount $ segNumGroups lvl) (unCount $ segGroupSize lvl) evalStateT (traverseKernelBodyArrayIndexes free_ker_vars@@ -426,7 +426,7 @@ paddedScanReduceInput w stride = do w_padded <- letSubExp "padded_size" =<< eRoundToMultipleOf Int32 (eSubExp w) (eSubExp stride)- padding <- letSubExp "padding" $ BasicOp $ BinOp (Sub Int32) w_padded w+ padding <- letSubExp "padding" $ BasicOp $ BinOp (Sub Int32 OverflowUndef) w_padded w return (w_padded, padding) --- Computing variance.
src/Futhark/Pass/Simplify.hs view
@@ -9,11 +9,9 @@ ) where -import qualified Futhark.Representation.SOACS as R-import qualified Futhark.Representation.SOACS.Simplify as R-import qualified Futhark.Representation.Kernels as R-import qualified Futhark.Representation.Kernels.Simplify as R-import qualified Futhark.Representation.Seq as R+import qualified Futhark.Representation.SOACS.Simplify as SOACS+import qualified Futhark.Representation.Kernels.Simplify as Kernels+import qualified Futhark.Representation.Seq as Seq import qualified Futhark.Representation.KernelsMem as KernelsMem import qualified Futhark.Representation.SeqMem as SeqMem @@ -24,14 +22,14 @@ -> Pass lore lore simplify = Pass "simplify" "Perform simple enabling optimisations." -simplifySOACS :: Pass R.SOACS R.SOACS-simplifySOACS = simplify R.simplifySOACS+simplifySOACS :: Pass SOACS.SOACS SOACS.SOACS+simplifySOACS = simplify SOACS.simplifySOACS -simplifyKernels :: Pass R.Kernels R.Kernels-simplifyKernels = simplify R.simplifyKernels+simplifyKernels :: Pass Kernels.Kernels Kernels.Kernels+simplifyKernels = simplify Kernels.simplifyKernels -simplifySeq :: Pass R.Seq R.Seq-simplifySeq = simplify R.simplifyProg+simplifySeq :: Pass Seq.Seq Seq.Seq+simplifySeq = simplify Seq.simplifyProg simplifyKernelsMem :: Pass KernelsMem.KernelsMem KernelsMem.KernelsMem simplifyKernelsMem = simplify KernelsMem.simplifyProg
src/Futhark/Pkg/Info.hs view
@@ -72,7 +72,7 @@ data PkgRevInfo m = PkgRevInfo { pkgRevZipballUrl :: T.Text , pkgRevZipballDir :: FilePath -- ^ The directory inside the zipball- -- containing the 'lib' directory, in+ -- containing the @lib@ directory, in -- which the package files themselves -- are stored (Based on the package -- path).@@ -102,9 +102,12 @@ liftIO $ writeIORef ref $ Just v' return v' +-- | Download the zip archive corresponding to a specific package+-- version. downloadZipball :: (MonadLogger m, MonadIO m, MonadFail m) =>- T.Text -> m Zip.Archive-downloadZipball url = do+ 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 <> ": ")<>)@@ -124,6 +127,7 @@ -- commit, or HEAD in case of Nothing. } +-- | Lookup information about a given version of a package. lookupPkgRev :: SemVer -> PkgInfo m -> Maybe (PkgRevInfo m) lookupPkgRev v = M.lookup v . pkgVersions
src/Futhark/Pkg/Types.hs view
@@ -66,7 +66,7 @@ -- | Versions of the form (0,0,0)-timestamp+hash are treated -- specially, as a reference to the commit identified uniquely with--- 'hash' (typically the Git commit ID). This function detects such+-- @hash@ (typically the Git commit ID). This function detects such -- versions. isCommitVersion :: SemVer -> Maybe T.Text isCommitVersion (SemVer 0 0 0 [_] [[Str s]]) = Just s@@ -271,9 +271,11 @@ blankLine = some spaceChar >> pure Nothing +-- | Parse a text as a 'PkgManifest'. The 'FilePath' is used for any error messages. parsePkgManifest :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text Void) PkgManifest parsePkgManifest = parse pPkgManifest +-- | Read contents of file and pass it to 'parsePkgManifest'. parsePkgManifestFromFile :: FilePath -> IO PkgManifest parsePkgManifestFromFile f = do s <- T.readFile f
src/Futhark/Representation/AST/Attributes/Ranges.hs view
@@ -176,11 +176,11 @@ primOpRanges (SubExp se) = [rangeOf se] -primOpRanges (BinOp (Add t) x y) =+primOpRanges (BinOp (Add t _) x y) = [scalExpRange $ SE.SPlus (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)]-primOpRanges (BinOp (Sub t) x y) =+primOpRanges (BinOp (Sub t _) x y) = [scalExpRange $ SE.SMinus (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)]-primOpRanges (BinOp (Mul t) x y) =+primOpRanges (BinOp (Mul t _) x y) = [scalExpRange $ SE.STimes (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] primOpRanges (BinOp (SDiv t) x y) = [scalExpRange $ SE.SDiv (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)]
src/Futhark/Representation/AST/Attributes/Rearrange.hs view
@@ -1,3 +1,5 @@+-- | A rearrangement is a generalisation of transposition, where the+-- dimensions are arbitrarily permuted. module Futhark.Representation.AST.Attributes.Rearrange ( rearrangeShape , rearrangeInverse
src/Futhark/Representation/Kernels/Kernel.hs view
@@ -60,6 +60,7 @@ text "groupsize=" <> ppr (segGroupSize lvl) <> case segVirt lvl of SegNoVirt -> mempty+ SegNoVirtFull -> PP.semi <+> text "full" SegVirt -> PP.semi <+> text "virtualise") where lvl' = case lvl of SegThread{} -> "_thread"
src/Futhark/Representation/Kernels/Simplify.hs view
@@ -8,6 +8,8 @@ ( simplifyKernels , simplifyLambda + , Kernels+ -- * Building blocks , simplifyKernelOp )
src/Futhark/Representation/Mem/Simplify.hs view
@@ -19,8 +19,8 @@ hiding (Prog, BasicOp, Exp, Body, Stm, Pattern, PatElem, Lambda, FunDef, FParam, LParam, RetType) import Futhark.Representation.Mem-import Futhark.Pass.ExplicitAllocations- (simplifiable, arraySizeInBytesExp)+import qualified Futhark.Representation.Mem.IxFun as IxFun+import Futhark.Pass.ExplicitAllocations (simplifiable) import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Analysis.UsageTable as UT import qualified Futhark.Optimise.Simplify.Engine as Engine@@ -120,9 +120,8 @@ -- Create non-existential memory blocks big enough to hold the -- arrays. (arr_to_mem, oldmem_to_mem) <-- fmap unzip $ forM fixable $ \(arr_pe, oldmem, space) -> do- size <- letSubExp "size" =<<- toExp (arraySizeInBytesExp $ patElemType arr_pe)+ fmap unzip $ forM fixable $ \(arr_pe, mem_size, oldmem, space) -> do+ size <- letSubExp "size" =<< toExp mem_size mem <- letExp "mem" $ Op $ allocOp size space return ((patElemName arr_pe, mem), (oldmem, mem)) @@ -155,7 +154,7 @@ inContext = (`elem` patternContextNames pat) hasConcretisableMemory fixable pat_elem- | (_, MemArray _ shape _ (ArrayIn mem _)) <- patElemAttr pat_elem,+ | (_, MemArray pt shape _ (ArrayIn mem ixfun)) <- patElemAttr pat_elem, Just (j, Mem space) <- fmap patElemType <$> find ((mem==) . patElemName . snd) (zip [(0::Int)..] $ patternElements pat),@@ -164,7 +163,10 @@ mem `onlyUsedIn` patElemName pat_elem, all knownSize (shapeDims shape), fse /= tse =- (pat_elem, mem, space) : fixable+ let mem_size =+ ConvOpExp (SExt Int32 Int64) $+ product $ primByteSize pt : IxFun.base ixfun+ in (pat_elem, mem_size, mem, space) : fixable | otherwise = fixable unExistentialiseMemory _ _ _ _ = Skip
src/Futhark/Representation/Primitive.hs view
@@ -22,6 +22,7 @@ , blankPrimValue -- * Operations+ , Overflow (..) , UnOp (..), allUnOps , BinOp (..), allBinOps , ConvOp (..), allConvOps@@ -189,6 +190,7 @@ intValue Int32 = Int32Value . fromIntegral intValue Int64 = Int64Value . fromIntegral +-- | The type of an integer value. intValueType :: IntValue -> IntType intValueType Int8Value{} = Int8 intValueType Int16Value{} = Int16@@ -225,6 +227,7 @@ floatValue Float32 = Float32Value . fromRational . toRational floatValue Float64 = Float64Value . fromRational . toRational +-- | The type of a floating-point value. floatValueType :: FloatValue -> FloatType floatValueType Float32Value{} = Float32 floatValueType Float64Value{} = Float64@@ -274,16 +277,33 @@ | USignum IntType -- ^ Unsigned sign function: @usignum(2)@ = 1. deriving (Eq, Ord, Show) +-- | What to do in case of arithmetic overflow. Futhark's semantics+-- are that overflow does wraparound, but for generated code (like+-- address arithmetic), it can be beneficial for overflow to be+-- undefined behaviour, as it allows better optimisation of things+-- such as GPU kernels.+--+-- Note that all values of this type are considered equal for 'Eq' and+-- 'Ord'.+data Overflow = OverflowWrap | OverflowUndef+ deriving (Show)++instance Eq Overflow where+ _ == _ = True++instance Ord Overflow where+ _ `compare` _ = EQ+ -- | Binary operators. These correspond closely to the binary operators in -- LLVM. Most are parametrised by their expected input and output -- types.-data BinOp = Add IntType -- ^ Integer addition.+data BinOp = Add IntType Overflow -- ^ Integer addition. | FAdd FloatType -- ^ Floating-point addition. - | Sub IntType -- ^ Integer subtraction.+ | Sub IntType Overflow -- ^ Integer subtraction. | FSub FloatType -- ^ Floating-point subtraction. - | Mul IntType -- ^ Integer multiplication.+ | Mul IntType Overflow -- ^ Integer multiplication. | FMul FloatType -- ^ Floating-point multiplication. | UDiv IntType@@ -398,11 +418,11 @@ -- | A list of all binary operators for all types. allBinOps :: [BinOp]-allBinOps = concat [ map Add allIntTypes+allBinOps = concat [ map (`Add` OverflowWrap) allIntTypes , map FAdd allFloatTypes- , map Sub allIntTypes+ , map (`Sub` OverflowWrap) allIntTypes , map FSub allFloatTypes- , map Mul allIntTypes+ , map (`Mul` OverflowWrap) allIntTypes , map FMul allFloatTypes , map UDiv allIntTypes , map SDiv allIntTypes@@ -453,6 +473,8 @@ , BToI <$> allIntTypes ] +-- | Apply an 'UnOp' to an operand. Returns 'Nothing' if the+-- application is mistyped. doUnOp :: UnOp -> PrimValue -> Maybe PrimValue doUnOp Not (BoolValue b) = Just $ BoolValue $ not b doUnOp Complement{} (IntValue v) = Just $ IntValue $ doComplement v@@ -482,6 +504,9 @@ doUSignum :: IntValue -> IntValue doUSignum v = intValue (intValueType v) $ signum $ intToWord64 v +-- | Apply a 'BinOp' to an operand. Returns 'Nothing' if the+-- application is mistyped, or outside the domain (e.g. division by+-- zero). doBinOp :: BinOp -> PrimValue -> PrimValue -> Maybe PrimValue doBinOp Add{} = doIntBinOp doAdd doBinOp FAdd{} = doFloatBinOp (+) (+)@@ -642,6 +667,8 @@ | negativeIshInt v2 = Nothing | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 ^ intToInt64 v2 +-- | Apply a 'ConvOp' to an operand. Returns 'Nothing' if the+-- application is mistyped. doConvOp :: ConvOp -> PrimValue -> Maybe PrimValue doConvOp (ZExt _ to) (IntValue v) = Just $ IntValue $ doZExt v to doConvOp (SExt _ to) (IntValue v) = Just $ IntValue $ doSExt v to@@ -697,6 +724,8 @@ doSIToFP :: IntValue -> FloatType -> FloatValue doSIToFP v t = floatValue t $ intToInt64 v +-- | Apply a 'CmpOp' to an operand. Returns 'Nothing' if the+-- application is mistyped. doCmpOp :: CmpOp -> PrimValue -> PrimValue -> Maybe Bool doCmpOp CmpEq{} v1 v2 = Just $ doCmpEq v1 v2 doCmpOp CmpUlt{} (IntValue v1) (IntValue v2) = Just $ doCmpUlt v1 v2@@ -761,9 +790,9 @@ -- | The result type of a binary operator. binOpType :: BinOp -> PrimType-binOpType (Add t) = IntType t-binOpType (Sub t) = IntType t-binOpType (Mul t) = IntType t+binOpType (Add t _) = IntType t+binOpType (Sub t _) = IntType t+binOpType (Mul t _) = IntType t binOpType (SDiv t) = IntType t binOpType (SMod t) = IntType t binOpType (SQuot t) = IntType t@@ -1123,11 +1152,14 @@ -- Prettyprinting instances instance Pretty BinOp where- ppr (Add t) = taggedI "add" t+ ppr (Add t OverflowWrap) = taggedI "add" t+ ppr (Add t OverflowUndef) = taggedI "add_nw" t+ ppr (Sub t OverflowWrap) = taggedI "sub" t+ ppr (Sub t OverflowUndef) = taggedI "sub_nw" t+ ppr (Mul t OverflowWrap) = taggedI "mul" t+ ppr (Mul t OverflowUndef) = taggedI "mul_nw" t ppr (FAdd t) = taggedF "fadd" t- ppr (Sub t) = taggedI "sub" t ppr (FSub t) = taggedF "fsub" t- ppr (Mul t) = taggedI "mul" t ppr (FMul t) = taggedF "fmul" t ppr (UDiv t) = taggedI "udiv" t ppr (UMod t) = taggedI "umod" t@@ -1177,6 +1209,8 @@ ppr (USignum t) = taggedI "usignum" t ppr (Complement t) = taggedI "complement" t +-- | The human-readable name for a 'ConvOp'. This is used to expose+-- the 'ConvOp' in the @intrinsics@ module of a Futhark program. convOpFun :: ConvOp -> String convOpFun ZExt{} = "zext" convOpFun SExt{} = "sext"@@ -1185,8 +1219,8 @@ convOpFun FPToSI{} = "fptosi" convOpFun UIToFP{} = "uitofp" convOpFun SIToFP{} = "sitofp"-convOpFun IToB{} = "itob"-convOpFun BToI{} = "btoi"+convOpFun IToB{} = "itob"+convOpFun BToI{} = "btoi" taggedI :: String -> IntType -> Doc taggedI s Int8 = text $ s ++ "8"
src/Futhark/Representation/SOACS/SOAC.hs view
@@ -9,7 +9,9 @@ , StreamForm(..) , ScremaForm(..) , HistOp(..)- , Scan+ , Scan(..)+ , scanResults+ , singleScan , Reduce(..) , redResults , singleReduce@@ -122,12 +124,37 @@ -- | The essential parts of a 'Screma' factored out (everything -- except the input arrays). data ScremaForm lore = ScremaForm- (Scan lore)+ [Scan lore] [Reduce lore] (Lambda lore) deriving (Eq, Ord, Show) -type Scan lore = (Lambda lore, [SubExp])+singleBinOp :: Bindable lore => [Lambda lore] -> Lambda lore+singleBinOp lams =+ Lambda { lambdaParams = concatMap xParams lams ++ concatMap yParams lams+ , lambdaReturnType = concatMap lambdaReturnType lams+ , lambdaBody = mkBody (mconcat (map (bodyStms . lambdaBody) lams))+ (concatMap (bodyResult . lambdaBody) lams)+ }+ where xParams lam = take (length (lambdaReturnType lam)) (lambdaParams lam)+ yParams lam = drop (length (lambdaReturnType lam)) (lambdaParams lam)++data Scan lore = Scan { scanLambda :: Lambda lore+ , scanNeutral :: [SubExp]+ }+ deriving (Eq, Ord, Show)++-- | How many reduction results are produced by these 'Scan's?+scanResults :: [Scan lore] -> Int+scanResults = sum . map (length . scanNeutral)++-- | Combine multiple scan operators to a single operator.+singleScan :: Bindable lore => [Scan lore] -> Scan lore+singleScan scans =+ let scan_nes = concatMap scanNeutral scans+ scan_lam = singleBinOp $ map scanLambda scans+ in Scan scan_lam scan_nes+ data Reduce lore = Reduce { redComm :: Commutativity , redLambda :: Lambda lore , redNeutral :: [SubExp]@@ -142,20 +169,14 @@ singleReduce :: Bindable lore => [Reduce lore] -> Reduce lore singleReduce reds = let red_nes = concatMap redNeutral reds- red_lam =- let xParams red = take (length (redNeutral red)) (lambdaParams (redLambda red))- yParams red = drop (length (redNeutral red)) (lambdaParams (redLambda red))- in Lambda { lambdaParams = concatMap xParams reds ++ concatMap yParams reds- , lambdaReturnType = concatMap (lambdaReturnType . redLambda) reds- , lambdaBody = mkBody (mconcat (map (bodyStms . lambdaBody . redLambda) reds))- (concatMap (bodyResult . lambdaBody . redLambda) reds)- }+ red_lam = singleBinOp $ map redLambda reds in Reduce (mconcat (map redComm reds)) red_lam red_nes scremaType :: SubExp -> ScremaForm lore -> [Type]-scremaType w (ScremaForm (scan_lam, _scan_nes) reds map_lam) =- map (`arrayOfRow` w) scan_tps ++ red_tps ++ map (`arrayOfRow` w) map_tps- where scan_tps = lambdaReturnType scan_lam+scremaType w (ScremaForm scans reds map_lam) =+ scan_tps ++ red_tps ++ map (`arrayOfRow` w) map_tps+ where scan_tps = map (`arrayOfRow` w) $+ concatMap (lambdaReturnType . scanLambda) scans red_tps = concatMap (lambdaReturnType . redLambda) reds map_tps = drop (length scan_tps + length red_tps) $ lambdaReturnType map_lam @@ -178,44 +199,39 @@ nilFn :: Bindable lore => Lambda lore nilFn = Lambda mempty (mkBody mempty mempty) mempty -isNilFn :: Lambda lore -> Bool-isNilFn (Lambda ps body ts) =- null ps && null ts &&- null (bodyStms body) && null (bodyResult body)--scanomapSOAC :: Lambda lore -> [SubExp] -> Lambda lore -> ScremaForm lore-scanomapSOAC lam nes = ScremaForm (lam, nes) []+scanomapSOAC :: [Scan lore] -> Lambda lore -> ScremaForm lore+scanomapSOAC scans = ScremaForm scans [] -redomapSOAC :: Bindable lore =>- [Reduce lore] -> Lambda lore -> ScremaForm lore-redomapSOAC = ScremaForm (nilFn, mempty)+redomapSOAC :: [Reduce lore] -> Lambda lore -> ScremaForm lore+redomapSOAC = ScremaForm [] scanSOAC :: (Bindable lore, MonadFreshNames m) =>- Lambda lore -> [SubExp] -> m (ScremaForm lore)-scanSOAC lam nes = scanomapSOAC lam nes <$> mkIdentityLambda (lambdaReturnType lam)+ [Scan lore] -> m (ScremaForm lore)+scanSOAC scans = scanomapSOAC scans <$> mkIdentityLambda ts+ where ts = concatMap (lambdaReturnType . scanLambda) scans reduceSOAC :: (Bindable lore, MonadFreshNames m) => [Reduce lore] -> m (ScremaForm lore) reduceSOAC reds = redomapSOAC reds <$> mkIdentityLambda ts where ts = concatMap (lambdaReturnType . redLambda) reds -mapSOAC :: Bindable lore => Lambda lore -> ScremaForm lore-mapSOAC = ScremaForm (nilFn, mempty) []+mapSOAC :: Lambda lore -> ScremaForm lore+mapSOAC = ScremaForm [] [] -isScanomapSOAC :: ScremaForm lore -> Maybe (Lambda lore, [SubExp], Lambda lore)-isScanomapSOAC (ScremaForm (scan_lam, scan_nes) reds map_lam) = do+isScanomapSOAC :: ScremaForm lore -> Maybe ([Scan lore], Lambda lore)+isScanomapSOAC (ScremaForm scans reds map_lam) = do guard $ null reds- guard $ not $ null scan_nes- return (scan_lam, scan_nes, map_lam)+ guard $ not $ null scans+ return (scans, map_lam) -isScanSOAC :: ScremaForm lore -> Maybe (Lambda lore, [SubExp])-isScanSOAC form = do (scan_lam, scan_nes, map_lam) <- isScanomapSOAC form+isScanSOAC :: ScremaForm lore -> Maybe [Scan lore]+isScanSOAC form = do (scans, map_lam) <- isScanomapSOAC form guard $ isIdentityLambda map_lam- return (scan_lam, scan_nes)+ return scans isRedomapSOAC :: ScremaForm lore -> Maybe ([Reduce lore], Lambda lore)-isRedomapSOAC (ScremaForm (_, scan_nes) reds map_lam) = do- guard $ null scan_nes+isRedomapSOAC (ScremaForm scans reds map_lam) = do+ guard $ null scans guard $ not $ null reds return (reds, map_lam) @@ -225,8 +241,8 @@ return reds isMapSOAC :: ScremaForm lore -> Maybe (Lambda lore)-isMapSOAC (ScremaForm (_, scan_nes) reds map_lam) = do- guard $ null scan_nes+isMapSOAC (ScremaForm scans reds map_lam) = do+ guard $ null scans guard $ null reds return map_lam @@ -277,13 +293,15 @@ <*> mapOnSOACLambda tv op) ops <*> mapOnSOACLambda tv bucket_fun <*> mapM (mapOnSOACVName tv) imgs-mapSOACM tv (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) =+mapSOACM tv (Screma w (ScremaForm scans reds map_lam) arrs) = Screma <$> mapOnSOACSubExp tv w <*> (ScremaForm <$>- ((,) <$> mapOnSOACLambda tv scan_lam <*> mapM (mapOnSOACSubExp tv) scan_nes) <*>+ forM scans (\(Scan red_lam red_nes) ->+ Scan <$> mapOnSOACLambda tv red_lam <*>+ mapM (mapOnSOACSubExp tv) red_nes) <*> forM reds (\(Reduce comm red_lam red_nes) ->- Reduce comm <$> mapOnSOACLambda tv red_lam <*>- mapM (mapOnSOACSubExp tv) red_nes) <*>+ Reduce comm <$> mapOnSOACLambda tv red_lam <*>+ mapM (mapOnSOACSubExp tv) red_nes) <*> mapOnSOACLambda tv map_lam) <*> mapM (mapOnSOACVName tv) arrs @@ -377,13 +395,14 @@ addOpAliases (Hist len ops bucket_fun imgs) = Hist len (map (mapHistOp Alias.analyseLambda) ops) (Alias.analyseLambda bucket_fun) imgs- addOpAliases (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) =+ addOpAliases (Screma w (ScremaForm scans reds map_lam) arrs) = Screma w (ScremaForm- (Alias.analyseLambda scan_lam, scan_nes)+ (map onScan scans) (map onRed reds) (Alias.analyseLambda map_lam)) arrs where onRed red = red { redLambda = Alias.analyseLambda $ redLambda red }+ onScan scan = scan { scanLambda = Alias.analyseLambda $ scanLambda scan } removeOpAliases = runIdentity . mapSOACM remove where remove = SOACMapper return (return . removeLambdaAliases) return@@ -427,14 +446,16 @@ addOpRanges (Hist len ops bucket_fun imgs) = Hist len (map (mapHistOp $ Range.runRangeM . Range.analyseLambda) ops) (Range.runRangeM $ Range.analyseLambda bucket_fun) imgs- addOpRanges (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) =+ addOpRanges (Screma w (ScremaForm scans reds map_lam) arrs) = Screma w (ScremaForm- (Range.runRangeM $ Range.analyseLambda scan_lam, scan_nes)+ (map onScan scans) (map onRed reds) (Range.runRangeM $ Range.analyseLambda map_lam)) arrs- where onRed red = red { redLambda = Range.runRangeM $ Range.analyseLambda $- redLambda red }+ where onRed red =+ red { redLambda = Range.runRangeM $ Range.analyseLambda $ redLambda red }+ onScan red =+ red { scanLambda = Range.runRangeM $ Range.analyseLambda $ scanLambda red } instance (Attributes lore, CanBeWise (Op lore)) => CanBeWise (SOAC lore) where type OpWithWisdom (SOAC lore) = SOAC (Wise lore)@@ -450,8 +471,8 @@ case se of Var v -> uncurry (flip ST.Indexed) <$> M.lookup v arr_indexes' _ -> Nothing- where lambdaAndSubExp (Screma _ (ScremaForm (_, scan_nes) reds map_lam) arrs) =- nthMapOut (length scan_nes + redResults reds) map_lam arrs+ where lambdaAndSubExp (Screma _ (ScremaForm scans reds map_lam) arrs) =+ nthMapOut (scanResults scans + redResults reds) map_lam arrs lambdaAndSubExp _ = Nothing @@ -599,13 +620,21 @@ prettyTuple (lambdaReturnType bucket_fun) ++ " but should have type " ++ prettyTuple bucket_ret_t -typeCheckSOAC (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) = do+typeCheckSOAC (Screma w (ScremaForm scans reds map_lam) arrs) = do TC.require [Prim int32] w arrs' <- TC.checkSOACArrayArgs w arrs- scan_nes' <- mapM TC.checkArg scan_nes TC.checkLambda map_lam $ map TC.noArgAliases arrs'- TC.checkLambda scan_lam $ map TC.noArgAliases $ scan_nes' ++ scan_nes' + scan_nes' <- fmap concat $ forM scans $ \(Scan scan_lam scan_nes) -> do+ scan_nes' <- mapM TC.checkArg scan_nes+ let scan_t = map TC.argType scan_nes'+ TC.checkLambda scan_lam $ map TC.noArgAliases $ scan_nes' ++ scan_nes'+ unless (scan_t == lambdaReturnType scan_lam) $+ TC.bad $ TC.TypeError $ "Scan function returns type " +++ prettyTuple (lambdaReturnType scan_lam) ++ " but neutral element has type " +++ prettyTuple scan_t+ return scan_nes'+ red_nes' <- fmap concat $ forM reds $ \(Reduce _ red_lam red_nes) -> do red_nes' <- mapM TC.checkArg red_nes let red_t = map TC.argType red_nes'@@ -616,15 +645,9 @@ prettyTuple red_t return red_nes' - let scan_t = map TC.argType scan_nes'- map_lam_ts = lambdaReturnType map_lam-- unless (scan_t == lambdaReturnType scan_lam) $- TC.bad $ TC.TypeError $ "Scan function returns type " ++- prettyTuple (lambdaReturnType scan_lam) ++ " but neutral element has type " ++- prettyTuple scan_t+ let map_lam_ts = lambdaReturnType map_lam - unless (take (length scan_nes + length red_nes') map_lam_ts ==+ unless (take (length scan_nes' + length red_nes') map_lam_ts == map TC.argType (scan_nes'++ red_nes')) $ TC.bad $ TC.TypeError $ "Map function return type " ++ prettyTuple map_lam_ts ++ " wrong for given scan and reduction functions."@@ -645,8 +668,8 @@ inside "Scatter" $ lambdaMetrics lam opMetrics (Hist _len ops bucket_fun _imgs) = inside "Hist" $ mapM_ (lambdaMetrics . histOp) ops >> lambdaMetrics bucket_fun- opMetrics (Screma _ (ScremaForm (scan_lam, _) reds map_lam) _) =- inside "Screma" $ do lambdaMetrics scan_lam+ opMetrics (Screma _ (ScremaForm scans reds map_lam) _) =+ inside "Screma" $ do mapM_ (lambdaMetrics . scanLambda) scans mapM_ (lambdaMetrics . redLambda) reds lambdaMetrics map_lam @@ -668,14 +691,14 @@ ppSOAC "scatter" len [lam] (Just (map Var ivs)) (map (\(_,n,a) -> (n,a)) as) ppr (Hist len ops bucket_fun imgs) = ppHist len ops bucket_fun imgs- ppr (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs)- | isNilFn scan_lam, null scan_nes, null reds =+ ppr (Screma w (ScremaForm scans reds map_lam) arrs)+ | null scans, null reds = text "map" <> parens (ppr w <> comma </> ppr map_lam <> comma </> commasep (map ppr arrs)) - | isNilFn scan_lam, null scan_nes =+ | null scans = text "redomap" <> parens (ppr w <> comma </> PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr reds) <> comma </>@@ -685,23 +708,25 @@ | null reds = text "scanomap" <> parens (ppr w <> comma </>- ppr scan_lam <> comma </>- commasep (map ppr scan_nes) <> comma </>+ PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr scans) <> comma </> ppr map_lam <> comma </> commasep (map ppr arrs)) ppr (Screma w form arrs) = ppScrema w form arrs ppScrema :: (PrettyLore lore, Pretty inp) =>- SubExp -> ScremaForm lore -> [inp] -> Doc-ppScrema w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs =+ SubExp -> ScremaForm lore -> [inp] -> Doc+ppScrema w (ScremaForm scans reds map_lam) arrs = text "screma" <> parens (ppr w <> comma </>- ppr scan_lam <> comma </>- PP.braces (commasep $ map ppr scan_nes) </>+ PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr scans) <> comma </> PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr reds) <> comma </> ppr map_lam <> comma </> commasep (map ppr arrs))++instance PrettyLore lore => Pretty (Scan lore) where+ ppr (Scan scan_lam scan_nes) =+ ppr scan_lam <> comma </> PP.braces (commasep $ map ppr scan_nes) ppComm :: Commutativity -> Doc ppComm Noncommutative = mempty
src/Futhark/Representation/SOACS/Simplify.hs view
@@ -15,6 +15,8 @@ , simplifySOAC , soacRules++ , SOACS ) where @@ -122,19 +124,23 @@ (bfun', bfun_hoisted) <- Engine.simplifyLambda bfun $ map Just imgs return (Hist w' ops' bfun' imgs', mconcat hoisted <> bfun_hoisted) -simplifySOAC (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) = do- (scan_lam', scan_lam_hoisted) <-- Engine.simplifyLambda scan_lam $ replicate (length scan_nes) Nothing+simplifySOAC (Screma w (ScremaForm scans reds map_lam) arrs) = do+ (scans', scans_hoisted) <- fmap unzip $ forM scans $ \(Scan lam nes) -> do+ (lam', hoisted) <- Engine.simplifyLambda lam $ replicate (length nes) Nothing+ nes' <- Engine.simplify nes+ return (Scan lam' nes', hoisted)+ (reds', reds_hoisted) <- fmap unzip $ forM reds $ \(Reduce comm lam nes) -> do (lam', hoisted) <- Engine.simplifyLambda lam $ replicate (length nes) Nothing nes' <- Engine.simplify nes return (Reduce comm lam' nes', hoisted)+ (map_lam', map_lam_hoisted) <- Engine.simplifyLambda map_lam $ map Just arrs+ (,) <$> (Screma <$> Engine.simplify w <*>- (ScremaForm <$> ((,) scan_lam' <$> Engine.simplify scan_nes) <*>- pure reds' <*> pure map_lam') <*>+ (ScremaForm <$> pure scans' <*> pure reds' <*> pure map_lam') <*> Engine.simplify arrs) <*>- pure (scan_lam_hoisted <> mconcat reds_hoisted <> map_lam_hoisted)+ pure (mconcat scans_hoisted <> mconcat reds_hoisted <> map_lam_hoisted) instance BinderOps (Wise SOACS) where mkExpAttrB = bindableMkExpAttrB@@ -545,7 +551,7 @@ -- For now we just remove singleton SOACs. simplifyKnownIterationSOAC :: TopDownRuleOp (Wise SOACS) simplifyKnownIterationSOAC _ pat _ (Screma (Constant k)- (ScremaForm (scan_lam, scan_nes) reds map_lam)+ (ScremaForm scans reds map_lam) arrs) | oneIsh k = Simplify $ do zipWithM_ bindMapParam (lambdaParams map_lam) arrs@@ -559,6 +565,7 @@ zipWithM_ bindArrayResult map_pes map_res where (Reduce _ red_lam red_nes) = singleReduce reds+ (Scan scan_lam scan_nes) = singleScan scans (scan_pes, red_pes, map_pes) = splitAt3 (length scan_nes) (length red_nes) $ patternElements pat bindMapParam p a = do@@ -570,6 +577,27 @@ BasicOp $ ArrayLit [se] $ rowType $ patElemType pe bindResult pe se = letBindNames_ [patElemName pe] $ BasicOp $ SubExp se++simplifyKnownIterationSOAC _ pat _ (Stream (Constant k) form fold_lam arrs)+ | oneIsh k = Simplify $ do+ let nes = getStreamAccums form+ (chunk_param, acc_params, slice_params) =+ partitionChunkedFoldParameters (length nes) (lambdaParams fold_lam)++ letBindNames_ [paramName chunk_param] $+ BasicOp $ SubExp $ intConst Int32 1++ forM_ (zip acc_params nes) $ \(p, ne) ->+ letBindNames_ [paramName p] $ BasicOp $ SubExp ne++ forM_ (zip slice_params arrs) $ \(p, arr) ->+ letBindNames_ [paramName p] $ BasicOp $ SubExp $ Var arr++ res <- bodyBind $ lambdaBody fold_lam++ forM_ (zip (patternNames pat) res) $ \(v, se) ->+ letBindNames_ [v] $ BasicOp $ SubExp se+ simplifyKnownIterationSOAC _ _ _ _ = Skip data ArrayOp = ArrayIndexing Certificates VName (Slice SubExp)
src/Futhark/Representation/SegOp.hs view
@@ -20,8 +20,9 @@ -- * Details , HistOp(..) , histType- , SegRedOp(..)- , segRedResults+ , SegBinOp(..)+ , segBinOpResults+ , segBinOpChunks , KernelBody(..) , aliasAnalyseKernelBody , consumedInKernelBody@@ -102,6 +103,7 @@ rename (SplitStrided stride) = SplitStrided <$> rename stride +-- | An operator for 'SegHist'. data HistOp lore = HistOp { histWidth :: SubExp , histRaceFactor :: SubExp@@ -125,11 +127,12 @@ (`arrayOfShape` histShape op)) $ lambdaReturnType $ histOp op -data SegRedOp lore =- SegRedOp { segRedComm :: Commutativity- , segRedLambda :: Lambda lore- , segRedNeutral :: [SubExp]- , segRedShape :: Shape+-- | An operator for 'SegScan' and 'SegRed'.+data SegBinOp lore =+ SegBinOp { segBinOpComm :: Commutativity+ , segBinOpLambda :: Lambda lore+ , segBinOpNeutral :: [SubExp]+ , segBinOpShape :: Shape -- ^ In case this operator is semantically a vectorised -- operator (corresponding to a perfect map nest in the -- SOACS representation), these are the logical@@ -138,9 +141,15 @@ } deriving (Eq, Ord, Show) --- | How many reduction results are produced by these 'SegRedOp's?-segRedResults :: [SegRedOp lore] -> Int-segRedResults = sum . map (length . segRedNeutral)+-- | How many reduction results are produced by these 'SegBinOp's?+segBinOpResults :: [SegBinOp lore] -> Int+segBinOpResults = sum . map (length . segBinOpNeutral)++-- | Split some list into chunks equal to the number of values+-- returned by each 'SegBinOp'+segBinOpChunks :: [SegBinOp lore] -> [a] -> [[a]]+segBinOpChunks = chunks . map (length . segBinOpNeutral)+ -- | The body of a 'Kernel'. data KernelBody lore = KernelBody { kernelBodyLore :: BodyAttr lore , kernelBodyStms :: Stms lore@@ -167,6 +176,8 @@ -- kept in registers. deriving (Eq, Show, Ord) +-- | A 'KernelBody' does not return an ordinary 'Result'. Instead, it+-- returns a list of these. data KernelResult = Returns ResultManifest SubExp -- ^ Each "worker" in the kernel returns this. -- Whether this is a result-per-thread or a@@ -188,6 +199,7 @@ -- result to be written per physical thread. deriving (Eq, Show, Ord) +-- | Get the root 'SubExp' corresponding values for a 'KernelResult'. kernelResultSubExp :: KernelResult -> SubExp kernelResultSubExp (Returns _ se) = se kernelResultSubExp (WriteReturns _ arr _) = Var arr@@ -239,6 +251,7 @@ instance Rename KernelResult where rename = substituteRename +-- | Perform alias analysis on a 'KernelBody'. aliasAnalyseKernelBody :: (Attributes lore, CanBeAliased (Op lore)) => KernelBody lore@@ -355,8 +368,14 @@ -- overhead. This only really matters for fairly trivial but very -- wide @map@ kernels where each thread performs constant-time work on -- scalars.-data SegVirt = SegVirt | SegNoVirt- deriving (Eq, Ord, Show)+data SegVirt+ = SegVirt+ | SegNoVirt+ | SegNoVirtFull+ -- ^ Not only do we not need virtualisation, but we _guarantee_+ -- that all physical threads participate in the work. This can+ -- save some checks in code generation.+ deriving (Eq, Ord, Show) -- | Index space of a 'SegOp'. data SegSpace = SegSpace { segFlat :: VName@@ -368,9 +387,12 @@ deriving (Eq, Ord, Show) +-- | The sizes spanned by the indexes of the 'SegSpace'. segSpaceDims :: SegSpace -> [SubExp] segSpaceDims (SegSpace _ space) = map snd space +-- | A 'Scope' containing all the identifiers brought into scope by+-- this 'SegSpace'. scopeOfSegSpace :: SegSpace -> Scope lore scopeOfSegSpace (SegSpace phys space) = M.fromList $ zip (phys : map fst space) $ repeat $ IndexInfo Int32@@ -379,25 +401,37 @@ checkSegSpace (SegSpace _ dims) = mapM_ (TC.require [Prim int32] . snd) dims +-- | A 'SegOp' is semantically a perfectly nested stack of maps, on+-- top of some bottommost computation (scalar computation, reduction,+-- scan, or histogram). The 'SegSpace' encodes the original map+-- structure.+--+-- All 'SegOps' are parameterised by the representation of their body,+-- as well as a *level*. The *level* is a representation-specific bit+-- of information. For example, in GPU backends, it is used to+-- indicate whether the 'SegOp' is expected to run at the thread-level+-- or the group-level. data SegOp lvl lore = SegMap lvl SegSpace [Type] (KernelBody lore)- | SegRed lvl SegSpace [SegRedOp lore] [Type] (KernelBody lore)+ | SegRed lvl SegSpace [SegBinOp lore] [Type] (KernelBody lore) -- ^ The KernelSpace must always have at least two dimensions, -- implying that the result of a SegRed is always an array.- | SegScan lvl SegSpace (Lambda lore) [SubExp] [Type] (KernelBody lore)+ | SegScan lvl SegSpace [SegBinOp lore] [Type] (KernelBody lore) | SegHist lvl SegSpace [HistOp lore] [Type] (KernelBody lore) deriving (Eq, Ord, Show) +-- | The level of a 'SegOp'. segLevel :: SegOp lvl lore -> lvl segLevel (SegMap lvl _ _ _) = lvl segLevel (SegRed lvl _ _ _ _) = lvl-segLevel (SegScan lvl _ _ _ _ _) = lvl+segLevel (SegScan lvl _ _ _ _) = lvl segLevel (SegHist lvl _ _ _ _) = lvl +-- | The space of a 'SegOp'. segSpace :: SegOp lvl lore -> SegSpace segSpace (SegMap _ lvl _ _) = lvl segSpace (SegRed _ lvl _ _ _) = lvl-segSpace (SegScan _ lvl _ _ _ _) = lvl+segSpace (SegScan _ lvl _ _ _) = lvl segSpace (SegHist _ lvl _ _ _) = lvl segResultShape :: SegSpace -> Type -> KernelResult -> Type@@ -410,6 +444,7 @@ segResultShape _ t (TileReturns dims _) = t `arrayOfShape` Shape (map fst dims) +-- | The return type of a 'SegOp'. segOpType :: SegOp lvl lore -> [Type] segOpType (SegMap _ space ts kbody) = zipWith (segResultShape space) ts $ kernelBodyResult kbody@@ -421,14 +456,17 @@ segment_dims = init $ segSpaceDims space red_ts = do op <- reds- let shape = Shape segment_dims <> segRedShape op- map (`arrayOfShape` shape) (lambdaReturnType $ segRedLambda op)-segOpType (SegScan _ space _ nes ts kbody) =- map (`arrayOfShape` Shape dims) scan_ts +++ let shape = Shape segment_dims <> segBinOpShape op+ map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op)+segOpType (SegScan _ space scans ts kbody) =+ scan_ts ++ zipWith (segResultShape space) map_ts (drop (length scan_ts) $ kernelBodyResult kbody)- where dims = segSpaceDims space- (scan_ts, map_ts) = splitAt (length nes) ts+ where map_ts = drop (length scan_ts) ts+ scan_ts = do+ op <- scans+ let shape = Shape (segSpaceDims space) <> segBinOpShape op+ map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op) segOpType (SegHist _ space ops _ _) = do op <- ops let shape = Shape (segment_dims <> [histWidth op]) <> histShape op@@ -447,11 +485,12 @@ consumedInKernelBody kbody consumedInOp (SegRed _ _ _ _ kbody) = consumedInKernelBody kbody- consumedInOp (SegScan _ _ _ _ _ kbody) =+ consumedInOp (SegScan _ _ _ _ kbody) = consumedInKernelBody kbody consumedInOp (SegHist _ _ ops _ kbody) = namesFromList (concatMap histDest ops) <> consumedInKernelBody kbody +-- | Type check a 'SegOp', given a checker for its level. typeCheckSegOp :: TC.Checkable lore => (lvl -> TC.TypeM lore ()) -> SegOp lvl (Aliases lore) -> TC.TypeM lore ()@@ -463,13 +502,17 @@ checkLvl lvl checkScanRed space reds' ts body where reds' = zip3- (map segRedLambda reds)- (map segRedNeutral reds)- (map segRedShape reds)+ (map segBinOpLambda reds)+ (map segBinOpNeutral reds)+ (map segBinOpShape reds) -typeCheckSegOp checkLvl (SegScan lvl space scan_op nes ts body) = do+typeCheckSegOp checkLvl (SegScan lvl space scans ts body) = do checkLvl lvl- checkScanRed space [(scan_op, nes, mempty)] ts body+ checkScanRed space scans' ts body+ where scans' = zip3+ (map segBinOpLambda scans)+ (map segBinOpNeutral scans)+ (map segBinOpShape scans) typeCheckSegOp checkLvl (SegHist lvl space ops ts kbody) = do checkLvl lvl@@ -528,8 +571,7 @@ nes' <- mapM TC.checkArg nes -- Operator type must match the type of neutral elements.- let stripVecDims = stripArray $ shapeRank shape- TC.checkLambda lam $ map (TC.noArgAliases . first stripVecDims) $ nes' ++ nes'+ TC.checkLambda lam $ map TC.noArgAliases $ nes' ++ nes' let nes_t = map TC.argType nes' unless (lambdaReturnType lam == nes_t) $@@ -570,6 +612,15 @@ mapOnSegSpace tv (SegSpace phys dims) = SegSpace phys <$> traverse (traverse $ mapOnSegOpSubExp tv) dims +mapSegBinOp :: Monad m =>+ SegOpMapper lvl flore tlore m+ -> SegBinOp flore -> m (SegBinOp tlore)+mapSegBinOp tv (SegBinOp comm red_op nes shape) =+ SegBinOp comm+ <$> mapOnSegOpLambda tv red_op+ <*> mapM (mapOnSegOpSubExp tv) nes+ <*> (Shape <$> mapM (mapOnSegOpSubExp tv) (shapeDims shape))+ mapSegOpM :: (Applicative m, Monad m) => SegOpMapper lvl flore tlore m -> SegOp lvl flore -> m (SegOp lvl tlore)@@ -583,20 +634,14 @@ SegRed <$> mapOnSegOpLevel tv lvl <*> mapOnSegSpace tv space- <*> mapM onSegOp reds+ <*> mapM (mapSegBinOp tv) reds <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts <*> mapOnSegOpBody tv lam- where onSegOp (SegRedOp comm red_op nes shape) =- SegRedOp comm- <$> mapOnSegOpLambda tv red_op- <*> mapM (mapOnSegOpSubExp tv) nes- <*> (Shape <$> mapM (mapOnSegOpSubExp tv) (shapeDims shape))-mapSegOpM tv (SegScan lvl space scan_op nes ts body) =+mapSegOpM tv (SegScan lvl space scans ts body) = SegScan <$> mapOnSegOpLevel tv lvl <*> mapOnSegSpace tv space- <*> mapOnSegOpLambda tv scan_op- <*> mapM (mapOnSegOpSubExp tv) nes+ <*> mapM (mapSegBinOp tv) scans <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts <*> mapOnSegOpBody tv body mapSegOpM tv (SegHist lvl space ops ts body) =@@ -652,10 +697,11 @@ opMetrics (SegMap _ _ _ body) = inside "SegMap" $ kernelBodyMetrics body opMetrics (SegRed _ _ reds _ body) =- inside "SegRed" $ do mapM_ (lambdaMetrics . segRedLambda) reds+ inside "SegRed" $ do mapM_ (lambdaMetrics . segBinOpLambda) reds kernelBodyMetrics body- opMetrics (SegScan _ _ scan_op _ _ body) =- inside "SegScan" $ lambdaMetrics scan_op >> kernelBodyMetrics body+ opMetrics (SegScan _ _ scans _ body) =+ inside "SegScan" $ do mapM_ (lambdaMetrics . segBinOpLambda) scans+ kernelBodyMetrics body opMetrics (SegHist _ _ ops _ body) = inside "SegHist" $ do mapM_ (lambdaMetrics . histOp) ops kernelBodyMetrics body@@ -665,6 +711,14 @@ return $ ppr i <+> "<" <+> ppr d) <+> parens (text "~" <> ppr phys) +instance PrettyLore lore => Pretty (SegBinOp lore) where+ ppr (SegBinOp comm lam nes shape) =+ PP.braces (PP.commasep $ map ppr nes) <> PP.comma </>+ ppr shape <> PP.comma </>+ comm' <> ppr lam+ where comm' = case comm of Commutative -> text "commutative "+ Noncommutative -> mempty+ instance (PrettyLore lore, PP.Pretty lvl) => PP.Pretty (SegOp lvl lore) where ppr (SegMap lvl space ts body) = text "segmap" <> ppr lvl </>@@ -673,21 +727,13 @@ ppr (SegRed lvl space reds ts body) = text "segred" <> ppr lvl </>- PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp reds)) </>+ PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr reds)) </> PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> PP.nestedBlock "{" "}" (ppr body)- where ppOp (SegRedOp comm lam nes shape) =- PP.braces (PP.commasep $ map ppr nes) <> PP.comma </>- ppr shape <> PP.comma </>- comm' <> ppr lam- where comm' = case comm of Commutative -> text "commutative "- Noncommutative -> mempty - ppr (SegScan lvl space scan_op nes ts body) =+ ppr (SegScan lvl space scans ts body) = text "segscan" <> ppr lvl </>- ppr lvl </>- PP.parens (ppr scan_op <> PP.comma </>- PP.braces (PP.commasep $ map ppr nes)) </>+ PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr scans)) </> PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> PP.nestedBlock "{" "}" (ppr body) @@ -855,41 +901,20 @@ where scope_vtable = ST.fromScope $ scopeOfSegSpace space bound_here = namesFromList $ M.keys $ scopeOfSegSpace space -simplifyRedOrScan :: (Engine.SimplifiableLore lore, BodyAttr lore ~ ()) =>- SegSpace- -> Lambda lore -> [SubExp] -> [Type]- -> KernelBody lore- -> Engine.SimpleM lore- (SegSpace, Lambda (Wise lore), [SubExp], [Type], KernelBody (Wise lore),- Stms (Wise lore))-simplifyRedOrScan space scan_op nes ts kbody = do- space' <- Engine.simplify space- nes' <- mapM Engine.simplify nes- ts' <- mapM Engine.simplify ts-- (scan_op', scan_op_hoisted) <-- Engine.localVtable (<>scope_vtable) $+simplifySegBinOp :: Engine.SimplifiableLore lore =>+ SegBinOp lore+ -> Engine.SimpleM lore (SegBinOp (Wise lore), Stms (Wise lore))+simplifySegBinOp (SegBinOp comm lam nes shape) = do+ (lam', hoisted) <- Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $- Engine.simplifyLambda scan_op $ replicate (length nes * 2) Nothing-- (kbody', body_hoisted) <- simplifyKernelBody space kbody-- return (space', scan_op', nes', ts', kbody',- scan_op_hoisted <> body_hoisted)-- where scope = scopeOfSegSpace space- scope_vtable = ST.fromScope scope+ Engine.simplifyLambda lam $ replicate (length nes * 2) Nothing+ shape' <- Engine.simplify shape+ nes' <- mapM Engine.simplify nes+ return (SegBinOp comm lam' nes' shape', hoisted) -simplifySegOp :: (Attributes lore,- Engine.Simplifiable (LetAttr lore),- Engine.Simplifiable (FParamAttr lore),- Engine.Simplifiable (LParamAttr lore),- Engine.Simplifiable (RetType lore),- Engine.Simplifiable (BranchType lore),- Engine.Simplifiable lvl,- CanBeWise (Op lore),- ST.IndexOp (OpWithWisdom (Op lore)), BinderOps (Wise lore),- BodyAttr lore ~ ()) =>+simplifySegOp :: (Engine.SimplifiableLore lore,+ BodyAttr lore ~ (),+ Engine.Simplifiable lvl) => SegOp lvl lore -> Engine.SimpleM lore (SegOp lvl (Wise lore), Stms (Wise lore)) simplifySegOp (SegMap lvl space ts kbody) = do@@ -900,15 +925,8 @@ simplifySegOp (SegRed lvl space reds ts kbody) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts)- (reds', reds_hoisted) <- fmap unzip $ forM reds $ \(SegRedOp comm lam nes shape) -> do- (lam', hoisted) <-- Engine.localVtable (<>scope_vtable) $- Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $- Engine.simplifyLambda lam $ replicate (length nes * 2) Nothing- shape' <- Engine.simplify shape- nes' <- mapM Engine.simplify nes- return (SegRedOp comm lam' nes' shape', hoisted)-+ (reds', reds_hoisted) <- Engine.localVtable (<>scope_vtable) $+ unzip <$> mapM simplifySegBinOp reds (kbody', body_hoisted) <- simplifyKernelBody space kbody return (SegRed lvl' space' reds' ts' kbody',@@ -916,13 +934,16 @@ where scope = scopeOfSegSpace space scope_vtable = ST.fromScope scope -simplifySegOp (SegScan lvl space scan_op nes ts kbody) = do- lvl' <- Engine.simplify lvl- (space', scan_op', nes', ts', kbody', hoisted) <-- simplifyRedOrScan space scan_op nes ts kbody+simplifySegOp (SegScan lvl space scans ts kbody) = do+ (lvl', space', ts') <- Engine.simplify (lvl, space, ts)+ (scans', scans_hoisted) <- Engine.localVtable (<>scope_vtable) $+ unzip <$> mapM simplifySegBinOp scans+ (kbody', body_hoisted) <- simplifyKernelBody space kbody - return (SegScan lvl' space' scan_op' nes' ts' kbody',- hoisted)+ return (SegScan lvl' space' scans' ts' kbody',+ mconcat scans_hoisted <> body_hoisted)+ where scope = scopeOfSegSpace space+ scope_vtable = ST.fromScope scope simplifySegOp (SegHist lvl space ops ts kbody) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts)@@ -1017,7 +1038,7 @@ -- overhead, but can in principle lead to more local memory usage. topDownSegOp _ (Pattern [] pes) _ (SegRed lvl space ops ts kbody) | length ops > 1,- op_groupings <- groupBy sameShape $ zip ops $ chunks (map (length . segRedNeutral) ops) $+ op_groupings <- groupBy sameShape $ zip ops $ chunks (map (length . segBinOpNeutral) ops) $ zip3 red_pes red_ts red_res, any ((>1) . length) op_groupings = Simplify $ do let (ops', aux) = unzip $ mapMaybe combineOps op_groupings@@ -1026,22 +1047,22 @@ ts' = red_ts' ++ map_ts kbody' = kbody { kernelBodyResult = red_res' ++ map_res } letBind_ (Pattern [] pes') $ Op $ segOp $ SegRed lvl space ops' ts' kbody'- where (red_pes, map_pes) = splitAt (segRedResults ops) pes- (red_ts, map_ts) = splitAt (segRedResults ops) ts- (red_res, map_res) = splitAt (segRedResults ops) $ kernelBodyResult kbody+ where (red_pes, map_pes) = splitAt (segBinOpResults ops) pes+ (red_ts, map_ts) = splitAt (segBinOpResults ops) ts+ (red_res, map_res) = splitAt (segBinOpResults ops) $ kernelBodyResult kbody - sameShape (op1, _) (op2, _) = segRedShape op1 == segRedShape op2+ sameShape (op1, _) (op2, _) = segBinOpShape op1 == segBinOpShape op2 combineOps [] = Nothing combineOps (x:xs) = Just $ foldl' combine x xs combine (op1, op1_aux) (op2, op2_aux) =- let lam1 = segRedLambda op1- lam2 = segRedLambda op2+ let lam1 = segBinOpLambda op1+ lam2 = segBinOpLambda op2 (op1_xparams, op1_yparams) =- splitAt (length (segRedNeutral op1)) $ lambdaParams lam1+ splitAt (length (segBinOpNeutral op1)) $ lambdaParams lam1 (op2_xparams, op2_yparams) =- splitAt (length (segRedNeutral op2)) $ lambdaParams lam2+ splitAt (length (segBinOpNeutral op2)) $ lambdaParams lam2 lam = Lambda { lambdaParams = op1_xparams ++ op2_xparams ++ op1_yparams ++ op2_yparams , lambdaReturnType = lambdaReturnType lam1 ++ lambdaReturnType lam2@@ -1049,10 +1070,10 @@ mkBody (bodyStms (lambdaBody lam1) <> bodyStms (lambdaBody lam2)) $ bodyResult (lambdaBody lam1) <> bodyResult (lambdaBody lam2) }- in (SegRedOp { segRedComm = segRedComm op1 <> segRedComm op2- , segRedLambda = lam- , segRedNeutral = segRedNeutral op1 ++ segRedNeutral op2- , segRedShape = segRedShape op1 -- Same as shape of op2 due to the grouping.+ in (SegBinOp { segBinOpComm = segBinOpComm op1 <> segBinOpComm op2+ , segBinOpLambda = lam+ , segBinOpNeutral = segBinOpNeutral op1 ++ segBinOpNeutral op2+ , segBinOpShape = segBinOpShape op1 -- Same as shape of op2 due to the grouping. }, op1_aux ++ op2_aux) topDownSegOp _ _ _ _ = Skip@@ -1139,13 +1160,14 @@ where correct (WriteReturns _ arr _) _ = varReturns arr correct _ ret = return ret +-- | Like 'segOpType', but for memory representations. segOpReturns :: (Mem lore, Monad m, HasScope lore m) => SegOp lvl lore -> m [ExpReturns] segOpReturns k@(SegMap _ _ _ kbody) = kernelBodyReturns kbody =<< (extReturns <$> opType k) segOpReturns k@(SegRed _ _ _ _ kbody) = kernelBodyReturns kbody =<< (extReturns <$> opType k)-segOpReturns k@(SegScan _ _ _ _ _ kbody) =+segOpReturns k@(SegScan _ _ _ _ kbody) = kernelBodyReturns kbody =<< (extReturns <$> opType k) segOpReturns (SegHist _ _ ops _ _) = concat <$> mapM (mapM varReturns . histDest) ops
src/Futhark/Representation/SeqMem.hs view
@@ -8,7 +8,6 @@ -- * Simplification , simplifyProg- , simplifyStms , simpleSeqMem -- * Module re-exports@@ -18,7 +17,6 @@ where import Futhark.Analysis.PrimExp.Convert-import Futhark.MonadFreshNames import Futhark.Pass import Futhark.Representation.AST.Syntax import Futhark.Representation.AST.Attributes@@ -79,13 +77,6 @@ simplifyProg :: Prog SeqMem -> PassM (Prog SeqMem) simplifyProg = simplifyProgGeneric $ const $ return ((), mempty)--simplifyStms :: (HasScope SeqMem m, MonadFreshNames m) =>- Stms SeqMem- -> m (Engine.SymbolTable (Engine.Wise SeqMem),- Stms SeqMem)-simplifyStms =- simplifyStmsGeneric $ const $ return ((), mempty) simpleSeqMem :: Engine.SimpleOps SeqMem simpleSeqMem =
src/Futhark/Tools.hs view
@@ -88,23 +88,25 @@ -- code for them. In essense, what happens is the opposite of -- horisontal fusion. dissectScrema :: (MonadBinder m, Op (Lore m) ~ SOAC (Lore m),- Bindable (Lore m)) =>- Pattern (Lore m) -> SubExp -> ScremaForm (Lore m) -> [VName]- -> m ()-dissectScrema pat w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs = do+ Bindable (Lore m)) =>+ Pattern (Lore m) -> SubExp -> ScremaForm (Lore m) -> [VName]+ -> m ()+dissectScrema pat w (ScremaForm scans reds map_lam) arrs = do let num_reds = redResults reds+ num_scans = scanResults scans (scan_res, red_res, map_res) =- splitAt3 (length scan_nes) num_reds $ patternNames pat+ splitAt3 num_scans num_reds $ patternNames pat+ -- First we perform the Map, then we perform the Reduce, and finally -- the Scan.- to_scan <- replicateM (length scan_nes) $ newVName "to_scan"+ to_scan <- replicateM num_scans $ newVName "to_scan" to_red <- replicateM num_reds $ newVName "to_red" letBindNames_ (to_scan <> to_red <> map_res) $ Op $ Screma w (mapSOAC map_lam) arrs reduce <- reduceSOAC reds letBindNames_ red_res $ Op $ Screma w reduce to_red - scan <- scanSOAC scan_lam scan_nes+ scan <- scanSOAC scans letBindNames_ scan_res $ Op $ Screma w scan to_scan sequentialStreamWholeArray :: (MonadBinder m, Bindable (Lore m)) =>
src/Futhark/Transform/FirstOrderTransform.hs view
@@ -94,9 +94,10 @@ -> SOAC (Lore m) -> m () -transformSOAC pat (Screma w form@(ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) = do+transformSOAC pat (Screma w form@(ScremaForm scans reds map_lam) arrs) = do -- Start by combining all the reduction parts into a single operator- let (Reduce _ red_lam red_nes) = singleReduce reds+ let Reduce _ red_lam red_nes = singleReduce reds+ Scan scan_lam scan_nes = singleScan scans (scan_arr_ts, _red_ts, map_arr_ts) = splitAt3 (length scan_nes) (length red_nes) $ scremaType w form scan_arrs <- resultArray scan_arr_ts
src/Futhark/TypeCheck.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-} -- | The type checker checks whether the program is type-consistent. module Futhark.TypeCheck ( -- * Interface
src/Futhark/Util.hs view
@@ -56,7 +56,7 @@ import qualified System.FilePath.Posix as Posix import qualified System.FilePath as Native --- | Like 'mapAccumL', but monadic.+-- | Like 'Data.Traversable.mapAccumL', but monadic. mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) mapAccumLM _ acc [] = return (acc, [])@@ -238,6 +238,8 @@ putMVar cell result return cell +-- | Run various 'IO' actions concurrently, possibly with a bound on+-- the number of threads. pmapIO :: Maybe Int -> (a -> IO b) -> [a] -> IO [b] pmapIO concurrency f elems = go elems [] where
src/Futhark/Util/Console.hs view
@@ -9,14 +9,18 @@ import System.Console.ANSI +-- | Surround the given string with the given start/end colour codes. color :: [SGR] -> String -> String color sgr s = setSGRCode sgr ++ s ++ setSGRCode [Reset] +-- | Make the string red. inRed :: String -> String inRed s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset] +-- | Make the string green. inGreen :: String -> String inGreen s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset] +-- | Make the string bold. inBold :: String -> String inBold s = setSGRCode [SetConsoleIntensity BoldIntensity] ++ s ++ setSGRCode [Reset]
src/Futhark/Util/IntegralExp.hs view
@@ -22,7 +22,10 @@ where import Data.Int+import Prelude +-- | A twist on the 'Integral' type class that is more friendly to+-- symbolic representations. class Num e => IntegralExp e where quot :: e -> e -> e rem :: e -> e -> e@@ -69,7 +72,7 @@ fromInt32 = fromInteger . toInteger fromInt64 = fromInteger . toInteger --- | Like 'quot', but rounds up.+-- | Like 'Prelude.quot', but rounds up. quotRoundingUp :: IntegralExp num => num -> num -> num quotRoundingUp x y = (x + y - 1) `Futhark.Util.IntegralExp.quot` y
src/Language/Futhark/Attributes.hs view
@@ -558,6 +558,8 @@ unscopeType (foldMap unscopeSet cs) t where unscopeSet (CasePat p _ _) = S.map identName $ patternIdents p +-- | @foldFunType ts ret@ creates a function type ('Arrow') that takes+-- @ts@ as parameters and returns @ret@. foldFunType :: Monoid as => [TypeBase dim as] -> TypeBase dim as -> TypeBase dim as foldFunType ps ret = foldr arrow ret ps where arrow t1 t2 = Scalar $ Arrow mempty Unnamed t1 t2
src/Language/Futhark/Interpreter.hs view
@@ -1225,9 +1225,9 @@ , (getU, putU, P.doUnOp $ P.Complement Int64) , (getB, putB, P.doUnOp P.Not) ] - def "+" = arithOp P.Add P.FAdd- def "-" = arithOp P.Sub P.FSub- def "*" = arithOp P.Mul P.FMul+ def "+" = arithOp (`P.Add` P.OverflowWrap) P.FAdd+ def "-" = arithOp (`P.Sub` P.OverflowWrap) P.FSub+ def "*" = arithOp (`P.Mul` P.OverflowWrap) P.FMul def "**" = arithOp P.Pow P.FPow def "/" = Just $ bopDef $ sintOp P.SDiv ++ uintOp P.UDiv ++ floatOp P.FDiv def "%" = Just $ bopDef $ sintOp P.SMod ++ uintOp P.UMod ++ floatOp P.FMod
src/Language/Futhark/TypeChecker/Modules.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-}+-- | Implementation of the Futhark module system (at least most of it;+-- some is scattered elsewhere in the type checker). module Language.Futhark.TypeChecker.Modules ( matchMTys , newNamesForMTy@@ -67,9 +69,10 @@ allNamesInMTy (MTy abs mod) = S.fromList (map qualLeaf $ M.keys abs) <> allNamesInMod mod +-- | Create unique renames for the module type. This is used for+-- e.g. generative functor application. newNamesForMTy :: MTy -> TypeM (MTy, M.Map VName VName) newNamesForMTy orig_mty = do- -- Create unique renames for the module type. pairs <- forM (S.toList $ allNamesInMTy orig_mty) $ \v -> do v' <- newName v return (v, v')@@ -327,7 +330,7 @@ spread (map ppr ps) <+> equals <+/> nest 2 (align (ppr t)) --- Return new renamed/abstracted env, as well as a mapping from+-- | Return new renamed/abstracted env, as well as a mapping from -- names in the signature to names in the new env. This is used for -- functor application. The first env is the module env, and the -- second the env it must match.@@ -487,6 +490,7 @@ "val" <+> pprName v <+> spread (map ppr tps) <+> colon </> indent 2 (align (ppr t)) +-- | Apply a parametric module to an argument. applyFunctor :: SrcLoc -> FunSig -> MTy -> TypeM (MTy, M.Map VName VName,