futhark 0.25.34 → 0.25.35
raw patch · 129 files changed
+2878/−1325 lines, 129 filesdep +text-ropedep ~basedep ~futhark-datadep ~futhark-manifest
Dependencies added: text-rope
Dependency ranges changed: base, futhark-data, futhark-manifest
Files
- CHANGELOG.md +46/−0
- docs/error-index.rst +31/−0
- docs/language-reference.rst +9/−0
- docs/man/futhark-profile.rst +23/−12
- docs/man/futhark-test.rst +4/−0
- futhark.cabal +12/−5
- prelude/array.fut +1/−1
- prelude/math.fut +25/−0
- rts/c/backends/c.h +12/−7
- rts/c/backends/cuda.h +14/−15
- rts/c/backends/hip.h +14/−15
- rts/c/backends/multicore.h +12/−7
- rts/c/backends/opencl.h +13/−16
- rts/c/context.h +8/−10
- rts/c/context_prototypes.h +8/−0
- rts/c/gpu.h +4/−3
- rts/c/values.h +30/−13
- rts/futhark-doc/style.css +0/−226
- rts/python/opencl.py +36/−35
- rts/python/tuning.py +13/−2
- rts/style.css +242/−0
- src-testing/Futhark/IR/Prop/RearrangeTests.hs +8/−8
- src-testing/Futhark/IR/Prop/ReshapeTests.hs +58/−58
- src-testing/Language/Futhark/PrimitiveTests.hs +1/−1
- src/Futhark/AD/Rev.hs +4/−1
- src/Futhark/AD/Rev/Loop.hs +3/−4
- src/Futhark/AD/Rev/Monad.hs +0/−1
- src/Futhark/AD/Rev/Scan.hs +3/−6
- src/Futhark/Analysis/AccessPattern.hs +2/−1
- src/Futhark/Analysis/CallGraph.hs +0/−1
- src/Futhark/Analysis/HORep/SOAC.hs +1/−1
- src/Futhark/Analysis/Metrics.hs +2/−1
- src/Futhark/Analysis/SymbolTable.hs +1/−1
- src/Futhark/CLI/Bench.hs +20/−5
- src/Futhark/CLI/Doc.hs +1/−1
- src/Futhark/CLI/LSP.hs +18/−1
- src/Futhark/CLI/Main.hs +1/−1
- src/Futhark/CLI/Pkg.hs +1/−1
- src/Futhark/CLI/Profile.hs +317/−38
- src/Futhark/CLI/Test.hs +28/−5
- src/Futhark/CodeGen/Backends/CCUDA.hs +1/−2
- src/Futhark/CodeGen/Backends/COpenCL.hs +1/−2
- src/Futhark/CodeGen/Backends/GPU.hs +8/−4
- src/Futhark/CodeGen/Backends/GenericC.hs +32/−26
- src/Futhark/CodeGen/Backends/GenericC/CLI.hs +2/−2
- src/Futhark/CodeGen/Backends/GenericC/Code.hs +3/−0
- src/Futhark/CodeGen/Backends/GenericC/Monad.hs +5/−3
- src/Futhark/CodeGen/Backends/GenericC/Server.hs +2/−2
- src/Futhark/CodeGen/Backends/GenericC/Types.hs +21/−5
- src/Futhark/CodeGen/Backends/GenericPython.hs +63/−18
- src/Futhark/CodeGen/Backends/GenericPython/Options.hs +1/−2
- src/Futhark/CodeGen/Backends/HIP.hs +1/−2
- src/Futhark/CodeGen/Backends/MulticoreC.hs +17/−1
- src/Futhark/CodeGen/Backends/MulticoreISPC.hs +0/−1
- src/Futhark/CodeGen/Backends/MulticoreWASM.hs +0/−1
- src/Futhark/CodeGen/Backends/PyOpenCL.hs +11/−9
- src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +15/−22
- src/Futhark/CodeGen/Backends/SequentialC.hs +0/−1
- src/Futhark/CodeGen/Backends/SequentialPython.hs +24/−21
- src/Futhark/CodeGen/Backends/SequentialWASM.hs +0/−1
- src/Futhark/CodeGen/Backends/SimpleRep.hs +4/−1
- src/Futhark/CodeGen/ImpCode.hs +43/−29
- src/Futhark/CodeGen/ImpCode/GPU.hs +4/−0
- src/Futhark/CodeGen/ImpCode/Multicore.hs +24/−13
- src/Futhark/CodeGen/ImpCode/OpenCL.hs +1/−3
- src/Futhark/CodeGen/ImpGen.hs +24/−2
- src/Futhark/CodeGen/ImpGen/GPU.hs +10/−8
- src/Futhark/CodeGen/ImpGen/GPU/Base.hs +7/−0
- src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs +19/−20
- src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +1/−2
- src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs +425/−380
- src/Futhark/Doc/Generator.hs +5/−18
- src/Futhark/IR/GPU/Op.hs +6/−6
- src/Futhark/IR/GPUMem.hs +1/−1
- src/Futhark/IR/MC/Op.hs +5/−5
- src/Futhark/IR/MCMem.hs +1/−1
- src/Futhark/IR/Mem.hs +1/−1
- src/Futhark/IR/Mem/LMAD.hs +2/−4
- src/Futhark/IR/Parse.hs +2/−0
- src/Futhark/IR/Pretty.hs +11/−9
- src/Futhark/IR/Prop/Aliases.hs +1/−0
- src/Futhark/IR/Prop/Scope.hs +0/−1
- src/Futhark/IR/Prop/TypeOf.hs +2/−1
- src/Futhark/IR/SOACS/SOAC.hs +6/−6
- src/Futhark/IR/SegOp.hs +16/−17
- src/Futhark/IR/SeqMem.hs +1/−1
- src/Futhark/IR/Syntax.hs +3/−0
- src/Futhark/IR/Traversals.hs +4/−0
- src/Futhark/IR/TypeCheck.hs +47/−49
- src/Futhark/Internalise/Defunctionalise.hs +0/−1
- src/Futhark/Internalise/Exps.hs +30/−9
- src/Futhark/Internalise/Lambdas.hs +1/−1
- src/Futhark/Internalise/LiftLambdas.hs +0/−1
- src/Futhark/Internalise/Monomorphise.hs +4/−6
- src/Futhark/Internalise/TypesValues.hs +2/−2
- src/Futhark/LSP/Handlers.hs +79/−1
- src/Futhark/Optimise/CSE.hs +2/−2
- src/Futhark/Optimise/Fusion/Composing.hs +2/−2
- src/Futhark/Optimise/Fusion/TryFusion.hs +1/−1
- src/Futhark/Optimise/InliningDeadFun.hs +7/−1
- src/Futhark/Optimise/ReduceDeviceSyncs.hs +0/−1
- src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs +3/−0
- src/Futhark/Optimise/Simplify/Engine.hs +1/−1
- src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +1/−1
- src/Futhark/Optimise/Simplify/Rules/Loop.hs +8/−12
- src/Futhark/Optimise/Simplify/Rules/Match.hs +1/−1
- src/Futhark/Optimise/Sink.hs +0/−1
- src/Futhark/Optimise/TileLoops.hs +1/−2
- src/Futhark/Optimise/TileLoops/Shared.hs +1/−1
- src/Futhark/Pass/ExpandAllocations.hs +1/−1
- src/Futhark/Pass/ExplicitAllocations.hs +1/−1
- src/Futhark/Pass/ExtractKernels/Distribution.hs +2/−2
- src/Futhark/Pkg/Info.hs +0/−2
- src/Futhark/Pkg/Types.hs +1/−1
- src/Futhark/Profile/Details.hs +34/−0
- src/Futhark/Profile/EventSummary.hs +21/−0
- src/Futhark/Profile/Html.hs +433/−0
- src/Futhark/Profile/SourceRange.hs +175/−0
- src/Futhark/Script.hs +4/−4
- src/Futhark/Test.hs +10/−2
- src/Futhark/Transform/FirstOrderTransform.hs +1/−1
- src/Futhark/Util/Html.hs +38/−0
- src/Futhark/Util/Pretty.hs +3/−3
- src/Language/Futhark/Interpreter.hs +14/−14
- src/Language/Futhark/Pretty.hs +2/−2
- src/Language/Futhark/Primitive.hs +1/−1
- src/Language/Futhark/Prop.hs +17/−5
- src/Language/Futhark/Semantic.hs +1/−1
- src/Language/Futhark/TypeChecker/Terms/Loop.hs +66/−32
CHANGELOG.md view
@@ -5,6 +5,50 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [0.25.35]++### Added++* `futhark lsp` now provides the `textDocument/formatting` server method++* `futhark profile`: Generation of HTML-Files with cost centre and source range+ analysis, heatmap markup according to source range cost.+ (#2340, With VegOwOtenks)++* Per Cost-Centre Source Location Listings in the `.summary`-file output of+ `futhark profile`. (By VegOwOtenks)++* The `multicore` backend now uses a decoupled lookback `scan` implemented by+ Amirreza Hashemi.++* Custom tuning parameters can now be added with the `#[param(NAME)]` attribute.+ See the documentation for the sharp edges.++* `futhark test` now supports `--tuning`, just like `futhark bench`.++### Fixed++* Unit types now behave like records/tuples in the C interface and derived+ interface, such as server-mode and `futhark literate`. (#2332)++* `futhark bench`: JSON output now contains results for all test stanzas that+ use a given entry point, rather than just the last one.++* A bug in internalisation of `while` loops that could occur when one result of+ the loop was syntactically the same as a loop parameter. (#2335)++* Missing inlining for some functions that must be inlined when using GPU+ backends. (#2341)++* An interpreter bug in return size inference for functions returning an+ abstract type that is concrete at the calling size (#2336).++* `futhark bench` would ignore programs with any tag.++* An issue where some array types would not be generated for the C API.++* An edge case in loop size inference. (#2354)+ ## [0.25.34] ### Added@@ -364,6 +408,8 @@ * `futhark script` now supports an `-f` option. * `futhark script` now supports the builtin procedure `$store`.++* Compiling the Futhark compiler now requires GHC 9.10. ### Fixed
docs/error-index.rst view
@@ -660,6 +660,37 @@ def main = f (\(xs:[1]i64) -> xs[0]) +.. _loop-variant-escape:++"Loop-variant size has escaped"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This somewhat rare error occurs for ``loop`` expression where the size of some+loop parameter changes for every iteration, yet type inference leads to that+size also occurring in the type of some variable or expression bound outside the+loop. As an example, consider this program:++.. code-block:: futhark++ def grow [d] (a: [d]f64) (b: [d + 1]f64) : [d + 1]f64 =+ b++ def f_pass [n] (a: [n]f64) (b: []f64) =+ loop a' = a for i < 1 do+ grow a' b++The definition of ``grow`` does not matter; the important detail is that it+forces a relationship between the sizes of its arguments. Now the loop parameter+``a'`` is assigned a type ``[m]f64`` for some ``m`` that varies for every+iteration of the loop. Due to the application of ``grow``, we force the type of+``b`` to become ``[m+1]f64``. But this is meaningless (and not allowed), since+``m`` does not exist at the point where ``b`` is found.++It can be difficult to identify the specific point in the code that makes the+undesirable inferance, but it usually helps to put explicit size annotations on+all function parameters and other ambiguous cases. The error can occur only due+to instantiation of an anonymous size.+ Module errors -------------
docs/language-reference.rst view
@@ -1850,6 +1850,15 @@ to be told when the compiler is unable to statically verify the safety of all operations. +``param(name)``+...............++This attribute can only be attached to an expression of type ``i64``. It causes+a tuning parameter to be defined with the given name. This tuning parameter can+then be set at program startup to override value of the expression this+attribute is applied to. It is currently unspecified whether setting the tuning+parameter after context creation has any effect.+ Declaration attributes ~~~~~~~~~~~~~~~~~~~~~~
docs/man/futhark-profile.rst view
@@ -14,9 +14,10 @@ DESCRIPTION =========== -This tool produces human-readable profiling information based on information-collected with :ref:`futhark bench<futhark-bench(1)>`. Futhark has basic support-for profiling. The system can collect information about the run-time behaviour+This tool produces human- and browser-readable profiling information based on+information collected with :ref:`futhark bench<futhark-bench(1)>`.+Futhark has basic support for profiling.+The system can collect information about the run-time behaviour of the program, and connects it as best it is able to the program source code. This works best for the GPU backends, and not at all for the sequential backends. The collected information can then be used to estimate the source of@@ -32,13 +33,15 @@ the profiling information will be missing. The information in the JSON file is complete, but it is difficult for humans to read. -The next step is to run ``futhark profile`` on the JSON file. For a-JSON file ``prog.json``, this will create a *top level directory*-``prog.prof`` that contains files with human-readable profiling-information. A set of files will be created for each benchmark-dataset. If the original invocation of ``futhark bench`` included-multiple programs, then ``futhark profile`` will create subdirectories-for each program (although all inside the same top level directory).+The next step is to run ``futhark profile`` on the JSON file. For a JSON file+``prog.json``, this will create a *top level directory* ``prog.prof`` that+contains files with human-readable profiling information. A set of files will be+created for each benchmark dataset. If the original invocation of ``futhark+bench`` included multiple programs, then ``futhark profile`` will create+subdirectories for each program (although all inside the same top level+directory). If the source files passed to ``futhark bench`` are accessible via+the original paths, then the directory will also contain HTML files with+annotated source code. You can pass multiple JSON files to ``futhark profile``. Each will produce a distinct top level directory.@@ -46,8 +49,9 @@ Files produced -------------- -Supposing a dataset ``foo``, ``futhark profile`` will produce the-following files in the top level directory.+Supposing a dataset ``foo`` for an entry point in ``source-file.fut``.+``futhark profile`` will produce the following files and directories in the top+level directory. * ``foo.log``: the running log produced during execution. Contains many details on dynamic behaviour, depending on the exact backend.@@ -59,8 +63,15 @@ which they occurred, along with their runtime and other available information, most importantly the source locations. +* ``foo-index.html``: overview file and guide to the other html files.+ Contains explanations for the concepts, links to other pages.+ This is the entry file for profile exploration.+ The log file is often too verbose to be useful, but the summary and timeline should be inspected, even if the latter is sometimes fairly large.++All the other files require a web browser but may provide easier access+to the timing data, since the source resolution and parsing is done already. Technicalities --------------
docs/man/futhark-test.rst view
@@ -161,6 +161,10 @@ The number of tests to run concurrently. Defaults to the number of (hyper-)cores available. +--entry-point=name++ Only run entry points with this name.+ --exclude=tag Do not run test cases that contain the given tag. Cases marked with
futhark.cabal view
@@ -1,6 +1,6 @@-cabal-version: 2.4+cabal-version: 3.0 name: futhark-version: 0.25.34+version: 0.25.35 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to@@ -67,7 +67,7 @@ rts/c/util.h rts/c/server.h rts/cuda/prelude.cu- rts/futhark-doc/style.css+ rts/style.css rts/javascript/server.js rts/javascript/values.js rts/javascript/wrapperclasses.js@@ -103,7 +103,7 @@ location: https://github.com/diku-dk/futhark common common- ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wno-x-partial -Wno-unrecognised-warning-flags -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -Wunused-packages+ ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wno-x-partial -Wno-unrecognised-warning-flags -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -Wunused-packages -Wno-x-data-list-nonempty-unzip default-language: GHC2021 default-extensions: OverloadedStrings@@ -380,6 +380,10 @@ Futhark.Pkg.Solve Futhark.Pkg.Types Futhark.Profile+ Futhark.Profile.Details+ Futhark.Profile.EventSummary+ Futhark.Profile.Html+ Futhark.Profile.SourceRange Futhark.Script Futhark.Test Futhark.Test.Spec@@ -392,6 +396,7 @@ Futhark.Util Futhark.Util.CMath Futhark.Util.IntegralExp+ Futhark.Util.Html Futhark.Util.Loc Futhark.Util.Log Futhark.Util.Options@@ -446,7 +451,7 @@ , ansi-terminal >=0.6.3.1 , array >=0.4 , async >=2.0- , base >=4.15 && <5+ , base >=4.20 && <5 , base16-bytestring , binary >=0.8.3 , blaze-html >=0.9.0.1@@ -489,6 +494,7 @@ , temporary , terminal-size >=0.3 , text >=1.2.2.2+ , text-rope , time >=1.6.0.1 , transformers >=0.3 , vector >=0.12@@ -508,6 +514,7 @@ library futhark-testing import: common hs-source-dirs: src-testing+ visibility: private exposed-modules: Futhark.AD.DerivativesTests Futhark.Analysis.AlgSimplifyTests
prelude/array.fut view
@@ -73,7 +73,7 @@ -- | Concatenate two arrays. Warning: never try to perform a reduction -- with this operator; it will not work. ----- **Work:** O(n).+-- **Work:** O(n + m). -- -- **Span:** O(1). #[inline]
prelude/math.fut view
@@ -4,6 +4,31 @@ -- | Describes types of values that can be created from the primitive -- numeric types (and bool).+--+-- This is a somewhat lawless module, and the precise semantics of these+-- conversions depend on the modules in question, but the following rules apply+-- for the modules in prelude:+--+-- * Creating a `bool` from a number produces `false` if the number is 0 and+-- `true` otherwise.+--+-- * Creating a number from `true` produces 1, and `false` produces 0.+--+-- * Creating an integer from a larger integer type is by bitwise truncation.+--+-- * Creating a signed integer from a smaller integer type is by sign extension.+--+-- * Creating an unsigned integer from a smaller integer type is by zero+-- extension.+--+-- * Creating an integer from a floating point number is by numerical+-- truncation. If the floating-point number is infinity or NaN, then the+-- integer value is not meaningful. Use `to_bits` if you want to inspect the+-- bitwise representation of a float.+--+-- * Creating a floating-point number from an integer is by numerical conversion+-- (which may introduce roundoff error). Use `from_bits` if you want to+-- construct a float from its bitwise representation. module type from_prim = { type t
rts/c/backends/c.h view
@@ -6,11 +6,7 @@ int profiling; int logging; char *cache_fname;- int num_tuning_params;- int64_t *tuning_params;- const char** tuning_param_names;- const char** tuning_param_vars;- const char** tuning_param_classes;+ struct tuning_param tuning_params[NUM_TUNING_PARAMS]; }; static void backend_context_config_setup(struct futhark_context_config* cfg) {@@ -21,8 +17,17 @@ (void)cfg; } -int futhark_context_config_set_tuning_param(struct futhark_context_config* cfg, const char *param_name, size_t param_value) {- (void)cfg; (void)param_name; (void)param_value;+int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg,+ const char *param_name,+ size_t new_value) {+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) {+ if (strcmp(param_name, cfg->tuning_params[i].name) == 0) {+ cfg->tuning_params[i].val = new_value;+ cfg->tuning_params[i].set = true;+ return 0;+ }+ }+ return 1; }
rts/c/backends/cuda.h view
@@ -79,12 +79,8 @@ int debugging; int profiling; int logging;- char* cache_fname;- int num_tuning_params;- int64_t *tuning_params;- const char** tuning_param_names;- const char** tuning_param_vars;- const char** tuning_param_classes;+ char *cache_fname;+ struct tuning_param tuning_params[NUM_TUNING_PARAMS]; // Uniform fields above. char* program;@@ -210,7 +206,6 @@ CUdeviceptr global_failure; CUdeviceptr global_failure_args;- struct tuning_params tuning_params; // True if a potentially failing kernel has been enqueued. int32_t failure_is_an_option; int total_runs;@@ -395,7 +390,7 @@ } } - size_t i = 0, n_opts_alloc = 20 + num_macros + num_extra_opts + cfg->num_tuning_params;+ size_t i = 0, n_opts_alloc = 20 + num_macros + num_extra_opts + 2*NUM_TUNING_PARAMS; char **opts = (char**) malloc(n_opts_alloc * sizeof(char *)); if (!arch_set) { opts[i++] = strdup("-arch");@@ -422,9 +417,13 @@ opts[i++] = msgprintf("-D%s=%zu", macro_names[j], macro_vals[j]); } - for (int j = 0; j < cfg->num_tuning_params; j++) {- opts[i++] = msgprintf("-D%s=%zu", cfg->tuning_param_vars[j],- cfg->tuning_params[j]);+ for (int j = 0; j < NUM_TUNING_PARAMS; j++) {+ opts[i++] = msgprintf("-Dset_%s=%d",+ ctx->cfg->tuning_params[j].var,+ (int)ctx->cfg->tuning_params[j].set);+ opts[i++] = msgprintf("-Dval_%s=%d",+ ctx->cfg->tuning_params[j].var,+ (int)ctx->cfg->tuning_params[j].val); } opts[i++] = msgprintf("-DLOCKSTEP_WIDTH=%zu", ctx->lockstep_width); opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_thread_block_size);@@ -550,10 +549,10 @@ / cfg->gpu.default_block_size; } - for (int i = 0; i < cfg->num_tuning_params; i++) {- const char *size_class = cfg->tuning_param_classes[i];- int64_t *size_value = &cfg->tuning_params[i];- const char* size_name = cfg->tuning_param_names[i];+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) {+ const char *size_class = cfg->tuning_params[i].class;+ int64_t *size_value = &cfg->tuning_params[i].val;+ const char* size_name = cfg->tuning_params[i].name; int64_t max_value = 0, default_value = 0; if (strstr(size_class, "thread_block_size") == size_class) {
rts/c/backends/hip.h view
@@ -77,12 +77,8 @@ int debugging; int profiling; int logging;- char* cache_fname;- int num_tuning_params;- int64_t *tuning_params;- const char** tuning_param_names;- const char** tuning_param_vars;- const char** tuning_param_classes;+ char *cache_fname;+ struct tuning_param tuning_params[NUM_TUNING_PARAMS]; // Uniform fields above. char* program;@@ -183,7 +179,6 @@ void* global_failure; void* global_failure_args;- struct tuning_params tuning_params; // True if a potentially failing kernel has been enqueued. int32_t failure_is_an_option; int total_runs;@@ -316,10 +311,10 @@ / cfg->gpu.default_block_size; } - for (int i = 0; i < cfg->num_tuning_params; i++) {- const char *size_class = cfg->tuning_param_classes[i];- int64_t *size_value = &cfg->tuning_params[i];- const char* size_name = cfg->tuning_param_names[i];+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) {+ const char *size_class = cfg->tuning_params[i].class;+ int64_t *size_value = &cfg->tuning_params[i].val;+ const char* size_name = cfg->tuning_params[i].name; int64_t max_value = 0, default_value = 0; if (strstr(size_class, "thread_block_size") == size_class) {@@ -413,7 +408,7 @@ } } - size_t i = 0, n_opts_alloc = 20 + num_macros + num_extra_opts + cfg->num_tuning_params;+ size_t i = 0, n_opts_alloc = 20 + num_macros + num_extra_opts + 2*NUM_TUNING_PARAMS; char **opts = (char**) malloc(n_opts_alloc * sizeof(char *)); if (!arch_set) { hipDeviceProp_t props;@@ -438,9 +433,13 @@ opts[i++] = msgprintf("-D%s=%zu", macro_names[j], macro_vals[j]); } - for (int j = 0; j < cfg->num_tuning_params; j++) {- opts[i++] = msgprintf("-D%s=%zu", cfg->tuning_param_vars[j],- cfg->tuning_params[j]);+ for (int j = 0; j < NUM_TUNING_PARAMS; j++) {+ opts[i++] = msgprintf("-Dset_%s=%d",+ ctx->cfg->tuning_params[j].var,+ (int)ctx->cfg->tuning_params[j].set);+ opts[i++] = msgprintf("-Dval_%s=%d",+ ctx->cfg->tuning_params[j].var,+ (int)ctx->cfg->tuning_params[j].val); } opts[i++] = msgprintf("-DLOCKSTEP_WIDTH=%zu", ctx->lockstep_width); opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_thread_block_size);
rts/c/backends/multicore.h view
@@ -6,11 +6,7 @@ int profiling; int logging; char *cache_fname;- int num_tuning_params;- int64_t *tuning_params;- const char** tuning_param_names;- const char** tuning_param_vars;- const char** tuning_param_classes;+ struct tuning_param tuning_params[NUM_TUNING_PARAMS]; // Uniform fields above. int num_threads;@@ -28,8 +24,17 @@ cfg->num_threads = n; } -int futhark_context_config_set_tuning_param(struct futhark_context_config* cfg, const char *param_name, size_t param_value) {- (void)cfg; (void)param_name; (void)param_value;+int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg,+ const char *param_name,+ size_t new_value) {+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) {+ if (strcmp(param_name, cfg->tuning_params[i].name) == 0) {+ cfg->tuning_params[i].val = new_value;+ cfg->tuning_params[i].set = true;+ return 0;+ }+ }+ return 1; }
rts/c/backends/opencl.h view
@@ -123,11 +123,7 @@ int profiling; int logging; char *cache_fname;- int num_tuning_params;- int64_t *tuning_params;- const char** tuning_param_names;- const char** tuning_param_vars;- const char** tuning_param_classes;+ struct tuning_param tuning_params[NUM_TUNING_PARAMS]; // Uniform fields above. char* program;@@ -446,7 +442,6 @@ cl_mem global_failure; cl_mem global_failure_args;- struct tuning_params tuning_params; // True if a potentially failing kernel has been enqueued. cl_int failure_is_an_option; int total_runs;@@ -514,8 +509,8 @@ struct opencl_device_option device_option) { int compile_opts_size = 1024; - for (int i = 0; i < ctx->cfg->num_tuning_params; i++) {- compile_opts_size += strlen(ctx->cfg->tuning_param_names[i]) + 20;+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) {+ compile_opts_size += 2*(strlen(ctx->cfg->tuning_params[i].name) + 20); } char** macro_names;@@ -551,11 +546,13 @@ "max_registers", (int)ctx->max_registers); - for (int i = 0; i < ctx->cfg->num_tuning_params; i++) {+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) { w += snprintf(compile_opts+w, compile_opts_size-w,- "-D%s=%d ",- ctx->cfg->tuning_param_vars[i],- (int)ctx->cfg->tuning_params[i]);+ "-Dset_%s=%d -Dval_%s=%d ",+ ctx->cfg->tuning_params[i].var,+ (int)ctx->cfg->tuning_params[i].set,+ ctx->cfg->tuning_params[i].var,+ (int)ctx->cfg->tuning_params[i].val); } for (int i = 0; extra_build_opts[i] != NULL; i++) {@@ -816,10 +813,10 @@ // Now we go through all the sizes, clamp them to the valid range, // or set them to the default.- for (int i = 0; i < ctx->cfg->num_tuning_params; i++) {- const char *size_class = ctx->cfg->tuning_param_classes[i];- int64_t *size_value = &ctx->cfg->tuning_params[i];- const char* size_name = ctx->cfg->tuning_param_names[i];+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) {+ const char *size_class = ctx->cfg->tuning_params[i].class;+ int64_t *size_value = &ctx->cfg->tuning_params[i].val;+ const char* size_name = ctx->cfg->tuning_params[i].name; int64_t max_value = 0, default_value = 0; if (strstr(size_class, "thread_block_size") == size_class) {
rts/c/context.h view
@@ -109,7 +109,7 @@ } int futhark_get_tuning_param_count(void) {- return num_tuning_params;+ return NUM_TUNING_PARAMS; } const char *futhark_get_tuning_param_name(int i) {@@ -142,13 +142,13 @@ cfg->profiling = 0; cfg->logging = 0; cfg->cache_fname = NULL;- cfg->num_tuning_params = num_tuning_params;- cfg->tuning_params = malloc(cfg->num_tuning_params * sizeof(int64_t));- memcpy(cfg->tuning_params, tuning_param_defaults,- cfg->num_tuning_params * sizeof(int64_t));- cfg->tuning_param_names = tuning_param_names;- cfg->tuning_param_vars = tuning_param_vars;- cfg->tuning_param_classes = tuning_param_classes;+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) {+ cfg->tuning_params[i].set = false;+ cfg->tuning_params[i].val = tuning_param_defaults[i];+ cfg->tuning_params[i].name = tuning_param_names[i];+ cfg->tuning_params[i].var = tuning_param_vars[i];+ cfg->tuning_params[i].class = tuning_param_classes[i];+ } backend_context_config_setup(cfg); return cfg; }@@ -157,7 +157,6 @@ assert(!cfg->in_use); backend_context_config_teardown(cfg); free(cfg->cache_fname);- free(cfg->tuning_params); free(cfg); } @@ -184,7 +183,6 @@ ctx->profiling_paused = 0; ctx->error = NULL; ctx->log = stderr;- set_tuning_params(ctx); if (backend_context_setup(ctx) == 0) { setup_program(ctx); init_constants(ctx);
rts/c/context_prototypes.h view
@@ -6,6 +6,14 @@ struct futhark_context_config; struct futhark_context; +struct tuning_param {+ const char *name;+ const char *var; // Z-encoded name.+ const char *class;+ bool set;+ int64_t val;+};+ static void set_error(struct futhark_context* ctx, char *error); // These are called in context/config new/free functions and contain
rts/c/gpu.h view
@@ -93,9 +93,10 @@ int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg, const char *param_name, size_t new_value) {- for (int i = 0; i < cfg->num_tuning_params; i++) {- if (strcmp(param_name, cfg->tuning_param_names[i]) == 0) {- cfg->tuning_params[i] = new_value;+ for (int i = 0; i < NUM_TUNING_PARAMS; i++) {+ if (strcmp(param_name, cfg->tuning_params[i].name) == 0) {+ cfg->tuning_params[i].val = new_value;+ cfg->tuning_params[i].set = true; return 0; } }
rts/c/values.h view
@@ -4,7 +4,7 @@ typedef int (*writer)(FILE*, const void*); typedef int (*bin_reader)(void*);-typedef int (*str_reader)(const char *, void*);+typedef int (*str_reader)(char *, void*); struct array_reader { char* elems;@@ -386,39 +386,48 @@ } } -static int write_str_i8(FILE *out, int8_t *src) {+static int read_str_unit(char *buf, void* dest) {+ (void)dest;+ if (strcmp(buf, "()") == 0) {+ return 0;+ } else {+ return 1;+ }+}++static int write_str_i8(FILE *out, const int8_t *src) { return fprintf(out, "%hhdi8", *src); } -static int write_str_u8(FILE *out, uint8_t *src) {+static int write_str_u8(FILE *out, const uint8_t *src) { return fprintf(out, "%hhuu8", *src); } -static int write_str_i16(FILE *out, int16_t *src) {+static int write_str_i16(FILE *out, const int16_t *src) { return fprintf(out, "%hdi16", *src); } -static int write_str_u16(FILE *out, uint16_t *src) {+static int write_str_u16(FILE *out, const uint16_t *src) { return fprintf(out, "%huu16", *src); } -static int write_str_i32(FILE *out, int32_t *src) {+static int write_str_i32(FILE *out, const int32_t *src) { return fprintf(out, "%di32", *src); } -static int write_str_u32(FILE *out, uint32_t *src) {+static int write_str_u32(FILE *out, const uint32_t *src) { return fprintf(out, "%uu32", *src); } -static int write_str_i64(FILE *out, int64_t *src) {+static int write_str_i64(FILE *out, const int64_t *src) { return fprintf(out, "%"PRIi64"i64", *src); } -static int write_str_u64(FILE *out, uint64_t *src) {+static int write_str_u64(FILE *out, const uint64_t *src) { return fprintf(out, "%"PRIu64"u64", *src); } -static int write_str_f16(FILE *out, uint16_t *src) {+static int write_str_f16(FILE *out, const uint16_t *src) { float x = halfbits2float(*src); if (isnan(x)) { return fprintf(out, "f16.nan");@@ -431,7 +440,7 @@ } } -static int write_str_f32(FILE *out, float *src) {+static int write_str_f32(FILE *out, const float *src) { float x = *src; if (isnan(x)) { return fprintf(out, "f32.nan");@@ -444,7 +453,7 @@ } } -static int write_str_f64(FILE *out, double *src) {+static int write_str_f64(FILE *out, const double *src) { double x = *src; if (isnan(x)) { return fprintf(out, "f64.nan");@@ -457,10 +466,15 @@ } } -static int write_str_bool(FILE *out, void *src) {+static int write_str_bool(FILE *out, const void *src) { return fprintf(out, *(char*)src ? "true" : "false"); } +static int write_str_unit(FILE *out, const void *src) {+ (void)src;+ return fprintf(out, "()");+}+ //// Binary I/O #define BINARY_FORMAT_VERSION 2@@ -540,6 +554,9 @@ static const struct primtype_info_t bool_info = {.binname = "bool", .type_name = "bool", .size = 1, .write_str = (writer)write_str_bool, .read_str = (str_reader)read_str_bool};+static const struct primtype_info_t unit_info =+ {.binname = "bool", .type_name = "unit", .size = 1,+ .write_str = (writer)write_str_unit, .read_str = (str_reader)read_str_unit}; static const struct primtype_info_t* primtypes[] = { &i8_info, &i16_info, &i32_info, &i64_info,
− rts/futhark-doc/style.css
@@ -1,226 +0,0 @@-body {- background-color: #fff9e5;- font-family: sans-serif;- padding: 0px;- margin: 0px;- margin-top: 0em;- margin-left: 0em;- margin-right: 0em;- overflow-y: scroll;- line-height: 1.4;-}--h1 {- margin-top: 0;- display: inline;-}--h2 {- margin-bottom: 1ex;- font-size: 2em;- color: #5f021f;-}--h3 {- font-size: 1em;- color: #5f021f;-}--p {- max-width: 65em;-}--td {- vertical-align: top;-}--#header {- color: #fff9e5;- background: #5f0220;- padding-left: 1em;-}--#navigation {- float: right;- vertical-align: centre;-}--#navigation ol {- display: block;-}--#navigation li {- display: inline;- list-style-type: none;- border-left: 1px solid #fff9e5;- padding-left: 1em;- padding-right: 1em;-}--#navigation a, #navigation a:visited {- color: #fff9e5;- text-decoration: none;-}--#content {- display: flex;-}--main {- padding-left: 1em;- padding-right: 1em;- width: 100%;-}--#abstract {- margin-bottom: 2ex;-}--#footer {- color: #fff9e5;- background: #5f0220;- padding-left: 1em;- padding-right: 1em;-}--#footer a, #footer a:visited {- color: #fff9e5;-}--@media (max-width:950px) {- #filenav {- display: none;- }-}--#filenav {- color: #fff9e5;- background: #5f0220;- padding-left: 1em;- padding-right: 1em;-}--#filenav a:hover {- background: #fff9e5;- display: block;- color: #5f0220;-}--#filenav a, #footer a:visited {- color: #fff9e5;- text-decoration: none;-}--#filenav > ul {- list-style: none;- padding: 0;- font-family: monospace;- font-weight: bold;-}--.file_desc {- /* Hack to avoid breaking a file description across multiple columns- on the contents page. */- display: table;- width: 100%;-}--@media (min-width:950px) {- .file_list {- columns: 3;- }-- .file_list > dd {- break-before: avoid;- }-}--.keyword {- font-weight: bold;-}--.specs {- margin-left: 2ex;- border-collapse: collapse;-}--.specs tr:hover td {- background: #ccc;-}--.spec_eql {- text-align: right;-}--.decl_description {- margin-bottom: 2ex;-}--.decl_name {- font-weight: bold;-}--.desc_header {- background: #ffcc7a;- font-family: monospace;- border-top: 1px solid #5f021f;-}--.desc_doc {- margin-left: 2ex;-}--.synopsis_link {- font-weight: bold;- text-decoration: none;- font-size: 1.3em;- width: 2ex;- display: inline-block;-}--.self_link {- text-decoration: none;-}--#module {- font-family: monospace;- white-space: pre;- display: block;- unicode-bidi: embed;-}--#doc_index thead {- font-weight: bold;-}--#doc_index td {- padding-right: 1em;-}--.doc_index_name {- font-family: monospace;-}--.doc_index_namespace {- font-style: italic;-}--.doc_index_initial {- font-size: 2em;- font-weight: bold;-}--.doc_index_initial a, .doc_index_initial a:visited {- color: #5f0220;-}--#doc_index_list li {- display: inline;- list-style-type: none;- padding-right: 1em;-}--#doc_index_list a, #doc_index_list a:visited {- color: #5f0220;- text-decoration: none;-}
rts/python/opencl.py view
@@ -183,25 +183,25 @@ ) self.failure_is_an_option = np.int32(0) - if "default_group_size" in sizes:- default_group_size = sizes["default_group_size"]- del sizes["default_group_size"]+ if "default_group_size" in user_sizes:+ default_group_size = user_sizes["default_group_size"]+ del user_sizes["default_group_size"] - if "default_num_groups" in sizes:- default_num_groups = sizes["default_num_groups"]- del sizes["default_num_groups"]+ if "default_num_groups" in user_sizes:+ default_num_groups = user_sizes["default_num_groups"]+ del user_sizes["default_num_groups"] - if "default_tile_size" in sizes:- default_tile_size = sizes["default_tile_size"]- del sizes["default_tile_size"]+ if "default_tile_size" in user_sizes:+ default_tile_size = user_sizes["default_tile_size"]+ del user_sizes["default_tile_size"] - if "default_reg_tile_size" in sizes:- default_reg_tile_size = sizes["default_reg_tile_size"]- del sizes["default_reg_tile_size"]+ if "default_reg_tile_size" in user_sizes:+ default_reg_tile_size = user_sizes["default_reg_tile_size"]+ del user_sizes["default_reg_tile_size"] - if "default_threshold" in sizes:- default_threshold = sizes["default_threshold"]- del sizes["default_threshold"]+ if "default_threshold" in user_sizes:+ default_threshold = user_sizes["default_threshold"]+ del user_sizes["default_threshold"] default_group_size_set = default_group_size != None default_tile_size_set = default_tile_size != None@@ -242,19 +242,13 @@ ) default_tile_size = max_tile_size - for k, v in user_sizes.items():- if k in all_sizes:- all_sizes[k]["value"] = v- else:- raise Exception(- "Unknown size: {}\nKnown sizes: {}".format(- k, " ".join(all_sizes.keys())- )- )+ set_user_params(all_sizes, user_sizes) - self.sizes = {} for k, v in all_sizes.items():- if v["class"] == "thread_block_size":+ if v["class"] is None:+ max_value = None+ default_value = None+ elif v["class"] == "thread_block_size": max_value = max_group_size default_value = default_group_size elif v["class"] == "grid_size":@@ -279,16 +273,16 @@ # Bespoke sizes have no limit or default. max_value = None if v["value"] == None:- self.sizes[k] = default_value+ self.sizes[k]["value"] = default_value elif max_value != None and v["value"] > max_value: sys.stderr.write( "Note: Device limits {} to {} (down from {}\n".format( k, max_value, v["value"] ) )- self.sizes[k] = max_value+ self.sizes[k]["value"] = max_value else:- self.sizes[k] = v["value"]+ self.sizes[k]["value"] = v["value"] # XXX: we perform only a subset of z-encoding here. Really, the # compiler should provide us with the variables to which@@ -300,16 +294,23 @@ "-D{}={}".format("max_thread_block_size", max_group_size) ] - build_options += [- "-D{}={}".format(+ for s, v in self.sizes.items():+ z = ( s.replace("z", "zz") .replace(".", "zi") .replace("#", "zh")- .replace("'", "zq"),- v,+ .replace("'", "zq") )- for (s, v) in self.sizes.items()- ]+ if v["value"] is None:+ build_options += [+ "-Dval_{}=0".format(z),+ "-Dset_{}=false".format(z),+ ]+ else:+ build_options += [+ "-Dval_{}={}".format(z, v["value"]),+ "-Dset_{}=true".format(z),+ ] build_options += [ "-D{}={}".format(s, to_c_str_rep(f())) for (s, f) in constants
rts/python/tuning.py view
@@ -4,8 +4,19 @@ def read_tuning_file(kvs, f): for line in f.read().splitlines(): size, value = line.split("=")- kvs[size] = int(value)- return kvs+ kvs[size] = np.int64(value)+++def set_user_params(all_sizes, user_sizes):+ for k, v in user_sizes.items():+ if k in all_sizes:+ all_sizes[k]["value"] = v+ else:+ raise Exception(+ "Unknown tuning parameter: {}\nKnown tuning parameters: {}".format(+ k, " ".join(all_sizes.keys())+ )+ ) # End of tuning.py.
+ rts/style.css view
@@ -0,0 +1,242 @@+body {+ background-color: #fff9e5;+ font-family: sans-serif;+ padding: 0px;+ margin: 0px;+ margin-top: 0em;+ margin-left: 0em;+ margin-right: 0em;+ overflow-y: scroll;+ line-height: 1.4;+}++h1 {+ margin-top: 0;+ display: inline;+}++h2 {+ margin-bottom: 1ex;+ font-size: 2em;+ color: #5f021f;+}++h3 {+ font-size: 1em;+ color: #5f021f;+}++p {+ max-width: 65em;+}++td {+ vertical-align: top;+}++#header {+ color: #fff9e5;+ background: #5f0220;+ padding-left: 1em;+}++#navigation {+ float: right;+ vertical-align: center;+}++#navigation ol {+ display: block;+}++#navigation li {+ display: inline;+ list-style-type: none;+ border-left: 1px solid #fff9e5;+ padding-left: 1em;+ padding-right: 1em;+}++#navigation a, #navigation a:visited {+ color: #fff9e5;+ text-decoration: none;+}++#content {+ display: flex;+}++main {+ padding-left: 1em;+ padding-right: 1em;+ width: 100%;+}++#abstract {+ margin-bottom: 2ex;+}++#footer {+ color: #fff9e5;+ background: #5f0220;+ padding-left: 1em;+ padding-right: 1em;+}++#footer a, #footer a:visited {+ color: #fff9e5;+}++@media (max-width:950px) {+ #filenav {+ display: none;+ }+}++#filenav {+ color: #fff9e5;+ background: #5f0220;+ padding-left: 1em;+ padding-right: 1em;+}++#filenav a:hover {+ background: #fff9e5;+ display: block;+ color: #5f0220;+}++#filenav a, #footer a:visited {+ color: #fff9e5;+ text-decoration: none;+}++#filenav > ul {+ list-style: none;+ padding: 0;+ font-family: monospace;+ font-weight: bold;+}++.file_desc {+ /* Hack to avoid breaking a file description across multiple columns+ on the contents page. */+ display: table;+ width: 100%;+}++@media (min-width:950px) {+ .file_list {+ columns: 3;+ }++ .file_list > dd {+ break-before: avoid;+ }+}++.keyword {+ font-weight: bold;+}++.specs {+ margin-left: 2ex;+ border-collapse: collapse;+}++.specs tr:hover td {+ background: #ccc;+}++.spec_eql {+ text-align: right;+}++.decl_description {+ margin-bottom: 2ex;+}++.decl_name {+ font-weight: bold;+}++.desc_header {+ background: #ffcc7a;+ font-family: monospace;+ border-top: 1px solid #5f021f;+}++.desc_doc {+ margin-left: 2ex;+}++.synopsis_link {+ font-weight: bold;+ text-decoration: none;+ font-size: 1.3em;+ width: 2ex;+ display: inline-block;+}++.self_link {+ text-decoration: none;+}++#module {+ font-family: monospace;+ white-space: pre;+ display: block;+ unicode-bidi: embed;+}++#doc_index thead {+ font-weight: bold;+}++#doc_index td {+ padding-right: 1em;+}++.doc_index_name {+ font-family: monospace;+}++.doc_index_namespace {+ font-style: italic;+}++.doc_index_initial {+ font-size: 2em;+ font-weight: bold;+}++.doc_index_initial a, .doc_index_initial a:visited {+ color: #5f0220;+}++#doc_index_list li {+ display: inline;+ list-style-type: none;+ padding-right: 1em;+}++#doc_index_list a, #doc_index_list a:visited {+ color: #5f0220;+ text-decoration: none;+}++a.silent-anchor {+ text-decoration: inherit;+ color: inherit;+}++.cctable table, .cctable th, .cctable td {+ border: 1px solid black;+ border-collapse: collapse;+}++.cctable th, .cctable td {+ padding-left: 0.5em;+ padding-right: 0.5em;+ text-align: center;+}
src-testing/Futhark/IR/Prop/RearrangeTests.hs view
@@ -17,14 +17,14 @@ isMapTransposeTests = [ testCase (unwords ["isMapTranspose", show perm, "==", show dres]) $ isMapTranspose perm @?= dres- | (perm, dres) <-- [ ([0, 1, 4, 5, 2, 3], Just (2, 2, 2)),- ([1, 0, 4, 5, 2, 3], Nothing),- ([1, 0], Just (0, 1, 1)),- ([0, 2, 1], Just (1, 1, 1)),- ([0, 1, 2], Nothing),- ([1, 0, 2], Nothing)- ]+ | (perm, dres) <-+ [ ([0, 1, 4, 5, 2, 3], Just (2, 2, 2)),+ ([1, 0, 4, 5, 2, 3], Nothing),+ ([1, 0], Just (0, 1, 1)),+ ([0, 2, 1], Just (1, 1, 1)),+ ([0, 1, 2], Nothing),+ ([1, 0, 2], Nothing)+ ] ] newtype Permutation = Permutation [Int]
src-testing/Futhark/IR/Prop/ReshapeTests.hs view
@@ -20,24 +20,24 @@ reshapeOuterTests = [ testCase (unwords ["reshapeOuter", show sc, show n, show shape, "==", show sc_res]) $ reshapeOuter (intShape sc) n (intShape shape) @?= intShape sc_res- | (sc, n, shape, sc_res) <-- [ ([1], 1, [4, 3], [1, 3]),- ([1], 2, [4, 3], [1]),- ([2, 2], 1, [4, 3], [2, 2, 3]),- ([2, 2], 2, [4, 3], [2, 2])- ]+ | (sc, n, shape, sc_res) <-+ [ ([1], 1, [4, 3], [1, 3]),+ ([1], 2, [4, 3], [1]),+ ([2, 2], 1, [4, 3], [2, 2, 3]),+ ([2, 2], 2, [4, 3], [2, 2])+ ] ] reshapeInnerTests :: [TestTree] reshapeInnerTests = [ testCase (unwords ["reshapeInner", show sc, show n, show shape, "==", show sc_res]) $ reshapeInner (intShape sc) n (intShape shape) @?= intShape sc_res- | (sc, n, shape, sc_res) <-- [ ([1], 1, [4, 3], [4, 1]),- ([1], 0, [4, 3], [1]),- ([2, 2], 1, [4, 3], [4, 2, 2]),- ([2, 2], 0, [4, 3], [2, 2])- ]+ | (sc, n, shape, sc_res) <-+ [ ([1], 1, [4, 3], [4, 1]),+ ([1], 0, [4, 3], [1]),+ ([2, 2], 1, [4, 3], [4, 2, 2]),+ ([2, 2], 0, [4, 3], [2, 2])+ ] ] dimFlatten :: Int -> Int -> d -> DimSplice d@@ -63,33 +63,33 @@ ] ) $ flipReshapeRearrange v0_shape v1_shape perm @?= res- | (v0_shape :: [String], v1_shape, perm, res) <-- [ ( ["A", "B", "C"],- ["A", "BC"],- [1, 0],- Just [1, 2, 0]- ),- ( ["A", "B", "C", "D"],- ["A", "BCD"],- [1, 0],- Just [1, 2, 3, 0]- ),- ( ["A"],- ["B", "C"],- [1, 0],- Nothing- ),- ( ["A", "B", "C"],- ["AB", "C"],- [1, 0],- Just [2, 0, 1]- ),- ( ["A", "B", "C", "D"],- ["ABC", "D"],- [1, 0],- Just [3, 0, 1, 2]- )- ]+ | (v0_shape :: [String], v1_shape, perm, res) <-+ [ ( ["A", "B", "C"],+ ["A", "BC"],+ [1, 0],+ Just [1, 2, 0]+ ),+ ( ["A", "B", "C", "D"],+ ["A", "BCD"],+ [1, 0],+ Just [1, 2, 3, 0]+ ),+ ( ["A"],+ ["B", "C"],+ [1, 0],+ Nothing+ ),+ ( ["A", "B", "C"],+ ["AB", "C"],+ [1, 0],+ Just [2, 0, 1]+ ),+ ( ["A", "B", "C", "D"],+ ["ABC", "D"],+ [1, 0],+ Just [3, 0, 1, 2]+ )+ ] ] flipRearrangeReshapeTests :: [TestTree]@@ -102,25 +102,25 @@ ] ) $ flipRearrangeReshape perm newshape @?= res- | (perm, newshape :: NewShape String, res) <-- [ ( [1, 0],- NewShape- [dimUnflatten 1 ["B", "C"]]- (Shape ["A", "B", "C"]),- Just- ( NewShape- [dimUnflatten 0 ["B", "C"]]- (Shape ["B", "C", "A"]),- [2, 0, 1]- )- ),- ( [1, 0],- NewShape- [dimFlatten 0 2 "AB"]- (Shape ["AB"]),- Nothing- )- ]+ | (perm, newshape :: NewShape String, res) <-+ [ ( [1, 0],+ NewShape+ [dimUnflatten 1 ["B", "C"]]+ (Shape ["A", "B", "C"]),+ Just+ ( NewShape+ [dimUnflatten 0 ["B", "C"]]+ (Shape ["B", "C", "A"]),+ [2, 0, 1]+ )+ ),+ ( [1, 0],+ NewShape+ [dimFlatten 0 2 "AB"]+ (Shape ["AB"]),+ Nothing+ )+ ] ] simplifyTests :: TestTree
src-testing/Language/Futhark/PrimitiveTests.hs view
@@ -23,7 +23,7 @@ "propPrimValuesHaveRightTypes" [ testCase (show t ++ " has blank of right type") $ primValueType (blankPrimValue t) @?= t- | t <- [minBound .. maxBound]+ | t <- [minBound .. maxBound] ] instance Arbitrary IntType where
src/Futhark/AD/Rev.hs view
@@ -206,6 +206,9 @@ adj_t <- lookupType adj adj_i <- letExp "updateacc_val_adj" $ BasicOp $ Index adj $ fullSlice adj_t $ map DimFix is updateSubExpAdj v adj_i+ --+ UserParam {} ->+ void $ commonBasicOp pat aux e m vjpOps :: VjpOps vjpOps =@@ -277,7 +280,7 @@ ( pure . takeLast (length branches_free) <=< letTupExp "branch_adj" <=< renameExp- )+ ) =<< eMatch ses (map (fmap $ diffBody adjs branches_free) cases)
src/Futhark/AD/Rev/Loop.hs view
@@ -3,7 +3,6 @@ module Futhark.AD.Rev.Loop (diffLoop, stripmineStms) where import Control.Monad-import Data.Foldable (toList) import Data.List ((\\)) import Data.Map qualified as M import Data.Maybe@@ -333,7 +332,7 @@ (i_subst, i_stms) <- reverseIndices loop' val_pat_adjs <- valPatAdjs loop_vnames- let val_pat_adjs_list = concat $ toList val_pat_adjs+ let val_pat_adjs_list = concat val_pat_adjs (loop_adjs, stms_adj) <- collectStms $ localScope (scopeOfLoopForm form' <> scopeOfFParams (map fst val_pat_adjs_list <> loop_params')) $ do@@ -343,7 +342,7 @@ zipWithM_ (\val_pat v -> insAdj v (paramName $ fst val_pat)) val_pat_adjs_list- (concat $ toList loop_vnames)+ (concat loop_vnames) diffStms $ bodyStms body' loop_res_adjs <- mapM (lookupAdjVal . paramName) loop_params'@@ -364,7 +363,7 @@ inScopeOf stms_adj $ localScope (scopeOfFParams $ map fst val_pat_adjs_list) $ do- let body_adj = mkBody stms_adj $ varsRes $ concat $ toList loop_adjs+ let body_adj = mkBody stms_adj $ varsRes $ concat loop_adjs restore_true_deps = M.fromList $ flip mapMaybe (zip loop_params' $ patElems pat) $ \(p, pe) -> if p `elem` filter (inAttrs (AttrName "true_dep") . paramAttrs) loop_params'
src/Futhark/AD/Rev/Monad.hs view
@@ -56,7 +56,6 @@ import Control.Monad import Control.Monad.State.Strict import Data.Bifunctor (second)-import Data.List (foldl') import Data.Map qualified as M import Data.Maybe import Futhark.Analysis.Alias qualified as Alias
src/Futhark/AD/Rev/Scan.hs view
@@ -343,8 +343,7 @@ nm1 <- toSubExp "n_minus_one" $ pe64 w - 1 pure $ BasicOp $ CmpOp (CmpSlt Int64) (Var $ paramName par_i) nm1 )- ( buildBody_ $ (\x -> [subExpRes x]) <$> (letSubExp "val" =<< eIndex arr [toExp $ le64 (paramName par_i) + 1])- )+ (buildBody_ $ (\x -> [subExpRes x]) <$> (letSubExp "val" =<< eIndex arr [toExp $ le64 (paramName par_i) + 1])) (buildBody_ $ pure [subExpRes arr_e]) pure $ varRes a_lift @@ -359,11 +358,9 @@ a_lift <- letExp "y_right" =<< eIf- ( pure $ BasicOp $ CmpOp (CmpEq int64) (Var $ paramName par_i) (constant (0 :: Int64))- )+ (pure $ BasicOp $ CmpOp (CmpEq int64) (Var $ paramName par_i) (constant (0 :: Int64))) (buildBody_ $ pure [subExpRes arr_e])- ( buildBody_ $ (\x -> [subExpRes x]) <$> (letSubExp "val" =<< eIndex arr [toExp $ le64 (paramName par_i) - 1])- )+ (buildBody_ $ (\x -> [subExpRes x]) <$> (letSubExp "val" =<< eIndex arr [toExp $ le64 (paramName par_i) - 1])) pure $ varRes a_lift iota <- letExp "iota" $ BasicOp $ Iota w (intConst Int64 0) (intConst Int64 1) Int64
src/Futhark/Analysis/AccessPattern.hs view
@@ -488,6 +488,7 @@ concatVariableInfos (oneName name) (lsubexprs ++ rsubexprs) FlatIndex name _ -> varInfoFromNames ctx $ oneName name FlatUpdate name _ source -> varInfoFromNames ctx $ namesFromList [name, source]+ UserParam _name def -> varInfoFromSubExp def ctx' = foldl' extend ctx $ map (`oneContext` ctx_val) pats in (ctx', mempty) where@@ -688,7 +689,7 @@ Nothing -> True Just n -> length (dependencies dim_access) == 1 && n == head (map fst $ M.toList $ dependencies dim_access)- -- Only print the original name if it is different from the first (and single) dependency+ -- Only print the original name if it is different from the first (and single) dependency then "dependencies" <+> equals
src/Futhark/Analysis/CallGraph.hs view
@@ -12,7 +12,6 @@ where import Control.Monad.Writer.Strict-import Data.List (foldl') import Data.Map.Strict qualified as M import Data.Maybe (isJust) import Data.Set qualified as S
src/Futhark/Analysis/HORep/SOAC.hs view
@@ -442,7 +442,7 @@ let accrtps = take (length nes) $ lambdaReturnType lam arrtps = [ arrayOf (stripArray 1 t) (Shape [w]) NoUniqueness- | t <- drop (length nes) (lambdaReturnType lam)+ | t <- drop (length nes) (lambdaReturnType lam) ] in accrtps ++ arrtps typeOf (Screma w _ form) =
src/Futhark/Analysis/Metrics.hs view
@@ -50,7 +50,7 @@ where expand (ctx, k) = [ (T.intercalate "/" (ctx' ++ [k]), 1)- | ctx' <- tails $ "" : ctx+ | ctx' <- tails $ "" : ctx ] -- | This monad is used for computing metrics. It internally keeps@@ -142,6 +142,7 @@ basicOpMetrics Reshape {} = seen "Reshape" basicOpMetrics Rearrange {} = seen "Rearrange" basicOpMetrics UpdateAcc {} = seen "UpdateAcc"+basicOpMetrics UserParam {} = seen "UserParam" -- | Compute metrics for this lambda. lambdaMetrics :: (OpMetrics (Op rep)) => Lambda rep -> MetricsM ()
src/Futhark/Analysis/SymbolTable.hs view
@@ -56,7 +56,7 @@ import Control.Arrow ((&&&)) import Control.Monad-import Data.List (elemIndex, foldl')+import Data.List (elemIndex) import Data.Map.Strict qualified as M import Data.Maybe import Data.Ord
src/Futhark/CLI/Bench.hs view
@@ -8,9 +8,9 @@ import Data.ByteString.Char8 qualified as SBS import Data.ByteString.Lazy.Char8 qualified as LBS import Data.Either-import Data.Function ((&))+import Data.Function (on, (&)) import Data.IORef-import Data.List (intersect, sortBy)+import Data.List (groupBy, intersect, sortBy) import Data.Map qualified as M import Data.Maybe import Data.Ord@@ -96,6 +96,19 @@ optTestSpec = Nothing } +combineDuplicates :: [BenchResult] -> [BenchResult]+combineDuplicates =+ mapMaybe f+ . groupBy ((==) `on` benchResultProg)+ . sortBy (comparing benchResultProg)+ where+ f [] = Nothing+ f (x : xs) =+ Just $+ BenchResult (benchResultProg x) $+ concatMap benchResultResults $+ x : xs+ runBenchmarks :: BenchOptions -> [FilePath] -> IO () runBenchmarks opts paths = do -- We force line buffering to ensure that we produce running output.@@ -134,7 +147,10 @@ let results = concat $ catMaybes maybe_results case optJSON opts of Nothing -> pure ()- Just file -> LBS.writeFile file $ encodeBenchResults results+ Just file ->+ LBS.writeFile file $+ encodeBenchResults $+ combineDuplicates results when (any isNothing maybe_results || anyFailed results) exitFailure where ignored f = any (`match` f) $ optIgnoreFiles opts@@ -173,8 +189,7 @@ RunCases cases _ _ | null $ optExcludeCase opts- `intersect` testTags spec- <> testTags program_spec,+ `intersect` (testTags spec <> testTags program_spec), any hasRuns cases -> if optSkipCompilation opts then do
src/Futhark/CLI/Doc.hs view
@@ -27,7 +27,7 @@ import Text.Blaze.Html.Renderer.Text cssFile :: T.Text-cssFile = $(embedStringFile "rts/futhark-doc/style.css")+cssFile = $(embedStringFile "rts/style.css") data DocConfig = DocConfig { docOutput :: Maybe FilePath,
src/Futhark/CLI/LSP.hs view
@@ -14,6 +14,23 @@ type (|?) (InR), ) import Language.LSP.Server+ ( Options (optTextDocumentSync),+ ServerDefinition+ ( ServerDefinition,+ configSection,+ defaultConfig,+ doInitialize,+ interpretHandler,+ onConfigChange,+ options,+ parseConfig,+ staticHandlers+ ),+ defaultOptions,+ runLspT,+ runServer,+ type (<~>) (Iso),+ ) -- | Run @futhark lsp@ main :: String -> [String] -> IO ()@@ -39,7 +56,7 @@ syncOptions :: TextDocumentSyncOptions syncOptions = TextDocumentSyncOptions- { _openClose = Just False,+ { _openClose = Just True, _change = Just TextDocumentSyncKind_Incremental, _willSave = Just False, _willSaveWaitUntil = Just False,
src/Futhark/CLI/Main.hs view
@@ -96,7 +96,7 @@ unlines $ ["<command> options...", "Commands:", ""] ++ [ " " <> cmd <> replicate (k - length cmd) ' ' <> desc- | (cmd, (_, desc)) <- commands+ | (cmd, (_, desc)) <- commands ] where k = maxinum (map (length . fst) commands) + 3
src/Futhark/CLI/Pkg.hs view
@@ -415,7 +415,7 @@ usageMsg . T.unlines $ ["<command> ...:", "", "Commands:"] ++ [ " " <> T.pack cmd <> T.pack (replicate (k - length cmd) ' ') <> desc- | (cmd, (_, desc)) <- commands+ | (cmd, (_, desc)) <- commands ] mainWithOptions () [] usage bad prog args
src/Futhark/CLI/Profile.hs view
@@ -1,20 +1,59 @@ -- | @futhark profile@ module Futhark.CLI.Profile (main) where +import Control.Arrow ((&&&), (>>>)) import Control.Exception (catch)+import Control.Monad (forM_, (>=>))+import Control.Monad.Except (ExceptT, liftEither, runExcept, runExceptT)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (Except)+import Data.Bifunctor (first, second) import Data.ByteString.Lazy.Char8 qualified as BS+import Data.Foldable (toList)+import Data.Function ((&)) import Data.List qualified as L import Data.Map qualified as M+import Data.Monoid (Sum (..))+import Data.Sequence qualified as Seq+import Data.Set qualified as S import Data.Text qualified as T+import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T+import Data.Text.Lazy qualified as LT+import Data.Text.Lazy.IO qualified as LT import Futhark.Bench+ ( BenchResult (BenchResult, benchResultProg),+ DataResult (DataResult),+ ProfilingEvent (ProfilingEvent),+ ProfilingReport (profilingEvents, profilingMemory),+ Result (report, stdErr),+ decodeBenchResults,+ decodeProfilingReport,+ )+import Futhark.Profile.Details (CostCentreDetails (CostCentreDetails), CostCentreName (CostCentreName), CostCentres, SourceRangeDetails (SourceRangeDetails), SourceRanges, containingCostCentres)+import Futhark.Profile.EventSummary qualified as ES+import Futhark.Profile.Html (generateCCOverviewHtml, generateHeatmapHtml, generateHtmlIndex, securedHashPath)+import Futhark.Profile.SourceRange (SourceRange)+import Futhark.Profile.SourceRange qualified as SR import Futhark.Util (showText)-import Futhark.Util.Options+import Futhark.Util.Html (cssFile)+import Futhark.Util.Options (mainWithOptions) import System.Directory (createDirectoryIfMissing, removePathForcibly)-import System.Exit+import System.Exit (ExitCode (ExitFailure), exitWith) import System.FilePath-import System.IO-import Text.Printf+ ( dropExtension,+ makeRelative,+ splitPath,+ takeDirectory,+ takeFileName,+ (-<.>),+ (<.>),+ (</>),+ )+import System.IO (hPutStrLn, stderr)+import Text.Blaze.Html.Renderer.Text qualified as H+import Text.Blaze.Html5 qualified as H+import Text.Printf (printf) commonPrefix :: (Eq e) => [e] -> [e] -> [e] commonPrefix _ [] = []@@ -38,36 +77,43 @@ padLeft :: Int -> T.Text -> T.Text padLeft k s = T.replicate (k - T.length s) " " <> s -data EvSummary = EvSummary- { evCount :: Integer,- evSum :: Double,- evMin :: Double,- evMax :: Double- }--tabulateEvents :: [ProfilingEvent] -> T.Text-tabulateEvents = mkRows . M.toList . M.fromListWith comb . map pair+tabulateEvents :: M.Map (T.Text, T.Text) ES.EvSummary -> T.Text+tabulateEvents = mkRows . M.toList where- pair (ProfilingEvent name dur _ _details) = (name, EvSummary 1 dur dur dur)- comb (EvSummary xn xdur xmin xmax) (EvSummary yn ydur ymin ymax) =- EvSummary (xn + yn) (xdur + ydur) (min xmin ymin) (max xmax ymax) numpad = 15 mkRows rows =- let longest = foldl max numpad $ map (T.length . fst) rows- total = sum $ map (evSum . snd) rows+ let longest = foldl max numpad $ map (T.length . fst . fst) rows+ total = sum $ map (ES.evSum . snd) rows header = headerRow longest splitter = T.map (const '-') header- bottom =+ eventSummary = T.unwords- [ showText (sum (map (evCount . snd) rows)),+ [ showText (sum (map (ES.evCount . snd) rows)), "events with a total runtime of", T.pack $ printf "%.2fμs" total ]+ costCentreSources =+ let costCentreSourceBlocks =+ map (costCentreSourceLines . fst)+ . L.sortOn (fst . fst)+ $ rows+ costCentreHeaderTitle = " Cost Centre Source Locations "+ costCentreHeader = T.center (T.length header) '=' costCentreHeaderTitle+ in concat $+ [costCentreHeader, T.empty]+ : L.intersperse [T.empty] costCentreSourceBlocks+ costCentreSourceLines (name, provenance) =+ let sources = T.splitOn "->" provenance+ orderedSources = L.sort sources+ in name+ : map ("- " <>) orderedSources in T.unlines $ header : splitter- : map (mkRow longest total) rows- <> [splitter, bottom]+ : map (mkRow longest total . first fst) rows+ <> [splitter, eventSummary]+ <> replicate 5 T.empty+ <> costCentreSources headerRow longest = T.unwords [ padLeft longest "Cost centre",@@ -81,12 +127,12 @@ mkRow longest total (name, ev) = T.unwords [ padRight longest name,- padLeft numpad (showText (evCount ev)),- padLeft numpad $ T.pack $ printf "%.2fμs" (evSum ev),- padLeft numpad $ T.pack $ printf "%.2fμs" $ evSum ev / fromInteger (evCount ev),- padLeft numpad $ T.pack $ printf "%.2fμs" (evMin ev),- padLeft numpad $ T.pack $ printf "%.2fμs" (evMax ev),- padLeft numpad $ T.pack $ printf "%.4f" (evSum ev / total)+ padLeft numpad (showText (ES.evCount ev)),+ padLeft numpad $ T.pack $ printf "%.2fμs" (ES.evSum ev),+ padLeft numpad $ T.pack $ printf "%.2fμs" $ ES.evSum ev / fromInteger (ES.evCount ev),+ padLeft numpad $ T.pack $ printf "%.2fμs" (ES.evMin ev),+ padLeft numpad $ T.pack $ printf "%.2fμs" (ES.evMax ev),+ padLeft numpad $ T.pack $ printf "%.4f" (ES.evSum ev / total) ] timeline :: [ProfilingEvent] -> T.Text@@ -100,18 +146,247 @@ data TargetFiles = TargetFiles { summaryFile :: FilePath,- timelineFile :: FilePath+ timelineFile :: FilePath,+ htmlIndexFile :: FilePath,+ htmlDir :: FilePath } writeAnalysis :: TargetFiles -> ProfilingReport -> IO ()-writeAnalysis tf r = do- T.writeFile (summaryFile tf) $- memoryReport (profilingMemory r)- <> "\n\n"- <> tabulateEvents (profilingEvents r)- T.writeFile (timelineFile tf) $- timeline (profilingEvents r)+writeAnalysis tf r = runExceptT >=> handleException $ do+ let evSummaryMap = ES.eventSummaries $ profilingEvents r + -- heatmap html and cost centres+ writeHtml tf evSummaryMap++ -- profile.summary+ liftIO $+ T.writeFile (summaryFile tf) $+ memoryReport (profilingMemory r)+ <> "\n\n"+ <> tabulateEvents evSummaryMap++ -- profile.timeline+ liftIO $+ T.writeFile (timelineFile tf) $+ timeline (profilingEvents r)+ where+ handleException :: Either T.Text () -> IO ()+ handleException = either (T.hPutStrLn stderr) pure++toIOExcept :: Except T.Text a -> ExceptT T.Text IO a+toIOExcept = liftEither . runExcept++writeHtml ::+ -- | Target paths+ TargetFiles ->+ -- | mapping keys are (name, provenance)+ M.Map (T.Text, T.Text) ES.EvSummary ->+ ExceptT T.Text IO ()+writeHtml tf evSummaryMap = do+ let htmlDirPath = htmlDir tf+ let htmlIndexPath = htmlIndexFile tf+ (sourceRanges, costCentres) <- toIOExcept $ buildDetailStructures evSummaryMap+ htmlFiles <- generateHtmlHeatmaps sourceRanges+ let costCentreOverview = generateCCOverviewHtml costCentres++ liftIO $ do+ -- create the bench.html/ directory+ createDirectoryIfMissing True htmlDirPath+ -- style is needed by both cc-overview and source ranges+ let cssPath = htmlDirPath </> "style.css"+ T.writeFile cssPath cssFile++ -- index file+ let relHtmlDirPath = last $ splitPath htmlDirPath+ LT.writeFile+ htmlIndexPath+ (H.renderHtml $ generateHtmlIndex relHtmlDirPath sourceRanges costCentres)++ -- cost centre file+ LT.writeFile+ (htmlDirPath </> "cost-centres.html")+ (H.renderHtml costCentreOverview)++ -- write all the source-heatmap files+ forM_ (M.toList htmlFiles) $ \(srcFilePath, html) -> do+ let absPath =+ htmlDirPath </> makeRelative "/" (srcFilePath <> ".html")+ writeLazyTextFile absPath (H.renderHtml html)++writeLazyTextFile :: FilePath -> LT.Text -> IO ()+writeLazyTextFile filepath content = do+ createDirectoryIfMissing True $ takeDirectory filepath+ LT.writeFile filepath content++generateHtmlHeatmaps ::+ M.Map FilePath SourceRanges ->+ ExceptT T.Text IO (M.Map FilePath H.Html)+generateHtmlHeatmaps fileToRanges = do+ sourceFiles <- loadAllFiles (M.keys fileToRanges)+ let disambiguatedSourceFiles =+ M.mapKeys (securedHashPath &&& id) sourceFiles+ let renderSingle (targetPath, oldPath) text =+ generateHeatmapHtml targetPath oldPath text (fileToRanges M.! oldPath)+ pure $+ M.mapWithKey renderSingle disambiguatedSourceFiles+ & M.mapKeys fst++buildDetailStructures ::+ -- | mapping keys are: (name, provenance)+ M.Map (T.Text, T.Text) ES.EvSummary ->+ -- | mapping key is the filename+ Except T.Text (M.Map FilePath SourceRanges, CostCentres)+buildDetailStructures evSummaries = do+ parsedEvSummaries <- parseEvSummaries evSummaries+ pure $+ let ranges = buildSourceRanges parsedEvSummaries lookupCC+ centres = buildCostCentres parsedEvSummaries ccToRanges+ lookupCC = (centres M.!)+ ccToRanges :: CostCentreName -> M.Map SourceRange SourceRangeDetails+ ccToRanges ccName =+ M.unions ranges+ & M.filter (M.member ccName . containingCostCentres)+ in (ranges, centres)++buildCostCentres ::+ M.Map (CostCentreName, Seq.Seq SourceRange) ES.EvSummary ->+ (CostCentreName -> M.Map SourceRange SourceRangeDetails) ->+ CostCentres+buildCostCentres summaries rangesInCC =+ let totalTime = getSum $ foldMap (Sum . ES.evSum) summaries+ makeDetails ((name, _), summary) =+ CostCentreDetails fraction ranges summary+ where+ fraction = ES.evSum summary / totalTime+ ranges = rangesInCC name+ in M.toList summaries+ & fmap (fst . fst &&& makeDetails)+ & M.fromList++buildSourceRanges ::+ M.Map (CostCentreName, Seq.Seq SourceRange) ES.EvSummary ->+ (CostCentreName -> CostCentreDetails) ->+ M.Map FilePath SourceRanges+buildSourceRanges summaries lookupCC =+ let distributeRanges ::+ (CostCentreName, Seq.Seq SourceRange) ->+ S.Set (CostCentreName, SourceRange)+ distributeRanges (name, ranges) =+ toList ranges+ & fmap (name,)+ & S.fromList++ distributedRanges =+ M.keysSet summaries+ & S.map distributeRanges+ & S.unions++ rangeToCCs = summarizeAndSplitRanges distributedRanges+ fileToRangeToCCs =+ fmap prepareElement (M.toList rangeToCCs)+ & M.fromListWith M.union+ where+ prepareElement =+ second (uncurry M.singleton)+ . (\(range, ccs) -> (SR.fileName range, (range, ccs)))++ ccsToDetails =+ toList+ >>> fmap (id &&& lookupCC)+ >>> M.fromList+ >>> SourceRangeDetails+ in fmap (fmap ccsToDetails) fileToRangeToCCs++parseEvSummaries ::+ M.Map (T.Text, T.Text) ES.EvSummary ->+ Except T.Text (M.Map (CostCentreName, Seq.Seq SourceRange) ES.EvSummary)+parseEvSummaries evSummaries =+ let parseKey (ccName, sourceLocs) v =+ let ccName' = CostCentreName ccName+ in do+ sourceRanges <- splitParseSourceLocs sourceLocs+ pure ((ccName', sourceRanges), v)+ in M.toList evSummaries+ & traverse (uncurry parseKey)+ & fmap M.fromList++splitParseSourceLocs :: T.Text -> Except T.Text (Seq.Seq SourceRange)+splitParseSourceLocs t =+ if t == "unknown"+ then pure Seq.empty+ else fmap Seq.fromList $ traverse (liftEither . SR.parse) $ T.splitOn "->" t++summarizeAndSplitRanges ::+ -- | Mapping from (ccName, ccProvenance) to event summary+ S.Set (CostCentreName, SR.SourceRange) ->+ -- | Non-Overlapping Events with SourceRanges separated by file+ -- invariant: sourcerange.rangeStartPos.file is always equal to the map key+ M.Map SR.SourceRange (Seq.Seq CostCentreName)+summarizeAndSplitRanges summaries =+ let separateSourceRanges ::+ -- \| All possibly overlapping SourceRanges+ Seq.Seq (SR.SourceRange, CostCentreName) ->+ -- \| Ordered non-overlapping sourceranges with merged attached informations+ M.Map SR.SourceRange (Seq.Seq CostCentreName)+ separateSourceRanges = L.foldl' accumulateRange M.empty . fmap (second Seq.singleton)+ where+ accumulateRange ::+ -- \| Mapping of non-overlapping ranges, the T.Text is a ccName+ M.Map SR.SourceRange (Seq.Seq CostCentreName) ->+ -- \| New SourceRange that must be merged and inserted+ (SR.SourceRange, Seq.Seq CostCentreName) ->+ -- \| Mapping of non-overlapping ranges+ M.Map SR.SourceRange (Seq.Seq CostCentreName)+ accumulateRange ranges (range, aux) = case M.lookupLE range ranges of+ -- there is no lower range+ Nothing -> case M.lookupGE range ranges of+ -- there is no higher range+ Nothing -> M.insert range aux ranges -- nothing to merge at all++ -- higher ranges was found+ Just higher@(higherRange, _) ->+ if range `SR.overlapsWith` higherRange+ then+ let mergedRanges = SR.mergeSemigroup (range, aux) higher+ rangesWithoutHigher = M.delete higherRange ranges+ in foldl accumulateRange rangesWithoutHigher mergedRanges+ -- ranges don't overlap, don't merge+ else M.insert range aux ranges+ -- lower range was found+ Just lower@(lowerRange, _) ->+ if range `SR.overlapsWith` lowerRange+ then+ let mergedRanges = SR.mergeSemigroup (range, aux) lower+ rangesWithoutLower = M.delete lowerRange ranges+ in foldl accumulateRange rangesWithoutLower mergedRanges+ -- lower range does not overlap+ else case M.lookupGE range ranges of -- check the higher bound+ -- nothing to merge+ Nothing -> M.insert range aux ranges+ -- higher range was found+ Just higher@(higherRange, _) ->+ if range `SR.overlapsWith` higherRange+ then+ let mergedRanges = SR.mergeSemigroup (range, aux) higher+ rangesWithoutHigher = M.delete higherRange ranges+ in foldl accumulateRange rangesWithoutHigher mergedRanges+ -- just insert the range normally+ else M.insert range aux ranges+ in S.toList summaries+ & fmap (uncurry $ flip (,))+ & Seq.fromList+ & separateSourceRanges++loadAllFiles :: [FilePath] -> ExceptT T.Text IO (M.Map FilePath T.Text)+loadAllFiles files =+ mapM (\path -> (path,) <$> tryLoadFile path) files+ & fmap M.fromList+ where+ tryLoadFile filePath = do+ bytes <- liftIO $ readFileSafely filePath+ bytes' <- liftEither . first T.pack $ bytes+ liftEither . first showText $ T.decodeUtf8' (BS.toStrict bytes')+ prepareDir :: FilePath -> IO FilePath prepareDir json_path = do let top_dir = takeFileName json_path -<.> "prof"@@ -126,7 +401,9 @@ let tf = TargetFiles { summaryFile = top_dir </> "summary",- timelineFile = top_dir </> "timeline"+ timelineFile = top_dir </> "timeline",+ htmlIndexFile = top_dir </> "index",+ htmlDir = top_dir </> "html/" } writeAnalysis tf r @@ -165,7 +442,9 @@ let tf = TargetFiles { summaryFile = name' <> ".summary",- timelineFile = name' <> ".timeline"+ timelineFile = name' <> ".timeline",+ htmlIndexFile = name' <> "-index.html",+ htmlDir = name' <> ".html/" } in writeAnalysis tf r
src/Futhark/CLI/Test.hs view
@@ -477,7 +477,8 @@ excludedTest config = any (`elem` configExclude config) . testTags . testCaseTest --- | Exclude those test cases that have tags we do not wish to run.+-- | Exclude those test cases that have tags we do not wish to run or+-- exclude based on entry point name. excludeCases :: TestConfig -> TestCase -> TestCase excludeCases config tcase = tcase {testCaseTest = onTest $ testCaseTest tcase}@@ -485,10 +486,12 @@ onTest (ProgramTest desc tags action) = ProgramTest desc tags $ onAction action onAction (RunCases ios stest wtest) =- RunCases (map onIOs ios) stest wtest+ RunCases (map onIOs $ filter relevantEntry ios) stest wtest onAction action = action onIOs (InputOutputs entry runs) = InputOutputs entry $ filter (not . any excluded . runTags) runs+ relevantEntry (InputOutputs entry _) =+ maybe True (== T.unpack entry) (configEntryPoint config) excluded = (`elem` configExclude config) putStatusTable :: TestStatus -> IO ()@@ -670,7 +673,8 @@ configPrograms :: ProgConfig, configExclude :: [T.Text], configLineOutput :: Bool,- configConcurrency :: Maybe Int+ configConcurrency :: Maybe Int,+ configEntryPoint :: Maybe String } defaultConfig :: TestConfig@@ -689,7 +693,8 @@ configCacheExt = Nothing }, configLineOutput = False,- configConcurrency = Nothing+ configConcurrency = Nothing,+ configEntryPoint = Nothing } data ProgConfig = ProgConfig@@ -802,6 +807,14 @@ "Pass this option to the compiler (or typechecker if in -t mode).", Option []+ ["tuning"]+ ( ReqArg+ (\s -> Right $ changeProgConfig $ \config -> config {configTuning = Just s})+ "EXTENSION"+ )+ "Look for tuning files with this extension (defaults to .tuning).",+ Option+ [] ["no-tuning"] (NoArg $ Right $ changeProgConfig $ \config -> config {configTuning = Nothing}) "Do not load tuning files.",@@ -827,7 +840,17 @@ ) "NUM" )- "Number of tests to run concurrently."+ "Number of tests to run concurrently.",+ Option+ "e"+ ["entry-point"]+ ( ReqArg+ ( \s -> Right $ \config ->+ config {configEntryPoint = Just s}+ )+ "NAME"+ )+ "Only run entry points with this name." ] excludeBackend :: TestConfig -> TestConfig
src/Futhark/CodeGen/Backends/CCUDA.hs view
@@ -110,14 +110,13 @@ compileProg :: (MonadFreshNames m) => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) compileProg version prog = do ( ws,- Program cuda_code cuda_prelude macros kernels types params failures prog'+ Program cuda_code cuda_prelude macros kernels types failures prog' ) <- ImpGen.compileProg prog (ws,) <$> GC.compileProg "cuda" version- params operations (mkBoilerplate (cuda_prelude <> cuda_code) macros kernels types failures) cuda_includes
src/Futhark/CodeGen/Backends/COpenCL.hs view
@@ -184,14 +184,13 @@ compileProg :: (MonadFreshNames m) => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) compileProg version prog = do ( ws,- Program opencl_code opencl_prelude macros kernels types params failures prog'+ Program opencl_code opencl_prelude macros kernels types failures prog' ) <- ImpGen.compileProg prog (ws,) <$> GC.compileProg "opencl" version- params operations (mkBoilerplate (opencl_prelude <> opencl_code) macros kernels types failures) opencl_includes
src/Futhark/CodeGen/Backends/GPU.hs view
@@ -69,15 +69,19 @@ ] getParamByKey :: Name -> C.Exp-getParamByKey key = [C.cexp|*ctx->tuning_params.$id:key|]+getParamByKey key = [C.cexp|ctx->cfg->tuning_params[tuning_param_indexes.$id:key]|] kernelConstToExp :: KernelConst -> C.Exp kernelConstToExp (SizeConst key _) =- getParamByKey key+ [C.cexp|$exp:(getParamByKey key).val|] kernelConstToExp (SizeMaxConst size_class) = [C.cexp|ctx->$id:field|] where field = "max_" <> prettyString size_class+kernelConstToExp (SizeUserParam name def) =+ [C.cexp|$exp:name'.set ? $exp:name'.val : $exp:def|]+ where+ name' = getParamByKey name compileBlockDim :: BlockDim -> GC.CompilerM op s C.Exp compileBlockDim (Left e) = GC.compileExp e@@ -139,10 +143,10 @@ callKernel :: GC.OpCompiler OpenCL () callKernel (GetSize v key) =- GC.stm [C.cstm|$id:v = $exp:(getParamByKey key);|]+ GC.stm [C.cstm|$id:v = $exp:(getParamByKey key).val;|] callKernel (CmpSizeLe v key x) = do x' <- GC.compileExp x- GC.stm [C.cstm|$id:v = $exp:(getParamByKey key) <= $exp:x';|]+ GC.stm [C.cstm|$id:v = $exp:(getParamByKey key).val <= $exp:x';|] -- Output size information if logging is enabled. The autotuner -- depends on the format of this output, so use caution if changing -- it.
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -39,7 +39,6 @@ import Futhark.CodeGen.Backends.GenericC.Types import Futhark.CodeGen.ImpCode import Futhark.CodeGen.RTS.C (cacheH, contextH, contextPrototypesH, copyH, errorsH, eventListH, freeListH, halfH, lockH, timingH, utilH)-import Futhark.IR.GPU.Sizes import Futhark.Manifest qualified as Manifest import Futhark.MonadFreshNames import Futhark.Util (zEncodeText)@@ -85,6 +84,9 @@ (typename int64_t[]){ $inits:srcstride_inits }, (typename int64_t[]){ $inits:shape_inits });|] +getUserParamByName :: Name -> C.Exp+getUserParamByName name = [C.cexp|ctx->cfg->tuning_params[tuning_param_indexes.$id:name]|]+ -- | A set of operations that fail for every operation involving -- non-default memory spaces. Uses plain pointers and @malloc@ for -- memory management.@@ -102,7 +104,10 @@ opsFatMemory = True, opsError = defError, opsCall = defCall,- opsCritical = mempty+ opsCritical = mempty,+ opsGetParam = \name ->+ let name' = getUserParamByName name+ in ([C.cexp|$exp:name'.val|], [C.cexp|$exp:name'.set|]) } where defWriteScalar _ _ _ _ _ =@@ -362,7 +367,6 @@ (MonadFreshNames m) => T.Text -> T.Text ->- ParamMap -> Operations op s -> s -> CompilerM op s () ->@@ -371,7 +375,7 @@ [Option] -> Definitions op -> m (CParts, CompilerState s)-compileProg' backend version params ops def extra header_extra (arr_space, spaces) options prog = do+compileProg' backend version ops def extra header_extra (arr_space, spaces) options prog = do src <- getNameSource let ((prototypes, definitions, entry_point_decls, manifest), endstate) = runCompilerM ops src def compileProgAction@@ -493,7 +497,7 @@ endstate ) where- Definitions types consts (Functions funs) = prog+ Definitions params types consts (Functions funs) = prog compileProgAction = do (memfuns, memreport) <- mapAndUnzipM defineMemorySpace spaces@@ -522,17 +526,6 @@ generateTuningParams params extra - let set_tuning_params =- zipWith- (\i k -> [C.cstm|ctx->tuning_params.$id:k = &ctx->cfg->tuning_params[$int:i];|])- [(0 :: Int) ..]- $ M.keys params- earlyDecl- [C.cedecl|static void set_tuning_params(struct futhark_context* ctx) {- (void)ctx;- $stms:set_tuning_params- }|]- mapM_ earlyDecl $ concat memfuns type_funs <- generateAPITypes arr_space types @@ -563,7 +556,6 @@ (MonadFreshNames m) => T.Text -> T.Text ->- ParamMap -> Operations op () -> CompilerM op () () -> T.Text ->@@ -571,27 +563,41 @@ [Option] -> Definitions op -> m CParts-compileProg backend version params ops extra header_extra (arr_space, spaces) options prog =- fst <$> compileProg' backend version params ops () extra header_extra (arr_space, spaces) options prog+compileProg backend version ops extra header_extra (arr_space, spaces) options prog =+ fst <$> compileProg' backend version ops () extra header_extra (arr_space, spaces) options prog generateTuningParams :: ParamMap -> CompilerM op a () generateTuningParams params = do- let (param_names, (param_classes, _param_users)) =- second unzip $ unzip $ M.toList params+ let (param_names, (param_classes, _param_users)) = second unzip $ unzip $ M.toList params strinit s = [C.cinit|$string:(T.unpack s)|] intinit x = [C.cinit|$int:x|] size_name_inits = map (strinit . prettyText) param_names size_var_inits = map (strinit . zEncodeText . prettyText) param_names- size_class_inits = map (strinit . prettyText) param_classes- size_default_inits = map (intinit . fromMaybe 0 . sizeDefault) param_classes- size_decls = map (\k -> [C.csdecl|typename int64_t *$id:k;|]) param_names+ size_class_inits = map (strinit . maybe "custom" prettyText) param_classes+ size_default_inits = map (intinit . maybe 0 (fromMaybe 0 . sizeDefault)) param_classes num_params = length params- earlyDecl [C.cedecl|struct tuning_params { int dummy; $sdecls:size_decls };|]- earlyDecl [C.cedecl|static const int num_tuning_params = $int:num_params;|]+ def = "#define NUM_TUNING_PARAMS " <> show num_params++ earlyDecl [C.cedecl|$esc:def|] earlyDecl [C.cedecl|static const char *tuning_param_names[] = { $inits:size_name_inits, NULL };|] earlyDecl [C.cedecl|static const char *tuning_param_vars[] = { $inits:size_var_inits, NULL };|] earlyDecl [C.cedecl|static const char *tuning_param_classes[] = { $inits:size_class_inits, NULL };|] earlyDecl [C.cedecl|static typename int64_t tuning_param_defaults[] = { $inits:size_default_inits, 0 };|]+ -- Produce global constant for each tuning parameter that contain an index+ -- into the array of tuning parameters. This makes it fast to look up the+ -- concrete parameter by name, and is easier than creating an enumeration in+ -- the compiler itself.+ let indexDecl k i =+ ( [C.csdecl|int $id:k;|],+ [C.cinit|$int:i|]+ )+ (index_decls, index_inits) =+ if null param_names+ then ([[C.csdecl|int dummy;|]], [[C.cinit|0|]])+ else unzip $ zipWith indexDecl param_names [0 :: Int ..]+ earlyDecl+ [C.cedecl|static const struct { $sdecls:index_decls } tuning_param_indexes =+ { $inits:index_inits };|] generateCommonLibFuns :: [C.BlockItem] -> CompilerM op s () generateCommonLibFuns memreport = do
src/Futhark/CodeGen/Backends/GenericC/CLI.hs view
@@ -125,10 +125,10 @@ if (equals != NULL) { *equals = 0; if (futhark_context_config_set_tuning_param(cfg, name, (size_t)value) != 0) {- futhark_panic(1, "Unknown size: %s\n", name);+ futhark_panic(1, "Unknown tuning parameter: %s\n", name); } } else {- futhark_panic(1, "Invalid argument for size option: %s\n", optarg);+ futhark_panic(1, "Invalid argument for --parameter option: %s\n", optarg); }}|] }, Option
src/Futhark/CodeGen/Backends/GenericC/Code.hs view
@@ -411,6 +411,9 @@ <*> pure fname <*> mapM compileArg args stms $ mconcat unpack_dest+compileCode (GetUserParam v name def) = do+ (val, set) <- asks (opsGetParam . envOperations) <*> pure name+ stm [C.cstm|$id:v = $exp:set ? $exp:val : $exp:def;|] -- | Compile an 'Copy' using sequential nested loops, but -- parameterised over how to do the reads and writes.
src/Futhark/CodeGen/Backends/GenericC/Monad.hs view
@@ -240,7 +240,9 @@ -- pointers. opsFatMemory :: Bool, -- | Code to bracket critical sections.- opsCritical :: ([C.BlockItem], [C.BlockItem])+ opsCritical :: ([C.BlockItem], [C.BlockItem]),+ -- | An expression for the param value and one for whether it is set.+ opsGetParam :: Name -> (C.Exp, C.Exp) } freeAllocatedMem :: CompilerM op s [C.BlockItem]@@ -273,11 +275,11 @@ gets $ unzip4 . DL.toList . compCtxFields let fields = [ [C.csdecl|$ty:ty $id:name;|]- | (name, ty) <- zip field_names field_types+ | (name, ty) <- zip field_names field_types ] init_fields = [ [C.cstm|ctx->program->$id:name = $exp:e;|]- | (name, Just e) <- zip field_names field_values+ | (name, Just e) <- zip field_names field_values ] (setup, free) = unzip $ catMaybes field_frees pure (fields, init_fields <> setup, free)
src/Futhark/CodeGen/Backends/GenericC/Server.hs view
@@ -83,10 +83,10 @@ if (equals != NULL) { *equals = 0; if (futhark_context_config_set_tuning_param(cfg, name, value) != 0) {- futhark_panic(1, "Unknown size: %s\n", name);+ futhark_panic(1, "Unknown parameter: %s\n", name); } } else {- futhark_panic(1, "Invalid argument for size option: %s\n", optarg);+ futhark_panic(1, "Invalid argument for --parameter option: %s\n", optarg); }}|] }, Option
src/Futhark/CodeGen/Backends/GenericC/Types.hs view
@@ -133,7 +133,7 @@ in_bounds = allTrue [ [C.cexp|$id:p >= 0 && $id:p < arr->shape[$int:i]|]- | (p, i) <- zip index_names [0 .. rank - 1]+ | (p, i) <- zip index_names [0 .. rank - 1] ] index_body <- collect $@@ -547,7 +547,7 @@ in_bounds = allTrue [ [C.cexp|$id:p >= 0 && $id:p < arr->$id:(tupleField 0)->shape[$int:i]|]- | (p, i) <- zip index_names [0 .. rank - 1]+ | (p, i) <- zip index_names [0 .. rank - 1] ] setField copy j (ValueType _ (Rank r) pt)@@ -774,6 +774,19 @@ OpaqueType -> [ValueType] -> CompilerM op s (Maybe Manifest.OpaqueExtraOps)+-- Special-case () as a 0-ary record. It isn't really in the IR, but otherwise+-- we cannot construct them from the outside.+opaqueExtraOps+ _+ types+ "()"+ (OpaqueType [ValueType Signed (Rank 0) Unit])+ [ValueType Signed (Rank 0) Unit] =+ Just . Manifest.OpaqueRecord+ <$> ( Manifest.RecordOps+ <$> recordProjectFunctions types "()" [] []+ <*> recordNewFunctions types "()" [] []+ ) opaqueExtraOps _ _ _ (OpaqueType _) _ = pure Nothing opaqueExtraOps _ _types desc (OpaqueSum _ cs) vds =@@ -1003,7 +1016,10 @@ then [C.csdecl|$ty:ct $id:(tupleField i);|] else [C.csdecl|$ty:ct *$id:(tupleField i);|] -generateAPITypes :: Space -> OpaqueTypes -> CompilerM op s (M.Map T.Text Manifest.Type)+generateAPITypes ::+ Space ->+ OpaqueTypes ->+ CompilerM op s (M.Map T.Text Manifest.Type) generateAPITypes arr_space types@(OpaqueTypes opaques) = do mapM_ (findNecessaryArrays . snd) opaques array_ts <- mapM (generateArray arr_space) . M.toList =<< gets compArrayTypes@@ -1016,8 +1032,8 @@ -- the innards to increment reference counts. findNecessaryArrays (OpaqueType _) = pure ()- findNecessaryArrays (OpaqueArray {}) =- pure ()+ findNecessaryArrays (OpaqueArray _ _ vts) =+ mapM_ (valueTypeToCType Private) vts findNecessaryArrays (OpaqueRecordArray _ _ fs) = mapM_ (entryPointTypeToCType Public . snd) fs findNecessaryArrays (OpaqueSum _ variants) =
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -5,7 +5,6 @@ ( compileProg, CompilerMode, Constructor (..),- emptyConstructor, compileName, compileVar, compileDim,@@ -36,7 +35,9 @@ atInit, collect', collect,+ getParamByKey, simpleCall,+ sizeClassesToPython, ) where @@ -272,7 +273,7 @@ { optionLongName = "tuning", optionShortName = Nothing, optionArgument = RequiredArgument "open",- optionAction = [Exp $ simpleCall "read_tuning_file" [Var "sizes", Var "optarg"]]+ optionAction = [Exp $ simpleCall "read_tuning_file" [Var "user_sizes", Var "optarg"]] }, -- Does not actually do anything for Python backends. Option@@ -369,10 +370,6 @@ -- constructor, although it can be vacuous. data Constructor = Constructor [String] [PyStmt] --- | A constructor that takes no arguments and does nothing.-emptyConstructor :: Constructor-emptyConstructor = Constructor ["self"] [Pass]- constructorToFunDef :: Constructor -> [PyStmt] -> PyFunDef constructorToFunDef (Constructor params body) at_init = Def "__init__" params $ body <> at_init@@ -396,7 +393,7 @@ pure . prettyText . PyProg $ imports ++ [ Import "argparse" Nothing,- Assign (Var "sizes") $ Dict []+ Assign (Var "user_sizes") $ Dict [] ] ++ defines ++ [ Escape valuesPy,@@ -408,7 +405,7 @@ ] ++ prog' where- Imp.Definitions _types consts (Imp.Functions funs) = prog+ Imp.Definitions params _types consts (Imp.Functions funs) = prog compileProg' = withConstantSubsts consts $ do compileConstants consts @@ -416,6 +413,13 @@ at_inits <- gets compInit let constructor' = constructorToFunDef constructor at_inits+ paramAssign (v, (c, _)) =+ ( String (nameToText v),+ Dict+ [ (String "class", String $ maybe "user" prettyText c),+ (String "value", None)+ ]+ ) case mode of ToLibrary -> do@@ -424,11 +428,17 @@ pure [ ClassDef $ Class class_name $- Assign (Var "entry_points") (Dict entry_point_types)- : Assign+ [ Assign+ (Var "entry_points")+ (Dict entry_point_types),+ Assign (Var "opaques")- (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads))- : map FunDef (constructor' : definitions ++ entry_points)+ (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads)),+ Assign+ (Var "sizes")+ (Dict $ map paramAssign $ M.toList params)+ ]+ <> map FunDef (constructor' : definitions ++ entry_points) ] ToServer -> do (entry_points, entry_point_types) <-@@ -437,11 +447,17 @@ parse_options_server ++ [ ClassDef ( Class class_name $- Assign (Var "entry_points") (Dict entry_point_types)- : Assign+ [ Assign+ (Var "entry_points")+ (Dict entry_point_types),+ Assign (Var "opaques")- (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads))- : map FunDef (constructor' : definitions ++ entry_points)+ (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads)),+ Assign+ (Var "sizes")+ (Dict $ map paramAssign $ M.toList params)+ ]+ <> map FunDef (constructor' : definitions ++ entry_points) ), Assign (Var "server")@@ -456,8 +472,10 @@ parse_options_executable ++ ClassDef ( Class class_name $- map FunDef $- constructor' : definitions+ Assign+ (Var "sizes")+ (Dict $ map paramAssign $ M.toList params)+ : map FunDef (constructor' : definitions) ) : classinst : map FunDef entry_point_defs@@ -1248,6 +1266,9 @@ doRead src_i = generateRead src' src_i t srcspace compileCopyWith shape doWrite dst_lmad doRead src_lmad +getParamByKey :: Name -> PyExp+getParamByKey key = Index (Var "self.sizes") (IdxExp $ String $ prettyText key)+ compileCode :: Imp.Code op -> CompilerM op s () compileCode Imp.DebugPrint {} = pure ()@@ -1378,6 +1399,14 @@ src' <- compileVar src stm . Assign x' =<< generateRead src' iexp' pt space compileCode Imp.Skip = pure ()+compileCode (Imp.GetUserParam v name def) = do+ v' <- compileVar v+ def' <- compileExp $ untyped def+ stm $+ If+ (BinOp "==" (Index (getParamByKey name) (IdxExp $ String "value")) None)+ [Assign v' def']+ [Assign v' $ Index (getParamByKey name) (IdxExp $ String "value")] lmadcopyCPU :: DoCopy op s lmadcopyCPU t shape dst (dstoffset, dststride) src (srcoffset, srcstride) =@@ -1391,3 +1420,19 @@ List (map unCount srcstride), List (map unCount shape) ]++sizeClassesToPython :: Imp.ParamMap -> PyExp+sizeClassesToPython = Dict . map f . M.toList+ where+ f (size_name, (size_class, _)) =+ ( String $ prettyText size_name,+ Dict+ [ (String "class", maybe None (String . prettyText) size_class),+ ( String "value",+ maybe+ None+ (maybe None (Integer . fromIntegral) . Imp.sizeDefault)+ size_class+ )+ ]+ )
src/Futhark/CodeGen/Backends/GenericPython/Options.hs view
@@ -82,8 +82,7 @@ executeOption option = For "optarg"- ( Index (Var "parser_result") $ IdxExp $ String $ fieldName option- )+ (Index (Var "parser_result") $ IdxExp $ String $ fieldName option) $ optionAction option fieldName = T.map escape . optionLongName
src/Futhark/CodeGen/Backends/HIP.hs view
@@ -92,14 +92,13 @@ compileProg :: (MonadFreshNames m) => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) compileProg version prog = do ( ws,- Program hip_code hip_prelude macros kernels types params failures prog'+ Program hip_code hip_prelude macros kernels types failures prog' ) <- ImpGen.compileProg prog (ws,) <$> GC.compileProg "hip" version- params operations (mkBoilerplate (hip_prelude <> hip_code) macros kernels types failures) hip_includes
src/Futhark/CodeGen/Backends/MulticoreC.hs view
@@ -50,7 +50,6 @@ ( GC.compileProg "multicore" version- mempty operations generateBoilerplate "#include <pthread.h>\n"@@ -446,6 +445,8 @@ compileOp (ExtractLane dest tar _) = do tar' <- GC.compileExp tar GC.stm [C.cstm|$id:dest = $exp:tar';|]+compileOp (GetError v) =+ GC.stm [C.cstm|$id:v = ctx->error != NULL;|] scopedBlock :: MCCode -> GC.CompilerM Multicore s () scopedBlock code = do@@ -491,6 +492,21 @@ where op :: String op = "__atomic_exchange_n"+atomicOps (AtomicLoad t ret arr ind) castf = do+ ind' <- GC.compileExp $ untyped $ unCount ind+ cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr+ GC.stm [C.cstm|$id:ret = $id:op(&(($ty:cast)$id:arr.mem)[$exp:ind'], __ATOMIC_ACQUIRE);|]+ where+ op :: String+ op = "__atomic_load_n"+atomicOps (AtomicStore t arr ind val) castf = do+ ind' <- GC.compileExp $ untyped $ unCount ind+ val' <- GC.compileExp val+ cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr+ GC.stm [C.cstm|$id:op(&(($ty:cast)$id:arr.mem)[$exp:ind'], $exp:val', __ATOMIC_RELEASE);|]+ where+ op :: String+ op = "__atomic_store_n" atomicOps (AtomicAdd t old arr ind val) castf = doAtomic old arr ind val "__atomic_fetch_add" [C.cty|$ty:(GC.intTypeToCType t)|] castf atomicOps (AtomicSub t old arr ind val) castf =
src/Futhark/CodeGen/Backends/MulticoreISPC.hs view
@@ -71,7 +71,6 @@ ( GC.compileProg' "ispc" version- mempty operations (ISPCState mempty mempty) ( do
src/Futhark/CodeGen/Backends/MulticoreWASM.hs view
@@ -48,7 +48,6 @@ GC.compileProg "wasm_multicore" version- mempty MC.operations generateBoilerplate ""
src/Futhark/CodeGen/Backends/PyOpenCL.hs view
@@ -37,7 +37,6 @@ macros kernels types- sizes failures prog' ) <-@@ -89,9 +88,9 @@ "default_tile_size=default_tile_size", "default_reg_tile_size=default_reg_tile_size", "default_threshold=default_threshold",- "sizes=sizes"+ "user_sizes=user_sizes" ]- [Escape $ openClInit macros types assign sizes failures]+ [Escape $ openClInit macros types assign (Imp.defParams prog') failures] options = [ Option { optionLongName = "platform",@@ -204,14 +203,17 @@ asLong :: PyExp -> PyExp asLong x = simpleCall "np.int64" [x] -getParamByKey :: Name -> PyExp-getParamByKey key = Index (Var "self.sizes") (IdxExp $ String $ prettyText key)- kernelConstToExp :: Imp.KernelConst -> PyExp kernelConstToExp (Imp.SizeConst key _) =- getParamByKey key+ Index (getParamByKey key) (IdxExp (String "value")) kernelConstToExp (Imp.SizeMaxConst size_class) = Var $ "self.max_" <> prettyString size_class+kernelConstToExp (Imp.SizeUserParam name def) =+ Call+ (Field (Var "self.user_params") "get")+ [ Arg $ String (nameToText name),+ Arg $ Var $ compileName def+ ] compileConstExp :: Imp.KernelConstExp -> PyExp compileConstExp e = runIdentity $ compilePrimExp (pure . kernelConstToExp) e@@ -223,11 +225,11 @@ callKernel :: OpCompiler Imp.OpenCL () callKernel (Imp.GetSize v key) = do v' <- compileVar v- stm $ Assign v' $ getParamByKey key+ stm $ Assign v' $ Index (getParamByKey key) (IdxExp (String "value")) callKernel (Imp.CmpSizeLe v key x) = do v' <- compileVar v x' <- compileExp x- stm $ Assign v' $ BinOp "<=" (getParamByKey key) x'+ stm $ Assign v' $ BinOp "<=" (Index (getParamByKey key) (IdxExp (String "value"))) x' callKernel (Imp.GetSizeMax v size_class) = do v' <- compileVar v stm $ Assign v' $ kernelConstToExp $ Imp.SizeMaxConst size_class
src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs view
@@ -7,7 +7,6 @@ where import Control.Monad.Identity-import Data.Map qualified as M import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericPython qualified as Py import Futhark.CodeGen.Backends.GenericPython.AST@@ -20,7 +19,6 @@ ParamMap, PrimType (..), errorMsgArgTypes,- sizeDefault, untyped, ) import Futhark.CodeGen.OpenCL.Heuristics@@ -31,16 +29,25 @@ errorMsgNumArgs = length . errorMsgArgTypes getParamByKey :: Name -> PyExp-getParamByKey key = Index (Var "self.sizes") (IdxExp $ String $ prettyText key)+getParamByKey key =+ Index+ (Index (Var "self.sizes") (IdxExp $ String $ prettyText key))+ (IdxExp $ String "value") +compileConstExp :: KernelConstExp -> PyExp+compileConstExp e = runIdentity $ Py.compilePrimExp (pure . kernelConstToExp) e+ kernelConstToExp :: KernelConst -> PyExp kernelConstToExp (SizeConst key _) = getParamByKey key kernelConstToExp (SizeMaxConst size_class) = Var $ "self.max_" <> prettyString size_class--compileConstExp :: KernelConstExp -> PyExp-compileConstExp e = runIdentity $ Py.compilePrimExp (pure . kernelConstToExp) e+kernelConstToExp (SizeUserParam name def) =+ Call+ (Field (Var "self.user_params") "get")+ [ Arg $ String (nameToText name),+ Arg $ Var $ Py.compileName def+ ] -- | Python code (as a string) that calls the -- @initiatialize_opencl_object@ procedure. Should be put in the@@ -66,7 +73,7 @@ default_threshold=default_threshold, size_heuristics=size_heuristics, required_types=$types',- user_sizes=sizes,+ user_sizes=user_sizes, all_sizes=$sizes', constants=constants) $assign'@@ -75,7 +82,7 @@ assign' = T.pack assign size_heuristics = prettyText $ sizeHeuristicsToPython sizeHeuristicsTable types' = prettyText $ map (show . prettyString) types -- Looks enough like Python.- sizes' = prettyText $ sizeClassesToPython sizes+ sizes' = prettyText $ Py.sizeClassesToPython sizes max_num_args = prettyText $ foldl max 0 $ map (errorMsgNumArgs . failureError) failures failure_msgs = prettyText $ List $ map formatFailure failures onConstant (name, e) =@@ -97,20 +104,6 @@ onPart (ErrorString s) = formatEscape $ T.unpack s onPart ErrorVal {} = "{}"--sizeClassesToPython :: ParamMap -> PyExp-sizeClassesToPython = Dict . map f . M.toList- where- f (size_name, (size_class, _)) =- ( String $ prettyText size_name,- Dict- [ (String "class", String $ prettyText size_class),- ( String "value",- maybe None (Integer . fromIntegral) $- sizeDefault size_class- )- ]- ) sizeHeuristicsToPython :: [SizeHeuristic] -> PyExp sizeHeuristicsToPython = List . map f
src/Futhark/CodeGen/Backends/SequentialC.hs view
@@ -26,7 +26,6 @@ ( GC.compileProg "c" version- mempty operations generateBoilerplate mempty
src/Futhark/CodeGen/Backends/SequentialPython.hs view
@@ -4,36 +4,35 @@ ) where -import Control.Monad import Data.Text qualified as T-import Futhark.CodeGen.Backends.GenericPython qualified as GenericPython+import Futhark.CodeGen.Backends.GenericPython qualified as Py import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.CodeGen.ImpCode.Sequential qualified as Imp import Futhark.CodeGen.ImpGen.Sequential qualified as ImpGen-import Futhark.IR.SeqMem+import Futhark.IR.SeqMem (Prog, SeqMem) import Futhark.MonadFreshNames -- | Compile the program to Python. compileProg :: (MonadFreshNames m) =>- GenericPython.CompilerMode ->+ Py.CompilerMode -> String -> Prog SeqMem -> m (ImpGen.Warnings, T.Text)-compileProg mode class_name =- ImpGen.compileProg- >=> traverse- ( GenericPython.compileProg- mode- class_name- GenericPython.emptyConstructor- imports- defines- operations- ()- []- []- )+compileProg mode class_name prog = do+ (ws, defs) <- ImpGen.compileProg prog+ (ws,)+ <$> Py.compileProg+ mode+ class_name+ constructor+ imports+ defines+ operations+ ()+ []+ []+ defs where imports = [ Import "sys" Nothing,@@ -41,9 +40,13 @@ Import "ctypes" $ Just "ct", Import "time" Nothing ]+ constructor =+ Py.Constructor+ ["self", "user_sizes=user_sizes"]+ [Exp $ Py.simpleCall "set_user_params" [Var "self.sizes", Var "user_sizes"]] defines = []- operations :: GenericPython.Operations Imp.Sequential ()+ operations :: Py.Operations Imp.Sequential () operations =- GenericPython.defaultOperations- { GenericPython.opsCompiler = const $ pure ()+ Py.defaultOperations+ { Py.opsCompiler = const $ pure () }
src/Futhark/CodeGen/Backends/SequentialWASM.hs view
@@ -43,7 +43,6 @@ GC.compileProg "wasm" version- mempty operations generateBoilerplate ""
src/Futhark/CodeGen/Backends/SimpleRep.hs view
@@ -152,7 +152,10 @@ (("arr" <> showText (length dims) <> "d_") <>) <$> p pTup = between "(" ")" $ do ts <- p `sepBy` pComma- pure $ "tup" <> showText (length ts) <> "_" <> T.intercalate "_" ts+ pure $+ if null ts+ then "unit"+ else "tup" <> showText (length ts) <> "_" <> T.intercalate "_" ts pRec = between "{" "}" $ do fs <- pField `sepBy` pComma pure $ "rec__" <> T.intercalate "__" fs
src/Futhark/CodeGen/ImpCode.hs view
@@ -109,7 +109,7 @@ import Data.Traversable import Futhark.Analysis.PrimExp import Futhark.Analysis.PrimExp.Convert-import Futhark.IR.GPU.Sizes (Count (..), SizeClass (..))+import Futhark.IR.GPU.Sizes (Count (..), SizeClass (..), sizeDefault) import Futhark.IR.Pretty () import Futhark.IR.Prop.Names import Futhark.IR.Syntax.Core@@ -151,15 +151,16 @@ -- | A collection of imperative functions and constants. data Definitions a = Definitions- { defTypes :: OpaqueTypes,+ { defParams :: ParamMap,+ defTypes :: OpaqueTypes, defConsts :: Constants a, defFuns :: Functions a } deriving (Show) instance Functor Definitions where- fmap f (Definitions types consts funs) =- Definitions types (fmap f consts) (fmap f funs)+ fmap f (Definitions params types consts funs) =+ Definitions params types (fmap f consts) (fmap f funs) -- | A collection of imperative functions. newtype Functions a = Functions {unFunctions :: [(Name, Function a)]}@@ -339,6 +340,8 @@ | -- | Log the given message, *without* a trailing linebreak (unless -- part of the message). TracePrint (ErrorMsg Exp)+ | -- | Retrieve user-provided parameter and put it in the given variable.+ GetUserParam VName Name (TExp Int64) | -- | Perform an extensible operation. Op a deriving (Show)@@ -442,9 +445,11 @@ foldProvenances f (Op x) = f x foldProvenances _ _ = mempty --- | A mapping from names of tuning parameters to their class, as well--- as which functions make use of them (including transitively).-type ParamMap = M.Map Name (SizeClass, S.Set Name)+-- | A mapping from names of tuning parameters to their class, as well as which+-- functions make use of them. These uses may or may not be transitive - early+-- on in code generation they will not be, but then later they will be extended+-- using call graph information.+type ParamMap = M.Map Name (Maybe SizeClass, S.Set Name) -- | A side-effect free expression whose execution will produce a -- single primitive value.@@ -485,45 +490,47 @@ -- Prettyprinting definitions. instance (Pretty op) => Pretty (Definitions op) where- pretty (Definitions types consts funs) =- pretty types </> pretty consts </> pretty funs+ pretty (Definitions params types consts funs) =+ params' </> pretty types </> pretty consts </> pretty funs+ where+ params' =+ "tuning params" <+> nestedBlock (stack $ map ppParam $ M.toList params)+ ppParam (k, (c, users)) =+ maybe "user" pretty c <+> pretty k <+> parens (commasep $ map pretty $ S.toList users) instance (Pretty op) => Pretty (Functions op) where pretty (Functions funs) = stack $ intersperse mempty $ map ppFun funs where ppFun (name, fun) =- "Function " <> pretty name <> colon </> indent 2 (pretty fun)+ "function" <+> pretty name <+> nestedBlock (pretty fun) instance (Pretty op) => Pretty (Constants op) where pretty (Constants decls code) =- "Constants:"- </> indent 2 (stack $ map pretty decls)+ "constants"+ <+> nestedBlock (stack $ map pretty decls) </> mempty- </> "Initialisation:"- </> indent 2 (pretty code)+ </> "initialisation"+ <+> nestedBlock (pretty code) instance Pretty EntryPoint where pretty (EntryPoint name results args) =- "Name:"- </> indent 2 (dquotes (pretty name))- </> "Arguments:"- </> indent 2 (stack $ map ppArg args)- </> "Results:"- </> indent 2 (stack $ map ppRes results)+ stack+ [ "name" <+> nestedBlock (dquotes (pretty name)),+ "arguments" <+> nestedBlock (stack $ map ppArg args),+ "results" <+> nestedBlock (stack $ map ppRes results)+ ] where ppArg ((p, u), t) = pretty p <+> ":" <+> ppRes (u, t) ppRes (u, t) = pretty u <> pretty t instance (Pretty op) => Pretty (FunctionT op) where pretty (Function entry outs ins body) =- "Inputs:"- </> indent 2 (stack $ map pretty ins)- </> "Outputs:"- </> indent 2 (stack $ map pretty outs)- </> "Entry:"- </> indent 2 (pretty entry)- </> "Body:"- </> indent 2 (pretty body)+ stack+ [ "inputs" <+> nestedBlock (stack $ map pretty ins),+ "outputs" <+> nestedBlock (stack $ map pretty outs),+ "entry" <+> nestedBlock (pretty entry),+ "body" <+> nestedBlock (pretty body)+ ] instance Pretty Param where pretty (ScalarParam name ptype) = pretty ptype <+> pretty name@@ -549,7 +556,7 @@ pretty (OpaqueValue desc vs) = "opaque" <+> dquotes (pretty desc)- <+> nestedBlock "{" "}" (stack $ map pretty vs)+ <+> nestedBlock (stack $ map pretty vs) instance Pretty ArrayContents where pretty (ArrayValues vs) = braces (commasep $ map pretty vs)@@ -672,6 +679,9 @@ "debug" <+> parens (pretty (show desc)) pretty (TracePrint msg) = "trace" <+> parens (pretty msg)+ pretty (GetUserParam v name def) =+ "get_user_param" <+> pretty v <+> "<-" <+> pretty name+ <> parens (pretty def) instance Pretty Arg where pretty (MemArg m) = pretty m@@ -748,6 +758,8 @@ pure $ DebugPrint s v traverse _ (TracePrint msg) = pure $ TracePrint msg+ traverse _ (GetUserParam v name def) =+ pure $ GetUserParam v name def -- | The names declared with 'DeclareMem', 'DeclareScalar', and -- 'DeclareArray' in the given code.@@ -825,6 +837,8 @@ maybe mempty freeIn' v freeIn' (TracePrint msg) = foldMap freeIn' msg+ freeIn' (GetUserParam v _ def) =+ freeIn' v <> freeIn' def instance FreeIn Arg where freeIn' (MemArg m) = freeIn' m
src/Futhark/CodeGen/ImpCode/GPU.hs view
@@ -36,6 +36,7 @@ data KernelConst = SizeConst Name SizeClass | SizeMaxConst SizeClass+ | SizeUserParam Name VName deriving (Eq, Ord, Show) -- | An expression whose variables are kernel constants.@@ -89,10 +90,13 @@ "get_size" <> parens (commasep [pretty key, pretty size_class]) pretty (SizeMaxConst size_class) = "get_max_size" <> parens (pretty size_class)+ pretty (SizeUserParam name def) =+ "get_user_param" <> parens (commasep [pretty name, pretty def]) instance FreeIn KernelConst where freeIn' SizeConst {} = mempty freeIn' (SizeMaxConst _) = mempty+ freeIn' (SizeUserParam _ def) = freeIn' def instance Pretty KernelUse where pretty (ScalarUse name t) =
src/Futhark/CodeGen/ImpCode/Multicore.hs view
@@ -43,6 +43,9 @@ | -- | Retrieve the number of subtasks to execute. Only valid -- immediately inside a 'SegOp' or 'ParLoop' construct! GetNumTasks VName+ | -- | If the context is currently in an error state (e.g. because some other+ -- task has died), put @True@ in the given variable, otherwise @False@.+ GetError VName | Atomic AtomicOp -- | Multicore code.@@ -59,6 +62,8 @@ | AtomicXor IntType VName VName (Count Elements (TExp Int32)) Exp | AtomicXchg PrimType VName VName (Count Elements (TExp Int32)) Exp | AtomicCmpXchg PrimType VName VName (Count Elements (TExp Int32)) VName Exp+ | AtomicLoad PrimType VName VName (Count Elements (TExp Int32))+ | AtomicStore PrimType VName (Count Elements (TExp Int32)) Exp deriving (Show) instance FreeIn AtomicOp where@@ -69,6 +74,8 @@ freeIn' (AtomicXor _ _ arr i x) = freeIn' arr <> freeIn' i <> freeIn' x freeIn' (AtomicCmpXchg _ _ arr i retval x) = freeIn' arr <> freeIn' i <> freeIn' x <> freeIn' retval freeIn' (AtomicXchg _ _ arr i x) = freeIn' arr <> freeIn' i <> freeIn' x+ freeIn' (AtomicLoad _ _ arr i) = freeIn' arr <> freeIn' i+ freeIn' (AtomicStore _ arr i x) = freeIn' arr <> freeIn' i <> freeIn' x -- | Information about parallel work that is do be done. This is -- passed to the scheduler to help it make scheduling decisions.@@ -95,8 +102,8 @@ instance Pretty SchedulerInfo where pretty (SchedulerInfo i sched) = stack- [ nestedBlock "scheduling {" "}" (pretty sched),- nestedBlock "iter {" "}" (pretty i)+ [ "scheduling" <+> nestedBlock (pretty sched),+ "iter" <+> nestedBlock (pretty i) ] instance Pretty ParallelTask where@@ -110,28 +117,28 @@ pretty (GetNumTasks v) = pretty v <+> "<-" <+> "get_num_tasks()" pretty (SegOp s free seq_code par_code retval scheduler) =- "SegOp" <+> pretty s <+> nestedBlock "{" "}" ppbody+ "SegOp" <+> pretty s <+> nestedBlock ppbody where ppbody = stack [ pretty scheduler,- nestedBlock "free {" "}" (pretty free),- nestedBlock "seq {" "}" (pretty seq_code),- maybe mempty (nestedBlock "par {" "}" . pretty) par_code,- nestedBlock "retvals {" "}" (pretty retval)+ "free" <+> nestedBlock (pretty free),+ "seq" <+> nestedBlock (pretty seq_code),+ maybe mempty (("par" <+>) . nestedBlock . pretty) par_code,+ "retvals" <+> nestedBlock (pretty retval) ] pretty (ParLoop s body params) =- "parloop" <+> pretty s </> nestedBlock "{" "}" ppbody+ "parloop" <+> pretty s </> nestedBlock ppbody where ppbody = stack- [ nestedBlock "params {" "}" (pretty params),- nestedBlock "body {" "}" (pretty body)+ [ "params" <+> nestedBlock (pretty params),+ "body" <+> nestedBlock (pretty body) ] pretty (Atomic _) = "AtomicOp" pretty (ISPCKernel body _) =- "ispc" <+> nestedBlock "{" "}" (pretty body)+ "ispc" <+> nestedBlock (pretty body) pretty (ForEach i from to body) = "foreach" <+> pretty i@@ -139,13 +146,15 @@ <+> pretty from <+> "to" <+> pretty to- <+> nestedBlock "{" "}" (pretty body)+ <+> nestedBlock (pretty body) pretty (ForEachActive i body) = "foreach_active" <+> pretty i- <+> nestedBlock "{" "}" (pretty body)+ <+> nestedBlock (pretty body) pretty (ExtractLane dest tar lane) = pretty dest <+> "<-" <+> "extract" <+> parens (commasep $ map pretty [tar, lane])+ pretty (GetError v) =+ pretty v <+> "<-" <+> "get_error()" instance FreeIn SchedulerInfo where freeIn' (SchedulerInfo iter _) = freeIn' iter@@ -174,6 +183,8 @@ fvBind (oneName i) (freeIn' body) freeIn' (ExtractLane dest tar lane) = freeIn' dest <> freeIn' tar <> freeIn' lane+ freeIn' (GetError v) =+ freeIn' v -- | Whether 'lexicalMemoryUsageMC' should look inside nested kernels -- or not.
src/Futhark/CodeGen/ImpCode/OpenCL.hs view
@@ -31,7 +31,7 @@ import Futhark.IR.GPU.Sizes import Futhark.Util.Pretty --- | An program calling OpenCL kernels.+-- | A program calling OpenCL kernels. data Program = Program { openClProgram :: T.Text, -- | Must be prepended to the program.@@ -42,8 +42,6 @@ openClKernelNames :: M.Map KernelName KernelSafety, -- | So we can detect whether the device is capable. openClUsedTypes :: [PrimType],- -- | Runtime-configurable constants.- openClParams :: ParamMap, -- | Assertion failure error messages. openClFailures :: [FailureMsg], hostDefinitions :: Definitions OpenCL
src/Futhark/CodeGen/ImpGen.hs view
@@ -36,6 +36,7 @@ emit, emitFunction, hasFunction,+ addTuningParam, collect, collect', VarEntry (..),@@ -139,6 +140,8 @@ ( Bytes, Count, Elements,+ ParamMap,+ SizeClass, elements, ) import Futhark.CodeGen.ImpCode qualified as Imp@@ -289,6 +292,7 @@ stateFunctions :: Imp.Functions op, stateCode :: Imp.Code op, stateConstants :: Imp.Constants op,+ stateParams :: ParamMap, stateWarnings :: Warnings, -- | Maps the arrays backing each accumulator to their -- update function and neutral elements. This works@@ -301,7 +305,7 @@ } newState :: VNameSource -> ImpState rep r op-newState = ImpState mempty mempty mempty mempty mempty mempty+newState = ImpState mempty mempty mempty mempty mempty mempty mempty newtype ImpM rep r op a = ImpM (ReaderT (Env rep r op) (State (ImpState rep r op)) a)@@ -376,11 +380,13 @@ stateNameSource = stateNameSource s, stateConstants = mempty, stateWarnings = mempty,+ stateParams = stateParams s, stateAccs = stateAccs s } (x, s'') = runState (runReaderT m env') s' putNameSource $ stateNameSource s''+ modify $ \s''' -> s''' {stateParams = stateParams s''} warnings $ stateWarnings s'' pure (x, stateCode s'') @@ -422,6 +428,15 @@ let Imp.Functions fs = stateFunctions s in isJust $ lookup fname fs +-- | Add a tuning parameter. You can call this function with the same parameter+-- name multiple times, but they must have the same class.+addTuningParam :: Name -> Maybe SizeClass -> ImpM rep r op ()+addTuningParam key sclass = do+ user <- asks $ maybe mempty S.singleton . envFunction+ modify $ \s -> s {stateParams = M.insertWith comb key (sclass, user) $ stateParams s}+ where+ comb (c, x) (_, y) = (c, x <> y)+ constsVTable :: (Mem rep inner) => Stms rep -> VTable rep constsVTable = foldMap stmVtable where@@ -448,6 +463,7 @@ combineStates ss in ( ( stateWarnings s', Imp.Definitions+ (stateParams s') types (foldMap stateConstants ss <> stateConstants s') (stateFunctions s')@@ -466,11 +482,14 @@ combineStates ss = let Imp.Functions funs' = mconcat $ map stateFunctions ss src = mconcat (map stateNameSource ss)+ mixParam (c, x) (_, y) = (c, x <> y) in (newState src) { stateFunctions = Imp.Functions $ M.toList $ M.fromList funs', stateWarnings =- mconcat $ map stateWarnings ss+ mconcat $ map stateWarnings ss,+ stateParams =+ foldl' (M.unionWith mixParam) mempty $ map stateParams ss } compileConsts :: Names -> Stms rep -> ImpM rep r op ()@@ -1026,6 +1045,9 @@ compileStms mempty (bodyStms $ lambdaBody lam) $ forM_ (zip arrs (bodyResult (lambdaBody lam))) $ \(arr, SubExpRes _ se) -> copyDWIMFix arr is' se []+defCompileBasicOp (Pat [PatElem v _]) (UserParam name se) = do+ addTuningParam name Nothing+ emit $ Imp.GetUserParam v name $ pe64 se defCompileBasicOp pat e = error $ "ImpGen.defCompileBasicOp: Invalid pattern\n "
src/Futhark/CodeGen/ImpGen/GPU.hs view
@@ -117,22 +117,24 @@ compileAlloc dest e space opCompiler (Pat [pe]) (Inner (SizeOp (GetSize key size_class))) = do fname <- askFunction- sOp $- Imp.GetSize (patElemName pe) (keyWithEntryPoint fname key) $- sizeClassWithEntryPoint fname size_class+ let key' = keyWithEntryPoint fname key+ addTuningParam key' $ Just size_class+ sOp $ Imp.GetSize (patElemName pe) key' $ sizeClassWithEntryPoint fname size_class opCompiler (Pat [pe]) (Inner (SizeOp (CmpSizeLe key size_class x))) = do fname <- askFunction let size_class' = sizeClassWithEntryPoint fname size_class- sOp . Imp.CmpSizeLe (patElemName pe) (keyWithEntryPoint fname key) size_class'- =<< toExp x+ key' = keyWithEntryPoint fname key+ addTuningParam key' $ Just size_class+ sOp . Imp.CmpSizeLe (patElemName pe) key' size_class' =<< toExp x opCompiler (Pat [pe]) (Inner (SizeOp (GetSizeMax size_class))) = sOp $ Imp.GetSizeMax (patElemName pe) size_class opCompiler (Pat [pe]) (Inner (SizeOp (CalcNumBlocks w64 max_num_tblocks_key tblock_size))) = do fname <- askFunction max_num_tblocks :: TV Int64 <- dPrim "max_num_tblocks"- sOp $- Imp.GetSize (tvVar max_num_tblocks) (keyWithEntryPoint fname max_num_tblocks_key) $- sizeClassWithEntryPoint fname SizeGrid+ let key = keyWithEntryPoint fname max_num_tblocks_key+ class_ = sizeClassWithEntryPoint fname SizeGrid+ addTuningParam key $ Just class_+ sOp $ Imp.GetSize (tvVar max_num_tblocks) key class_ -- If 'w' is small, we launch fewer blocks than we normally would. -- We don't want any idle blocks.
src/Futhark/CodeGen/ImpGen/GPU/Base.hs view
@@ -290,8 +290,13 @@ pure v f (Imp.SizeConst k c) = do v <- dPrimS (nameFromText $ prettyText k) int64+ addTuningParam k $ Just c sOp $ Imp.GetSize v k c pure v+ f (Imp.SizeUserParam name def) = do+ v <- dPrimS (nameFromText $ prettyText name) int64+ emit $ Imp.GetUserParam v name $ le64 def+ pure v -- | Given available register and a list of parameter types, compute -- the largest available chunk size given the parameters for which we@@ -1051,6 +1056,7 @@ tblock_size <- dPrim "tblock_size" fname <- askFunction let tblock_size_key = keyWithEntryPoint fname $ nameFromString $ prettyString $ tvVar tblock_size+ addTuningParam tblock_size_key $ Just Imp.SizeThreadBlock sOp $ Imp.GetSize (tvVar tblock_size) tblock_size_key Imp.SizeThreadBlock virt_num_tblocks <- dPrimVE "virt_num_tblocks" $ kernel_size `divUp` tvExp tblock_size num_tblocks <- dPrimV "num_tblocks" $ virt_num_tblocks `sMin64` max_num_tblocks@@ -1180,6 +1186,7 @@ v <- dPrim desc fname <- askFunction let v_key = keyWithEntryPoint fname $ nameFromText $ prettyText $ tvVar v+ addTuningParam v_key $ Just size_class sOp $ Imp.GetSize (tvVar v) v_key size_class pure v
src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs view
@@ -58,10 +58,11 @@ translateGPU target prog = let env = envFromProg prog ( prog',- ToOpenCL kernels device_funs used_types sizes failures constants+ ToOpenCL kernels device_funs used_types failures constants ) = (`runState` initialOpenCL) . (`runReaderT` env) $ do let ImpGPU.Definitions+ params types (ImpGPU.Constants ps consts) (ImpGPU.Functions funs) = prog@@ -71,6 +72,7 @@ pure $ ImpOpenCL.Definitions+ (findParamUsers env prog' (cleanParams params)) types (ImpOpenCL.Constants ps consts') (ImpOpenCL.Functions funs')@@ -91,7 +93,6 @@ openClMacroDefs = constants, openClKernelNames = kernels', openClUsedTypes = S.toList used_types,- openClParams = findParamUsers env prog' (cleanSizes sizes), openClFailures = failures, hostDefinitions = prog' }@@ -103,18 +104,18 @@ -- | Due to simplifications after kernel extraction, some threshold -- parameters may contain KernelPaths that reference threshold -- parameters that no longer exist. We remove these here.-cleanSizes :: M.Map Name SizeClass -> M.Map Name SizeClass-cleanSizes m = M.map clean m+cleanParams :: ParamMap -> ParamMap+cleanParams m = M.map clean m where known = M.keys m- clean (SizeThreshold path def) =- SizeThreshold (filter ((`elem` known) . fst) path) def+ clean (Just (SizeThreshold path def), users) =+ (Just $ SizeThreshold (filter ((`elem` known) . fst) path) def, users) clean s = s findParamUsers :: Env -> Definitions ImpOpenCL.OpenCL ->- M.Map Name SizeClass ->+ ParamMap -> ParamMap findParamUsers env defs = M.mapWithKey onParam where@@ -134,7 +135,7 @@ ) indirect_uses = direct_uses <> map (indirectUseInFun . fst) direct_uses - onParam k c = (c, S.fromList $ map fst $ filter ((k `elem`) . snd) indirect_uses)+ onParam k (c, _) = (c, S.fromList $ map fst $ filter ((k `elem`) . snd) indirect_uses) pointerQuals :: String -> [C.TypeQual] pointerQuals "global" = [C.ctyquals|__global|]@@ -173,13 +174,12 @@ { clGPU :: M.Map KernelName (KernelSafety, T.Text), clDevFuns :: M.Map Name (C.Definition, T.Text), clUsedTypes :: S.Set PrimType,- clSizes :: M.Map Name SizeClass, clFailures :: [FailureMsg], clConstants :: [(Name, KernelConstExp)] } initialOpenCL :: ToOpenCL-initialOpenCL = ToOpenCL mempty mempty mempty mempty mempty mempty+initialOpenCL = ToOpenCL mempty mempty mempty mempty mempty data Env = Env { envFuns :: ImpGPU.Functions ImpGPU.HostOp,@@ -226,17 +226,11 @@ type OnKernelM = ReaderT Env (State ToOpenCL) -addSize :: Name -> SizeClass -> OnKernelM ()-addSize key sclass =- modify $ \s -> s {clSizes = M.insert key sclass $ clSizes s}- onHostOp :: KernelTarget -> HostOp -> OnKernelM OpenCL onHostOp target (CallKernel k) = onKernel target k-onHostOp _ (ImpGPU.GetSize v key size_class) = do- addSize key size_class+onHostOp _ (ImpGPU.GetSize v key _) = pure $ ImpOpenCL.GetSize v key-onHostOp _ (ImpGPU.CmpSizeLe v key size_class x) = do- addSize key size_class+onHostOp _ (ImpGPU.CmpSizeLe v key _ x) = pure $ ImpOpenCL.CmpSizeLe v key x onHostOp _ (ImpGPU.GetSizeMax v size_class) = pure $ ImpOpenCL.GetSizeMax v size_class@@ -332,7 +326,7 @@ isConst :: BlockDim -> Maybe KernelConstExp isConst (Left (ValueExp (IntValue x))) =- Just $ ValueExp (IntValue x)+ Just $ ValueExp $ IntValue x isConst (Right e) = Just e isConst _ = Nothing@@ -612,7 +606,11 @@ GC.opsFatMemory = False, GC.opsError = errorInKernel, GC.opsCall = callInKernel,- GC.opsCritical = mempty+ GC.opsCritical = mempty,+ GC.opsGetParam = \name ->+ let name_val = "val_" <> nameToString name+ name_set = "set_" <> nameToString name+ in ([C.cexp|$id:name_val|], [C.cexp|$id:name_set|]) } where has_communication = hasCommunication body@@ -898,6 +896,7 @@ typesInCode (Meta _) = mempty typesInCode (DebugPrint _ v) = maybe mempty typesInExp v typesInCode (TracePrint msg) = foldMap typesInExp msg+typesInCode (GetUserParam _ _ def) = typesInExp (untyped def) typesInCode Op {} = mempty typesInExp :: Exp -> S.Set PrimType
src/Futhark/CodeGen/ImpGen/Multicore/Base.hs view
@@ -197,8 +197,7 @@ (free_allocs, here_allocs) = f body_allocs free' = filter- ( (`notNameIn` Imp.declaredIn body_allocs) . Imp.paramName- )+ ((`notNameIn` Imp.declaredIn body_allocs) . Imp.paramName) free in ( free_allocs, here_allocs <> Imp.Op (Imp.ParLoop s body' free')
src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+ -- | Multicore code generation for SegScan. Uses a fairly naive multipass -- algorithm, with no particular locality optimisations. module Futhark.CodeGen.ImpGen.Multicore.SegScan@@ -7,26 +9,20 @@ import Control.Monad import Data.List (zip4)+import Data.Maybe (isNothing) import Futhark.CodeGen.ImpCode.Multicore qualified as Imp import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.Multicore.Base import Futhark.IR.MCMem-import Futhark.Util.IntegralExp (quot, rem)+import Futhark.Transform.Rename (renameBody)+import Futhark.Util.IntegralExp (divUp) import Prelude hiding (quot, rem) --- | Compile a SegScan construct.-compileSegScan ::- Pat LetDecMem ->- SegSpace ->- [SegBinOp MCMem] ->- KernelBody MCMem ->- TV Int32 ->- MulticoreGen ()-compileSegScan pat space reds kbody nsubtasks- | [_] <- unSegSpace space =- nonsegmentedScan pat space reds kbody nsubtasks- | otherwise =- segmentedScan pat space reds kbody+-- This does not correspond with the actual cache size, but the actual cache+-- size may not really be the optimal value either. Ideally this should be+-- exposed as a tuning parameter.+cacheSize :: Imp.TExp Int64+cacheSize = 65536 -- 64 KB xParams, yParams :: SegBinOp MCMem -> [LParam MCMem] xParams scan =@@ -37,439 +33,488 @@ lamBody :: SegBinOp MCMem -> Body MCMem lamBody = lambdaBody . segBinOpLambda --- Arrays for storing worker results.-carryArrays :: Name -> TV Int32 -> [SegBinOp MCMem] -> MulticoreGen [[VName]]-carryArrays s nsubtasks segops =- forM segops $ \(SegBinOp _ lam _ shape) ->- forM (lambdaReturnType lam) $ \t -> do- let pt = elemType t- full_shape =- Shape [Var (tvVar nsubtasks)]- <> shape- <> arrayShape t- sAllocArray s pt full_shape DefaultSpace--nonsegmentedScan ::- Pat LetDecMem ->- SegSpace ->- [SegBinOp MCMem] ->- KernelBody MCMem ->- TV Int32 ->- MulticoreGen ()-nonsegmentedScan pat space scan_ops kbody nsubtasks = do- emit $ Imp.DebugPrint "nonsegmented segScan" Nothing- -- Are we working with nested arrays- let dims = map (shapeDims . segBinOpShape) scan_ops- -- Are we only working on scalars- let scalars = all (all (primType . typeOf . paramDec) . (lambdaParams . segBinOpLambda)) scan_ops && all null dims- -- Do we have nested vector operations- let vectorize = [] `notElem` dims-- let param_types = concatMap (map paramType . (lambdaParams . segBinOpLambda)) scan_ops- let no_array_param = all primType param_types-- let (scanStage1, scanStage3)- | scalars = (scanStage1Scalar, scanStage3Scalar)- | vectorize && no_array_param = (scanStage1Nested, scanStage3Nested)- | otherwise = (scanStage1Fallback, scanStage3Fallback)-- emit $ Imp.DebugPrint "Scan stage 1" Nothing- scanStage1 pat space kbody scan_ops-- let nsubtasks' = tvExp nsubtasks- sWhen (nsubtasks' .>. 1) $ do- scan_ops2 <- renameSegBinOp scan_ops- emit $ Imp.DebugPrint "Scan stage 2" Nothing- carries <- scanStage2 pat nsubtasks space scan_ops2- scan_ops3 <- renameSegBinOp scan_ops- emit $ Imp.DebugPrint "Scan stage 3" Nothing- scanStage3 pat space scan_ops3 carries---- Different ways to generate code for a scan loop-data ScanLoopType- = ScanSeq -- Fully sequential- | ScanNested -- Nested vectorized map- | ScanScalar -- Vectorized scan over scalars---- Given a scan type, return a function to inject into the loop body-getScanLoop ::- ScanLoopType ->- (Imp.TExp Int64 -> MulticoreGen ()) ->- MulticoreGen ()-getScanLoop ScanScalar = generateUniformizeLoop-getScanLoop _ = \body -> body 0---- Given a scan type, return a function to extract a scalar from a vector-getExtract :: ScanLoopType -> Imp.TExp Int64 -> MulticoreGen Imp.MCCode -> MulticoreGen ()-getExtract ScanSeq = \_ body -> body >>= emit-getExtract _ = extractVectorLane- genBinOpParams :: [SegBinOp MCMem] -> MulticoreGen () genBinOpParams scan_ops = dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) scan_ops -genLocalAccsStage1 :: [SegBinOp MCMem] -> MulticoreGen [[VName]]-genLocalAccsStage1 scan_ops = do+initialiseLocalPrefixes :: [SegBinOp MCMem] -> [[VName]] -> MulticoreGen ()+initialiseLocalPrefixes scan_ops per_op_prefix_var = do+ scan_ops_renamed <- renameSegBinOp scan_ops+ genBinOpParams scan_ops_renamed+ forM_ (zip scan_ops_renamed per_op_prefix_var) $ \(scan_op, prefix_vars) -> do+ sLoopNest (segBinOpShape scan_op) $ \vec_is ->+ forM_ (zip (segBinOpNeutral scan_op) prefix_vars) $ \(ne, prefix_var) -> do+ copyDWIMFix prefix_var vec_is ne []++updateLocalPrefixes :: [SegBinOp MCMem] -> [[VName]] -> [[VName]] -> [Imp.TExp Int64] -> MulticoreGen ()+updateLocalPrefixes scan_ops per_op_prefix_var per_op_prefix_arr index = do+ forM_ (zip3 scan_ops per_op_prefix_var per_op_prefix_arr) $ \(scan_op, prefix_vars, prefix_arrs) -> do+ let shape = segBinOpShape scan_op+ sLoopNest shape $ \vec_is ->+ forM_ (zip prefix_vars prefix_arrs) $ \(prefix_var, prefix_arr) -> do+ copyDWIMFix prefix_var vec_is (Var prefix_arr) (index ++ vec_is)++genArrays :: [SegBinOp MCMem] -> Name -> Shape -> MulticoreGen [[VName]]+genArrays scan_ops arr_name block_shape = do+ forM scan_ops $ \scan_op ->+ forM (lambdaReturnType $ segBinOpLambda scan_op) $ \t -> do+ let shape = block_shape <> segBinOpShape scan_op <> arrayShape t+ sAllocArray arr_name (elemType t) shape DefaultSpace++genLocalArray :: [SegBinOp MCMem] -> MulticoreGen [[VName]]+genLocalArray scan_ops = do forM scan_ops $ \scan_op -> do let shape = segBinOpShape scan_op ts = lambdaReturnType $ segBinOpLambda scan_op- forM (zip3 (xParams scan_op) (segBinOpNeutral scan_op) ts) $ \(p, ne, t) -> do- acc <- -- update accumulator to have type decoration- case shapeDims shape of- [] -> pure $ paramName p- _ -> do- let pt = elemType t- sAllocArray "local_acc" pt (shape <> arrayShape t) DefaultSpace+ forM (zip (xParams scan_op) ts) $ \(p, t) -> do+ case shapeDims shape of+ [] -> pure $ paramName p+ _ -> do+ let pt = elemType t+ sAllocArray "local_acc" pt (shape <> arrayShape t) DefaultSpace - -- Now neutral-initialise the accumulator.- sLoopNest (segBinOpShape scan_op) $ \vec_is ->- copyDWIMFix acc vec_is ne []+totalBytes :: [SegBinOp MCMem] -> Imp.TExp Int64+totalBytes scan_ops =+ sum+ [ bytesOfShape (elemType t) (arrayShape t <> scan_shape)+ | op <- scan_ops,+ let lam = segBinOpLambda op,+ let scan_shape = segBinOpShape op,+ t <- lambdaReturnType lam+ ]+ where+ bytesOfShape pt sh = primByteSize pt * product (map pe64 (shapeDims sh)) - pure acc+bodyHas :: (Exp MCMem -> Bool) -> GBody MCMem res -> Bool+bodyHas f = any (f' . stmExp) . bodyStms+ where+ f' e+ | f e = True+ | otherwise = isNothing $ walkExpM walker e+ walker =+ identityWalker+ { walkOnBody = const $ guard . not . bodyHas f+ } -getNestLoop ::- ScanLoopType ->- Shape ->- ([Imp.TExp Int64] -> MulticoreGen ()) ->+-- | Determine whether this kernel body should be recomputed. Involves both+-- correctness checks and (crude) efficiency checks. Basically, recomputation is+-- only safe if nothing is consumed in the body, and considered efficient only+-- if the body has no loops.+shouldRecompute :: KernelBody MCMem -> Bool+shouldRecompute = not . bodyHas bad+ where+ bad (BasicOp Update {}) = True+ bad (BasicOp UpdateAcc {}) = True+ bad (WithAcc {}) = True+ bad Loop {} = True+ bad _ = False++hasAssert :: GBody MCMem res -> Bool+hasAssert = bodyHas isAssert+ where+ isAssert (BasicOp Assert {}) = True+ isAssert _ = False++copyFromDescToLocal :: [SegBinOp MCMem] -> [[VName]] -> [[VName]] -> TV Int64 -> MulticoreGen ()+copyFromDescToLocal scan_ops per_op_local_vars per_op_description_arrays index = do+ forM_ (zip3 scan_ops per_op_local_vars per_op_description_arrays) $ \(scan_op, local_vars, desc_arrs) -> do+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip local_vars desc_arrs) $ \(local_var, desc_arr) -> do+ copyDWIMFix local_var vec_is (Var desc_arr) (tvExp index : vec_is)++applyScanFromDescToLocal ::+ [SegBinOp MCMem] ->+ [[VName]] ->+ [[VName]] ->+ TV Int64 -> MulticoreGen ()-getNestLoop ScanNested = sLoopNestVectorized-getNestLoop _ = sLoopNest+applyScanFromDescToLocal scan_ops per_op_local_vars per_op_description_arrays index = do+ scan_ops_renamed <- renameSegBinOp scan_ops+ genBinOpParams scan_ops_renamed+ forM_ (zip3 scan_ops_renamed per_op_local_vars per_op_description_arrays) $ \(scan_op, local_vars, description_array) -> do+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip (xParams scan_op) description_array) $ \(xs, desc_var) -> do+ copyDWIMFix (paramName xs) [] (Var desc_var) (tvExp index : vec_is)+ forM_ (zip (yParams scan_op) local_vars) $ \(ys, local_var) -> do+ copyDWIMFix (paramName ys) [] (Var local_var) vec_is+ compileStms mempty (bodyStms $ lamBody scan_op) $ do+ forM_ (zip (map resSubExp $ bodyResult $ lamBody scan_op) local_vars) $ \(se, local_var) -> do+ copyDWIMFix local_var vec_is se [] -applyScanOps ::- ScanLoopType ->- Pat LetDecMem ->- SegSpace ->- [SubExp] ->+applyScanAggregateToPrefix :: [SegBinOp MCMem] -> [[VName]] ->- ImpM MCMem HostEnv Imp.Multicore ()-applyScanOps typ pat space all_scan_res scan_ops local_accs = do- let per_scan_res = segBinOpChunks scan_ops all_scan_res- per_scan_pes = segBinOpChunks scan_ops $ patElems pat- let (is, _) = unzip $ unSegSpace space+ [[VName]] ->+ [[VName]] ->+ TV Int64 ->+ MulticoreGen ()+applyScanAggregateToPrefix scan_ops per_op_local_vars per_op_aggr_arrs prefArrs block_idx = do+ scan_ops_renamed <- renameSegBinOp scan_ops+ genBinOpParams scan_ops_renamed+ forM_ (zip4 scan_ops_renamed per_op_local_vars per_op_aggr_arrs prefArrs) $ \(scan_op, local_vars, aggr_arrs, prifix_arrs) -> do+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip (xParams scan_op) local_vars) $ \(xs, local_var) -> do+ copyDWIMFix (paramName xs) [] (Var local_var) vec_is+ forM_ (zip (yParams scan_op) aggr_arrs) $ \(ys, aggrArr) -> do+ copyDWIMFix (paramName ys) [] (Var aggrArr) (tvExp block_idx : vec_is) - -- Potential vector load and then do sequential scan- getScanLoop typ $ \j ->- forM_ (zip4 per_scan_pes scan_ops per_scan_res local_accs) $ \(pes, scan_op, scan_res, acc) ->- getNestLoop typ (segBinOpShape scan_op) $ \vec_is -> do- sComment "Read accumulator" $- forM_ (zip (xParams scan_op) acc) $ \(p, acc') -> do- copyDWIMFix (paramName p) [] (Var acc') vec_is- sComment "Read next values" $- forM_ (zip (yParams scan_op) scan_res) $ \(p, se) ->- getExtract typ j $- collect $- copyDWIMFix (paramName p) [] se vec_is- -- Scan body- sComment "Scan op body" $- compileStms mempty (bodyStms $ lamBody scan_op) $- forM_ (zip3 acc pes $ map resSubExp $ bodyResult $ lamBody scan_op) $- \(acc', pe, se) -> do- copyDWIMFix (patElemName pe) (map Imp.le64 is ++ vec_is) se []- copyDWIMFix acc' vec_is se []+ compileStms mempty (bodyStms $ lamBody scan_op) $ do+ forM_ (zip (map resSubExp $ bodyResult $ lamBody scan_op) prifix_arrs) $ \(se, prefix_arr) -> do+ copyDWIMFix prefix_arr (tvExp block_idx : vec_is) se [] --- Generate a loop which performs a potentially vectorized scan on the--- result of a kernel body.-genScanLoop ::- ScanLoopType ->+seqScanFastPath :: Pat LetDecMem ->- SegSpace ->- KernelBody MCMem ->+ VName -> [SegBinOp MCMem] ->+ KernelBody MCMem -> [[VName]] ->- Imp.TExp Int64 ->- ImpM MCMem HostEnv Imp.Multicore ()-genScanLoop typ pat space kbody scan_ops local_accs i = do- let (all_scan_res, map_res) =- splitAt (segBinOpResults scan_ops) $ bodyResult kbody- let (is, ns) = unzip $ unSegSpace space- ns' = map pe64 ns+ TV Int64 ->+ TV Int64 ->+ [[VName]] ->+ TV Int64 ->+ MulticoreGen ()+seqScanFastPath pat i scan_ops kbody per_op_prefixes_var start chunk_length per_op_prefix_arr block_idx = do+ kbody_renamed <- renameBody kbody+ scan_ops_renamed <- renameSegBinOp scan_ops+ genBinOpParams scan_ops_renamed+ per_op_local_accum <- genLocalArray scan_ops_renamed - zipWithM_ dPrimV_ is $ unflattenIndex ns' i- compileStms mempty (bodyStms kbody) $ do- let map_arrs = drop (segBinOpResults scan_ops) $ patElems pat- sComment "write mapped values results to memory" $- zipWithM_ (compileThreadResult space) map_arrs map_res- sComment "Apply scan op" $- applyScanOps typ pat space (map kernelResultSubExp all_scan_res) scan_ops local_accs+ let results = bodyResult kbody_renamed+ let n_scan = segBinOpResults scan_ops_renamed+ let (all_scan_res, map_res) = splitAt n_scan results -scanStage1Scalar ::+ let per_scan_res = segBinOpChunks scan_ops_renamed all_scan_res+ let per_scan_pes = segBinOpChunks scan_ops_renamed $ patElems pat++ forM_ (zip3 scan_ops_renamed per_op_prefixes_var per_op_local_accum) $ \(scan_op, prefix_vars, local_accums) ->+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip local_accums prefix_vars) $ \(acc, prefix) -> do+ copyDWIMFix acc vec_is (Var prefix) vec_is++ z <- dPrimV "z" (0 :: Imp.TExp Int64)+ sWhile (tvExp z .<. tvExp chunk_length) $ do+ dPrimV_ i (tvExp start + tvExp z)++ compileStms mempty (bodyStms kbody_renamed) $ do+ let map_arrs = drop (segBinOpResults scan_ops_renamed) $ patElems pat++ sComment "write mapped values results to memory" $+ forM_ (zip (map patElemName map_arrs) (map kernelResultSubExp map_res)) $ \(arr, res) ->+ copyDWIMFix arr [tvExp start + tvExp z] res []++ forM_ (zip4 per_scan_pes scan_ops_renamed per_scan_res per_op_local_accum) $ \(pes, scan_op, scan_res, local_accums) ->+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip (xParams scan_op) local_accums) $ \(p, acc) ->+ copyDWIMFix (paramName p) [] (Var acc) vec_is+ forM_ (zip (yParams scan_op) scan_res) $ \(py, kr) ->+ copyDWIMFix (paramName py) [] (kernelResultSubExp kr) vec_is+ compileStms mempty (bodyStms $ lamBody scan_op) $+ forM_ (zip3 local_accums (map resSubExp $ bodyResult $ lamBody scan_op) pes) $ \(acc, se, pe) -> do+ copyDWIMFix (patElemName pe) ((tvExp start + tvExp z) : vec_is) se []+ copyDWIMFix acc vec_is se []+ z <-- tvExp z + 1++ -- write back local accumulators to prefix arrays+ forM_ (zip3 scan_ops_renamed per_op_prefix_arr per_op_local_accum) $ \(scan_op, prefix_arrs, local_accums) ->+ sLoopNest (segBinOpShape scan_op) $ \vec_is ->+ forM_ (zip local_accums prefix_arrs) $ \(acc, prefix_arr) ->+ copyDWIMFix prefix_arr (tvExp block_idx : vec_is) (Var acc) vec_is++seqScanLB :: Pat LetDecMem ->- SegSpace ->- KernelBody MCMem ->+ VName -> [SegBinOp MCMem] ->+ KernelBody MCMem ->+ [[VName]] ->+ TV Int64 ->+ TV Int64 -> MulticoreGen ()-scanStage1Scalar pat space kbody scan_ops = do- fbody <- collect $ do- dPrim_ (segFlat space) int64- sOp $ Imp.GetTaskId (segFlat space)+seqScanLB pat i scan_ops kbody per_op_prefixes_var start chunk_length = do+ kbody_renamed <- renameBody kbody+ scan_ops_renamed <- renameSegBinOp scan_ops+ genBinOpParams scan_ops_renamed+ per_op_local_accum <- genLocalArray scan_ops_renamed - genBinOpParams scan_ops- local_accs <- genLocalAccsStage1 scan_ops- inISPC $- generateChunkLoop "SegScan" Vectorized $- genScanLoop ScanScalar pat space kbody scan_ops local_accs- free_params <- freeParams fbody- emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" fbody free_params+ let results = bodyResult kbody_renamed+ let n_scan = segBinOpResults scan_ops_renamed+ let (all_scan_res, _) = splitAt n_scan results -scanStage1Nested ::+ let per_scan_res = segBinOpChunks scan_ops_renamed all_scan_res+ let per_scan_pes = segBinOpChunks scan_ops_renamed $ patElems pat++ forM_ (zip3 scan_ops_renamed per_op_prefixes_var per_op_local_accum) $ \(scan_op, prefix_vars, local_accums) ->+ sLoopNest (segBinOpShape scan_op) $ \vec_is ->+ forM_ (zip local_accums prefix_vars) $ \(acc, prefix) ->+ copyDWIMFix acc vec_is (Var prefix) vec_is++ z <- dPrimV "z" (0 :: Imp.TExp Int64)+ sWhile (tvExp z .<. tvExp chunk_length) $ do+ dPrimV_ i (tvExp start + tvExp z)+ if shouldRecompute kbody_renamed+ then do+ compileStms mempty (bodyStms kbody_renamed) $ do+ forM_ (zip4 per_scan_pes scan_ops_renamed per_scan_res per_op_local_accum) $ \(pes, scan_op, scan_res, local_accums) ->+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip (xParams scan_op) local_accums) $ \(px, acc) ->+ copyDWIMFix (paramName px) [] (Var acc) vec_is+ forM_ (zip (yParams scan_op) scan_res) $ \(py, kr) ->+ copyDWIMFix (paramName py) [] (kernelResultSubExp kr) vec_is+ compileStms mempty (bodyStms $ lamBody scan_op) $+ forM_ (zip3 (map resSubExp $ bodyResult $ lamBody scan_op) pes local_accums) $ \(se, pe, acc) -> do+ copyDWIMFix acc vec_is se []+ copyDWIMFix (patElemName pe) ((tvExp start + tvExp z) : vec_is) se []+ z <-- tvExp z + 1+ else do+ forM_ (zip4 per_scan_pes scan_ops_renamed per_scan_res per_op_local_accum) $ \(pes, scan_op, _, local_accums) ->+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip (xParams scan_op) local_accums) $ \(px, acc) ->+ copyDWIMFix (paramName px) [] (Var acc) vec_is+ forM_ (zip (yParams scan_op) pes) $ \(py, pe) ->+ -- reading from output array+ copyDWIMFix (paramName py) [] (Var (patElemName pe)) ((tvExp start + tvExp z) : vec_is)+ compileStms mempty (bodyStms $ lamBody scan_op) $ do+ forM_ (zip (map resSubExp $ bodyResult $ lamBody scan_op) pes) $ \(se, pe) ->+ copyDWIMFix (patElemName pe) ((tvExp start + tvExp z) : vec_is) se []+ z <-- tvExp z + 1++seqAggregate :: Pat LetDecMem ->- SegSpace ->- KernelBody MCMem ->+ VName -> [SegBinOp MCMem] ->+ KernelBody MCMem ->+ TV Int64 ->+ TV Int64 ->+ [[VName]] ->+ TV Int64 -> MulticoreGen ()-scanStage1Nested pat space kbody scan_ops = do- fbody <- collect $ do- dPrim_ (segFlat space) int64- sOp $ Imp.GetTaskId (segFlat space)+seqAggregate pat i scan_ops kbody start chunk_length per_op_aggr_arrs block_idx = do+ scan_ops_renamed <- renameSegBinOp scan_ops+ kbody_renamed <- renameBody kbody+ genBinOpParams scan_ops_renamed+ let results = bodyResult kbody_renamed+ let n_scan = segBinOpResults scan_ops_renamed+ let (all_scan_res, map_res) = splitAt n_scan results+ let per_scan_res = segBinOpChunks scan_ops_renamed all_scan_res+ let per_scan_pes = segBinOpChunks scan_ops_renamed $ patElems pat - local_accs <- genLocalAccsStage1 scan_ops+ per_op_local_accum <- genLocalArray scan_ops_renamed - inISPC $ do- genBinOpParams scan_ops- generateChunkLoop "SegScan" Scalar $ \i -> do- genScanLoop ScanNested pat space kbody scan_ops local_accs i+ j <- dPrimV "j" (0 :: Imp.TExp Int64)+ sWhile (tvExp j .<. tvExp chunk_length) $ do+ dPrimV_ i (tvExp start + tvExp j)+ compileStms mempty (bodyStms kbody_renamed) $ do+ let map_arrs = drop (segBinOpResults scan_ops_renamed) $ patElems pat+ sComment "write mapped values results to memory" $+ forM_ (zip (map patElemName map_arrs) (map kernelResultSubExp map_res)) $ \(arr, res) ->+ copyDWIMFix arr [tvExp start + tvExp j] res [] - free_params <- freeParams fbody- emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" fbody free_params+ sIf+ (tvExp j .==. 0)+ ( forM_ (zip4 scan_ops_renamed per_scan_res per_op_local_accum per_scan_pes) $+ \(scan_op, scan_res_op, local_accums, pes) -> do+ let shape = segBinOpShape scan_op+ sLoopNest shape $ \vec_is -> do+ forM_ (zip3 scan_res_op local_accums pes) $ \(kr, acc, pe) -> do+ copyDWIMFix acc vec_is (kernelResultSubExp kr) vec_is+ unless (shouldRecompute kbody_renamed) $+ copyDWIMFix (patElemName pe) ((tvExp start + tvExp j) : vec_is) (kernelResultSubExp kr) vec_is+ )+ ( forM_ (zip4 scan_ops_renamed per_scan_res per_op_local_accum per_scan_pes) $+ \(scan_op, scan_res, local_accums, pes) ->+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip (xParams scan_op) local_accums) $ \(px, acc) ->+ copyDWIMFix (paramName px) [] (Var acc) vec_is+ forM_ (zip (yParams scan_op) scan_res) $ \(py, kr) ->+ copyDWIMFix (paramName py) [] (kernelResultSubExp kr) vec_is -scanStage1Fallback ::- Pat LetDecMem ->- SegSpace ->- KernelBody MCMem ->- [SegBinOp MCMem] ->+ compileStms mempty (bodyStms $ lamBody scan_op) $ do+ forM_ (zip3 (map resSubExp $ bodyResult $ lamBody scan_op) local_accums pes) $ \(se, acc, pe) -> do+ copyDWIMFix acc vec_is se []+ unless (shouldRecompute kbody_renamed) $ copyDWIMFix (patElemName pe) ((tvExp start + tvExp j) : vec_is) se []+ )+ j <-- tvExp j + 1++ -- write local accumulators to aggregate arrays+ forM_ (zip3 scan_ops_renamed per_op_local_accum per_op_aggr_arrs) $ \(scan_op, local_accums, aggr_arrs) ->+ sLoopNest (segBinOpShape scan_op) $ \vec_is -> do+ forM_ (zip local_accums aggr_arrs) $ \(acc, agg) -> do+ copyDWIMFix agg (tvExp block_idx : vec_is) (Var acc) vec_is++load64 ::+ VName ->+ VName ->+ Imp.Count Imp.Elements (Imp.TExp Int32) -> MulticoreGen ()-scanStage1Fallback pat space kbody scan_ops = do- -- Stage 1 : each thread partially scans a chunk of the input- -- Writes directly to the resulting array- fbody <- collect $ do- dPrim_ (segFlat space) int64- sOp $ Imp.GetTaskId (segFlat space)+load64 v arr i = sOp $ Imp.Atomic $ Imp.AtomicLoad (IntType Int64) v arr i - genBinOpParams scan_ops- local_accs <- genLocalAccsStage1 scan_ops+store64 ::+ VName ->+ Imp.Count Imp.Elements (Imp.TExp Int32) ->+ Imp.TExp Int64 ->+ MulticoreGen ()+store64 arr i x = sOp $ Imp.Atomic $ Imp.AtomicStore (IntType Int64) arr i (untyped x) - generateChunkLoop "SegScan" Scalar $- genScanLoop ScanSeq pat space kbody scan_ops local_accs- free_params <- freeParams fbody- emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" fbody free_params+add64 ::+ TV Int64 ->+ VName ->+ Imp.Count Imp.Elements (Imp.TExp Int32) ->+ Imp.TExp Int64 ->+ MulticoreGen ()+add64 v arr i x = sOp $ Imp.Atomic $ Imp.AtomicAdd Int64 (tvVar v) arr i (untyped x) -scanStage2 ::+nonsegmentedScan :: Pat LetDecMem ->- TV Int32 -> SegSpace -> [SegBinOp MCMem] ->- MulticoreGen [[VName]]-scanStage2 pat nsubtasks space scan_ops = do- let (is, ns) = unzip $ unSegSpace space- ns_64 = map pe64 ns- per_scan_pes = segBinOpChunks scan_ops $ patElems pat- nsubtasks' = sExt64 $ tvExp nsubtasks+ KernelBody MCMem ->+ TV Int32 ->+ MulticoreGen ()+nonsegmentedScan+ pat+ (SegSpace fid [(i, n)])+ scan_ops+ kbody+ _nsubtasks = do+ let multiplier = 1 -- For playing with.+ blockSize = cacheSize `divUp` (totalBytes scan_ops * multiplier) - dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) scan_ops- offset <- dPrimV "offset" (0 :: Imp.TExp Int64)- let offset' = tvExp offset- offset_index <- dPrimV "offset_index" (0 :: Imp.TExp Int64)- let offset_index' = tvExp offset_index+ block_no <- dPrimV "nblocks" (pe64 n `divUp` blockSize) - -- Parameters used to find the chunk sizes- -- Perhaps get this information from ``scheduling information``- -- instead of computing it manually here.- let iter_pr_subtask = product ns_64 `quot` nsubtasks'- remainder = product ns_64 `rem` nsubtasks'+ -- allocate flags/aggr/prefix arrays of length nblocks+ flagsArr <- sAllocArray "scan_flags" int64 (Shape [Var (tvVar block_no)]) DefaultSpace - carries <- carryArrays "scan_stage_2_carry" nsubtasks scan_ops- sComment "carry-in for first chunk is neutral" $- forM_ (zip scan_ops carries) $ \(scan_op, carry) ->- sLoopNest (segBinOpShape scan_op) $ \vec_is ->- forM_ (zip carry $ segBinOpNeutral scan_op) $ \(carry', ne) ->- copyDWIMFix carry' (0 : vec_is) ne []+ let block_shape = Shape [Var (tvVar block_no)] - -- Perform sequential scan over the last element of each chunk- sComment "scan carries" $ sFor "i" (nsubtasks' - 1) $ \i -> do- offset <-- iter_pr_subtask- sWhen (sExt64 i .<. remainder) (offset <-- offset' + 1)- offset_index <-- offset_index' + offset'- zipWithM_ dPrimV_ is $ unflattenIndex ns_64 $ sExt64 offset_index'+ aggrArrs <- genArrays scan_ops "scan_aggr" block_shape - forM_ (zip3 per_scan_pes scan_ops carries) $ \(pes, scan_op, carry) ->- sLoopNest (segBinOpShape scan_op) $ \vec_is -> do- sComment "Read carry" $- forM_ (zip (xParams scan_op) carry) $ \(p, carry') ->- copyDWIMFix (paramName p) [] (Var carry') (i : vec_is)+ prefArrs <- genArrays scan_ops "scan_pref" block_shape - sComment "Read next values" $- forM_ (zip (yParams scan_op) pes) $ \(p, pe) ->- copyDWIMFix (paramName p) [] (Var $ patElemName pe) ((offset_index' - 1) : vec_is)+ work_index <- sAllocArray "work_index" int64 (Shape [intConst Int64 1]) DefaultSpace - compileStms mempty (bodyStms $ lamBody scan_op) $- forM_ (zip carry $ map resSubExp $ bodyResult $ lamBody scan_op) $ \(carry', se) -> do- copyDWIMFix carry' ((i + 1) : vec_is) se []+ sFor "init" (tvExp block_no) $ \j -> do+ copyDWIMFix flagsArr [j] (intConst Int64 0) [] - -- Return the array of carries for each chunk.- pure carries+ copyDWIMFix work_index [0] (intConst Int64 0) [] -scanStage3Scalar ::- Pat LetDecMem ->- SegSpace ->- [SegBinOp MCMem] ->- [[VName]] ->- MulticoreGen ()-scanStage3Scalar pat space scan_ops per_scan_carries = do- let per_scan_pes = segBinOpChunks scan_ops $ patElems pat- (is, ns) = unzip $ unSegSpace space- ns' = map pe64 ns+ fbody <- collect $ do+ seq_flag <- dPrimV "seq_flag" true - body <- collect $ do- dPrim_ (segFlat space) int64- sOp $ Imp.GetTaskId $ segFlat space+ sOp $ Imp.GetTaskId fid - inISPC $ do- genBinOpParams scan_ops- sComment "load carry-in" $- forM_ (zip per_scan_carries scan_ops) $ \(op_carries, scan_op) ->- forM_ (zip (xParams scan_op) op_carries) $ \(p, carries) ->- copyDWIMFix (paramName p) [] (Var carries) [le64 (segFlat space)]- generateChunkLoop "SegScan" Vectorized $ \i -> do- zipWithM_ dPrimV_ is $ unflattenIndex ns' i- sComment "load partial result" $- forM_ (zip per_scan_pes scan_ops) $ \(scan_pes, scan_op) ->- forM_ (zip (yParams scan_op) scan_pes) $ \(p, pe) ->- copyDWIMFix (paramName p) [] (Var (patElemName pe)) (map le64 is)- sComment "combine carry with partial result" $- forM_ (zip per_scan_pes scan_ops) $ \(scan_pes, scan_op) ->- compileStms mempty (bodyStms $ lamBody scan_op) $- forM_ (zip scan_pes $ map resSubExp $ bodyResult $ lamBody scan_op) $ \(pe, se) ->- copyDWIMFix (patElemName pe) (map Imp.le64 is) se []+ block_idx <- dPrim "block_idx"+ work_index_loc <- entryArrayLoc <$> lookupArray work_index+ let work_index_loc_name = memLocName work_index_loc - free_params <- freeParams body- emit $ Imp.Op $ Imp.ParLoop "scan_stage_3" body free_params+ add64 block_idx work_index_loc_name (Imp.elements 0) 1 -scanStage3Nested ::- Pat LetDecMem ->- SegSpace ->- [SegBinOp MCMem] ->- [[VName]] ->- MulticoreGen ()-scanStage3Nested pat space scan_ops per_scan_carries = do- let per_scan_pes = segBinOpChunks scan_ops $ patElems pat- (is, ns) = unzip $ unSegSpace space- ns' = map pe64 ns- body <- collect $ do- dPrim_ (segFlat space) int64- sOp $ Imp.GetTaskId (segFlat space)+ sWhile (tvExp block_idx .<. tvExp block_no) $ do+ start <- dPrimV "start" (tvExp block_idx * blockSize) - generateChunkLoop "SegScan" Scalar $ \i -> do- genBinOpParams scan_ops- zipWithM_ dPrimV_ is $ unflattenIndex ns' i- forM_ (zip3 per_scan_pes per_scan_carries scan_ops) $ \(scan_pes, op_carries, scan_op) -> do- sLoopNest (segBinOpShape scan_op) $ \vec_is -> do- sComment "load carry-in" $- forM_ (zip (xParams scan_op) op_carries) $ \(p, carries) ->- copyDWIMFix (paramName p) [] (Var carries) (le64 (segFlat space) : vec_is)+ diff_start <- dPrimV "diff_start" (pe64 n - tvExp start) - sComment "load partial result" $- forM_ (zip (yParams scan_op) scan_pes) $ \(p, pe) ->- copyDWIMFix (paramName p) [] (Var (patElemName pe)) (map le64 is ++ vec_is)- sComment "combine carry with partial result" $- compileStms mempty (bodyStms $ lamBody scan_op) $- forM_ (zip scan_pes $ map resSubExp $ bodyResult $ lamBody scan_op) $ \(pe, se) ->- copyDWIMFix (patElemName pe) (map Imp.le64 is ++ vec_is) se []+ chunk_length <- dPrim "chunk_length"+ sIf+ (tvExp diff_start .<. blockSize)+ (chunk_length <-- tvExp diff_start)+ (chunk_length <-- blockSize) - free_params <- freeParams body- emit $ Imp.Op $ Imp.ParLoop "scan_stage_3" body free_params+ prefix_seqs <- genArrays scan_ops "seq_prefix" (Shape []) -scanStage3Fallback ::- Pat LetDecMem ->- SegSpace ->- [SegBinOp MCMem] ->- [[VName]] ->- MulticoreGen ()-scanStage3Fallback pat space scan_ops per_scan_carries = do- let per_scan_pes = segBinOpChunks scan_ops $ patElems pat- (is, ns) = unzip $ unSegSpace space- ns' = map pe64 ns- body <- collect $ do- dPrim_ (segFlat space) int64- sOp $ Imp.GetTaskId (segFlat space)+ flags_loc <- entryArrayLoc <$> lookupArray flagsArr+ let flag_loc_name = memLocName flags_loc+ let block_idx_32 = sExt32 (tvExp block_idx) - genBinOpParams scan_ops+ sWhen+ (tvExp seq_flag .==. true)+ ( sIf+ (tvExp block_idx .==. 0)+ (initialiseLocalPrefixes scan_ops prefix_seqs)+ ( do+ prev_flag <- dPrim "prev_flag" :: MulticoreGen (TV Int64)+ load64 (tvVar prev_flag) flag_loc_name (Imp.elements $ block_idx_32 - 1)+ sIf+ (tvExp prev_flag .==. 2)+ (updateLocalPrefixes scan_ops prefix_seqs prefArrs [tvExp block_idx - 1])+ (seq_flag <-- false)+ )+ ) - generateChunkLoop "SegScan" Scalar $ \i -> do- zipWithM_ dPrimV_ is $ unflattenIndex ns' i- forM_ (zip3 per_scan_pes per_scan_carries scan_ops) $ \(scan_pes, op_carries, scan_op) -> do- sLoopNest (segBinOpShape scan_op) $ \vec_is -> do- sComment "load carry-in" $- forM_ (zip (xParams scan_op) op_carries) $ \(p, carries) ->- copyDWIMFix (paramName p) [] (Var carries) (le64 (segFlat space) : vec_is)+ sIf+ (tvExp seq_flag .==. true)+ ( do+ seqScanFastPath pat i scan_ops kbody prefix_seqs start chunk_length prefArrs block_idx - sComment "load partial result" $- forM_ (zip (yParams scan_op) scan_pes) $ \(p, pe) ->- copyDWIMFix (paramName p) [] (Var (patElemName pe)) (map le64 is ++ vec_is)- sComment "combine carry with partial result" $- compileStms mempty (bodyStms $ lamBody scan_op) $- forM_ (zip scan_pes $ map resSubExp $ bodyResult $ lamBody scan_op) $ \(pe, se) ->- copyDWIMFix (patElemName pe) (map Imp.le64 is ++ vec_is) se []- free_params <- freeParams body- emit $ Imp.Op $ Imp.ParLoop "scan_stage_3" body free_params+ store64 flag_loc_name (Imp.elements block_idx_32) 2+ )+ ( do+ seqAggregate pat i scan_ops kbody start chunk_length aggrArrs block_idx --- Note: This isn't currently used anywhere.--- This implementation for a Segmented scan only--- parallelize over the segments and each segment is--- scanned sequentially.-segmentedScan ::- Pat LetDecMem ->- SegSpace ->- [SegBinOp MCMem] ->- KernelBody MCMem ->- MulticoreGen ()-segmentedScan pat space scan_ops kbody = do- emit $ Imp.DebugPrint "segmented segScan" Nothing- body <- compileSegScanBody pat space scan_ops kbody- free_params <- freeParams body- emit $ Imp.Op $ Imp.ParLoop "seg_scan" body free_params+ -- write flag as 1+ store64 flag_loc_name (Imp.elements block_idx_32) 1 -compileSegScanBody ::- Pat LetDecMem ->- SegSpace ->- [SegBinOp MCMem] ->- KernelBody MCMem ->- MulticoreGen Imp.MCCode-compileSegScanBody pat space scan_ops kbody = collect $ do- let (is, ns) = unzip $ unSegSpace space- ns_64 = map pe64 ns+ old_flag <- dPrim "old_flag" :: MulticoreGen (TV Int64)+ old_flag <-- 0+ prefix_vars <- genArrays scan_ops "par_prefix" (Shape []) - dPrim_ (segFlat space) int64- sOp $ Imp.GetTaskId (segFlat space)+ lb <- dPrimV "lb" (tvExp block_idx - 1)+ has_acc <- dPrimV "has_acc" (false :: Imp.TExp Bool) - let per_scan_pes = segBinOpChunks scan_ops $ patElems pat- generateChunkLoop "SegScan" Scalar $ \segment_i -> do- forM_ (zip scan_ops per_scan_pes) $ \(scan_op, scan_pes) -> do- dScope Nothing $ scopeOfLParams $ lambdaParams $ segBinOpLambda scan_op- let (scan_x_params, scan_y_params) = splitAt (length $ segBinOpNeutral scan_op) $ (lambdaParams . segBinOpLambda) scan_op+ error_flag <- dPrim "error_flag" :: MulticoreGen (TV Bool)+ sOp $ Imp.GetError (tvVar error_flag) - forM_ (zip scan_x_params $ segBinOpNeutral scan_op) $ \(p, ne) ->- copyDWIMFix (paramName p) [] ne []+ sWhile (bNot (tvExp old_flag .==. 2 .||. tvExp error_flag)) $ do+ load64 (tvVar old_flag) flag_loc_name (Imp.elements $ sExt32 $ tvExp lb) - let inner_bound = last ns_64- -- Perform a sequential scan over the segment ``segment_i``- sFor "i" inner_bound $ \i -> do- zipWithM_ dPrimV_ (init is) $ unflattenIndex (init ns_64) segment_i- dPrimV_ (last is) i- compileStms mempty (bodyStms kbody) $ do- let (scan_res, map_res) = splitAt (length $ segBinOpNeutral scan_op) $ bodyResult kbody- sComment "write to-scan values to parameters" $- forM_ (zip scan_y_params scan_res) $ \(p, se) ->- copyDWIMFix (paramName p) [] (kernelResultSubExp se) []+ -- One of the other operators may fail, in which case we have to+ -- bail out to avoid an infinite wait. This is a very rare case,+ -- so only do it when necessary.+ when (any (hasAssert . lambdaBody . segBinOpLambda) scan_ops || hasAssert kbody) $+ sOp $+ Imp.GetError (tvVar error_flag) - sComment "write mapped values results to memory" $- forM_ (zip (drop (length $ segBinOpNeutral scan_op) $ patElems pat) map_res) $ \(pe, se) ->- copyDWIMFix (patElemName pe) (map Imp.le64 is) (kernelResultSubExp se) []+ sWhen+ (tvExp old_flag .==. 2)+ ( do+ sIf+ (tvExp has_acc .==. false)+ (copyFromDescToLocal scan_ops prefix_vars prefArrs lb)+ (applyScanFromDescToLocal scan_ops prefix_vars prefArrs lb)+ )+ sWhen+ (tvExp old_flag .==. 1)+ ( do+ sIf+ (tvExp has_acc .==. false)+ (copyFromDescToLocal scan_ops prefix_vars aggrArrs lb)+ (applyScanFromDescToLocal scan_ops prefix_vars aggrArrs lb)+ has_acc <-- true+ lb <-- tvExp lb - 1+ ) - sComment "combine with carry and write to memory" $- compileStms mempty (bodyStms $ lambdaBody $ segBinOpLambda scan_op) $- forM_ (zip3 scan_x_params scan_pes $ map resSubExp $ bodyResult $ lambdaBody $ segBinOpLambda scan_op) $ \(p, pe, se) -> do- copyDWIMFix (patElemName pe) (map Imp.le64 is) se []- copyDWIMFix (paramName p) [] se []+ applyScanAggregateToPrefix scan_ops prefix_vars aggrArrs prefArrs block_idx++ store64 flag_loc_name (Imp.elements block_idx_32) 2++ seqScanLB pat i scan_ops kbody prefix_vars start chunk_length+ )++ add64 block_idx work_index_loc_name (Imp.elements 0) 1++ free_params <- freeParams fbody+ emit $ Imp.Op $ Imp.ParLoop "segmap" fbody free_params++-- | Compile a SegScan construct.+compileSegScan ::+ Pat LetDecMem ->+ SegSpace ->+ [SegBinOp MCMem] ->+ KernelBody MCMem ->+ TV Int32 ->+ MulticoreGen ()+compileSegScan pat space reds kbody nsubtasks+ | [_] <- unSegSpace space =+ nonsegmentedScan pat space reds kbody nsubtasks+ | otherwise =+ error "only nonsegmented scans for now"
src/Futhark/Doc/Generator.hs view
@@ -16,12 +16,13 @@ import Data.String (fromString) import Data.Text qualified as T import Data.Version+import Futhark.Util.Html (headHtml, relativise) import Futhark.Util.Pretty (Doc, docText, pretty) import Futhark.Version import Language.Futhark import Language.Futhark.Semantic import Language.Futhark.Warnings-import System.FilePath (makeRelative, splitPath, (-<.>), (</>))+import System.FilePath (makeRelative, (-<.>), (</>)) import Text.Blaze.Html5 (AttributeValue, Html, toHtml, (!)) import Text.Blaze.Html5 qualified as H import Text.Blaze.Html5.Attributes qualified as A@@ -135,7 +136,7 @@ fullRow = H.tr . (H.td ! A.colspan "3") emptyRow :: Html-emptyRow = H.tr $ H.td mempty <> H.td mempty <> H.td mempty+emptyRow = H.tr ! A.class_ "empty_spec_row" $ H.td mempty <> H.td mempty <> H.td mempty specRow :: Html -> Html -> Html -> Html specRow a b c =@@ -285,17 +286,7 @@ addBoilerplate :: String -> String -> Html -> Html addBoilerplate current titleText content =- let headHtml =- H.head $- H.meta- ! A.charset "utf-8"- <> H.title (fromString titleText)- <> H.link- ! A.href (fromString $ relativise "style.css" current)- ! A.rel "stylesheet"- ! A.type_ "text/css"-- navigation =+ let navigation = H.ul ! A.id "navigation" $ H.li (H.a ! A.href (fromString $ relativise "index.html" current) $ "Contents") <> H.li (H.a ! A.href (fromString $ relativise "doc-index.html" current) $ "Index")@@ -305,7 +296,7 @@ <> (H.a ! A.href futhark_doc_url) "futhark-doc" <> " " <> fromString (showVersion version)- in headHtml+ in headHtml current titleText <> H.body ( (H.div ! A.id "header") (H.h1 (toHtml titleText) <> navigation) <> (H.div ! A.id "content") content@@ -682,10 +673,6 @@ v' <- vnameHtml v pure $ parens $ v' <> ": " <> dietHtml d <> t' Unnamed -> pure t'--relativise :: FilePath -> FilePath -> FilePath-relativise dest src =- concat (replicate (length (splitPath src) - 1) "../") ++ makeRelative "/" dest dimDeclHtml :: Size -> DocM Html dimDeclHtml = pure . brackets . toHtml . prettyString
src/Futhark/IR/GPU/Op.hs view
@@ -224,10 +224,10 @@ typeCheckSizeOp :: (TC.Checkable rep) => SizeOp -> TC.TypeM rep () typeCheckSizeOp GetSize {} = pure () typeCheckSizeOp GetSizeMax {} = pure ()-typeCheckSizeOp (CmpSizeLe _ _ x) = TC.require [Prim int64] x+typeCheckSizeOp (CmpSizeLe _ _ x) = TC.require (Prim int64) x typeCheckSizeOp (CalcNumBlocks w _ tblock_size) = do- TC.require [Prim int64] w- TC.require [Prim int64] tblock_size+ TC.require (Prim int64) w+ TC.require (Prim int64) tblock_size -- | A host-level operation; parameterised by what else it can do. data HostOp op rep@@ -341,7 +341,7 @@ pretty (OtherOp op) = pretty op pretty (SizeOp op) = pretty op pretty (GPUBody ts body) =- "gpu" <+> PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body)+ "gpu" <+> PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock (pretty body) instance (OpMetrics (Op rep), OpMetrics (op rep)) => OpMetrics (HostOp op rep) where opMetrics (SegOp op) = opMetrics op@@ -357,8 +357,8 @@ checkGrid :: (TC.Checkable rep) => KernelGrid -> TC.TypeM rep () checkGrid grid = do- TC.require [Prim int64] $ unCount $ gridNumBlocks grid- TC.require [Prim int64] $ unCount $ gridBlockSize grid+ TC.require (Prim int64) $ unCount $ gridNumBlocks grid+ TC.require (Prim int64) $ unCount $ gridBlockSize grid checkSegLevel :: (TC.Checkable rep) =>
src/Futhark/IR/GPUMem.hs view
@@ -51,7 +51,7 @@ MemOp (HostOp NoOp) (Aliases GPUMem) -> TC.TypeM GPUMem () typeCheckMemoryOp _ (Alloc size _) =- TC.require [Prim int64] size+ TC.require (Prim int64) size typeCheckMemoryOp lvl (Inner op) = typeCheckHostOp (typeCheckMemoryOp . Just) lvl (const $ pure ()) op checkFParamDec = checkMemInfo
src/Futhark/IR/MC/Op.hs view
@@ -31,8 +31,8 @@ import Futhark.Util.Pretty ( nestedBlock, pretty,+ stack, (<+>),- (</>), ) import Prelude hiding (id, (.)) @@ -116,10 +116,10 @@ instance (PrettyRep rep, Pretty (op rep)) => Pretty (MCOp op rep) where pretty (ParOp Nothing op) = pretty op pretty (ParOp (Just par_op) op) =- "par"- <+> nestedBlock "{" "}" (pretty par_op)- </> "seq"- <+> nestedBlock "{" "}" (pretty op)+ stack+ [ "par" <+> nestedBlock (pretty par_op),+ "seq" <+> nestedBlock (pretty op)+ ] pretty (OtherOp op) = pretty op instance (OpMetrics (Op rep), OpMetrics (op rep)) => OpMetrics (MCOp op rep) where
src/Futhark/IR/MCMem.hs view
@@ -42,7 +42,7 @@ checkOp = typeCheckMemoryOp where typeCheckMemoryOp (Alloc size _) =- TC.require [Prim int64] size+ TC.require (Prim int64) size typeCheckMemoryOp (Inner op) = typeCheckMCOp (const $ pure ()) op checkFParamDec = checkMemInfo
src/Futhark/IR/Mem.hs view
@@ -916,7 +916,7 @@ MemInfo SubExp u MemBind -> TC.TypeM rep () checkMemInfo _ (MemPrim _) = pure ()-checkMemInfo _ (MemMem (ScalarSpace d _)) = mapM_ (TC.require [Prim int64]) d+checkMemInfo _ (MemMem (ScalarSpace d _)) = mapM_ (TC.require (Prim int64)) d checkMemInfo _ (MemMem _) = pure () checkMemInfo _ (MemAcc acc ispace ts u) = TC.checkType $ Acc acc ispace ts u
src/Futhark/IR/Mem/LMAD.hs view
@@ -410,11 +410,9 @@ ) of (Just interval1'', Just interval2'') -> isNothing- ( selfOverlap () () less_thans (map (flip LeafExp $ IntType Int64) $ namesToList non_negatives) interval1''- )+ (selfOverlap () () less_thans (map (flip LeafExp $ IntType Int64) $ namesToList non_negatives) interval1'') && isNothing- ( selfOverlap () () less_thans (map (flip LeafExp $ IntType Int64) $ namesToList non_negatives) interval2''- )+ (selfOverlap () () less_thans (map (flip LeafExp $ IntType Int64) $ namesToList non_negatives) interval2'') && not ( all (uncurry (intervalOverlap less_thans non_negatives))
src/Futhark/IR/Parse.hs view
@@ -347,6 +347,8 @@ safety <- choice [keyword "update_acc_unsafe" $> Unsafe, keyword "update_acc" $> Safe] parens (UpdateAcc safety <$> pVName <* pComma <*> pSubExps <* pComma <*> pSubExps),+ keyword "user_param"+ *> parens (UserParam <$> pName <* pComma <*> pSubExp), -- pConvOp "sext" SExt pIntType pIntType, pConvOp "zext" ZExt pIntType pIntType,
src/Futhark/IR/Pretty.hs view
@@ -267,6 +267,8 @@ update_acc_str = case safety of Safe -> "update_acc" Unsafe -> "update_acc_unsafe"+ pretty (UserParam name def) =+ "user_param" <> apply [pretty name, pretty def] instance (Pretty a) => Pretty (ErrorMsg a) where pretty (ErrorMsg parts) = braces $ align $ commasep $ map p parts@@ -277,7 +279,7 @@ maybeNest :: (PrettyRep rep) => Body rep -> Doc a maybeNest b | null $ bodyStms b = pretty b- | otherwise = nestedBlock "{" "}" $ pretty b+ | otherwise = nestedBlock $ pretty b instance (PrettyRep rep) => Pretty (Case (Body rep)) where pretty (Case vs b) =@@ -355,7 +357,7 @@ "while" <+> pretty cond ) <+> "do"- <+> nestedBlock "{" "}" (pretty loopbody)+ <+> nestedBlock (pretty loopbody) where (params, args) = unzip merge pretty (WithAcc inputs lam) =@@ -407,7 +409,7 @@ <+> parens (commastack $ map pretty fparams) </> indent 2 (colon <+> align (ppTupleLines' $ map prettyRet rettype)) <+> equals- <+> nestedBlock "{" "}" (pretty body)+ <+> nestedBlock (pretty body) where fun = case entry of Nothing -> "fun"@@ -425,27 +427,27 @@ instance Pretty OpaqueType where pretty (OpaqueType ts) =- "opaque" <+> nestedBlock "{" "}" (stack $ map pretty ts)+ "opaque" <+> nestedBlock (stack $ map pretty ts) pretty (OpaqueRecord fs) =- "record" <+> nestedBlock "{" "}" (stack $ map p fs)+ "record" <+> nestedBlock (stack $ map p fs) where p (f, et) = pretty f <> ":" <+> pretty et pretty (OpaqueSum ts cs) =- "sum" <+> nestedBlock "{" "}" (stack $ pretty ts : map p cs)+ "sum" <+> nestedBlock (stack $ pretty ts : map p cs) where p (c, ets) = hsep $ "#" <> pretty c : map pretty ets pretty (OpaqueArray r v ts) = "array" <+> pretty r <> "d" <+> dquotes (pretty v)- <+> nestedBlock "{" "}" (stack $ map pretty ts)+ <+> nestedBlock (stack $ map pretty ts) pretty (OpaqueRecordArray r v fs) =- "record_array" <+> pretty r <> "d" <+> dquotes (pretty v) <+> nestedBlock "{" "}" (stack $ map p fs)+ "record_array" <+> pretty r <> "d" <+> dquotes (pretty v) <+> nestedBlock (stack $ map p fs) where p (f, et) = pretty f <> ":" <+> pretty et instance Pretty OpaqueTypes where- pretty (OpaqueTypes ts) = "types" <+> nestedBlock "{" "}" (stack $ map p ts)+ pretty (OpaqueTypes ts) = "types" <+> nestedBlock (stack $ map p ts) where p (name, t) = "type" <+> dquotes (pretty name) <+> equals <+> pretty t
src/Futhark/IR/Prop/Aliases.hs view
@@ -77,6 +77,7 @@ basicOpAliases Manifest {} = [mempty] basicOpAliases Assert {} = [mempty] basicOpAliases UpdateAcc {} = [mempty]+basicOpAliases UserParam {} = [mempty] matchAliases :: [([Names], Names)] -> [Names] matchAliases l =
src/Futhark/IR/Prop/Scope.hs view
@@ -39,7 +39,6 @@ import Control.Monad.RWS.Lazy qualified import Control.Monad.RWS.Strict qualified import Control.Monad.Reader-import Data.Foldable (foldl') import Data.Map.Strict qualified as M import Futhark.IR.Pretty () import Futhark.IR.Prop.Types
src/Futhark/IR/Prop/TypeOf.hs view
@@ -54,7 +54,7 @@ mapType :: SubExp -> Lambda rep -> [Type] mapType outersize f = [ arrayOf t (Shape [outersize]) NoUniqueness- | t <- lambdaReturnType f+ | t <- lambdaReturnType f ] -- | The type of a primitive operation.@@ -119,6 +119,7 @@ pure [Prim Unit] basicOpType (UpdateAcc _ v _ _) = pure <$> lookupType v+basicOpType UserParam {} = pure [Prim int64] -- | The type of an expression. expExtType ::
src/Futhark/IR/SOACS/SOAC.hs view
@@ -606,7 +606,7 @@ </> "does not match type of seed vector" </> PP.indent 2 (pretty vec_ts) typeCheckSOAC (Stream size arrexps accexps lam) = do- TC.require [Prim int64] size+ TC.require (Prim int64) size accargs <- mapM TC.checkArg accexps arrargs <- mapM lookupType arrexps _ <- TC.checkSOACArrayArgs size arrexps@@ -626,13 +626,13 @@ let fake_lamarrs' = map asArg lamarrs' TC.checkLambda lam $ asArg inttp : accargs ++ fake_lamarrs' typeCheckSOAC (Hist w arrs ops bucket_fun) = do- TC.require [Prim int64] w+ TC.require (Prim int64) w -- Check the operators. forM_ ops $ \(HistOp dest_shape rf dests nes op) -> do nes' <- mapM TC.checkArg nes- mapM_ (TC.require [Prim int64]) dest_shape- TC.require [Prim int64] rf+ mapM_ (TC.require (Prim int64)) dest_shape+ TC.require (Prim int64) rf -- Operator type must match the type of neutral elements. TC.checkLambda op $ map TC.noArgAliases $ nes' ++ nes'@@ -646,7 +646,7 @@ -- Arrays must have proper type. forM_ (zip nes_t dests) $ \(t, dest) -> do- TC.requireI [t `arrayOfShape` dest_shape] dest+ TC.requireI (t `arrayOfShape` dest_shape) dest TC.consume =<< TC.lookupAliases dest -- Types of input arrays must equal parameter types for bucket function.@@ -666,7 +666,7 @@ <> " but should have type " <> prettyTuple bucket_ret_t typeCheckSOAC (Screma w arrs (ScremaForm map_lam scans reds)) = do- TC.require [Prim int64] w+ TC.require (Prim int64) w arrs' <- TC.checkSOACArrayArgs w arrs TC.checkLambda map_lam arrs'
src/Futhark/IR/SegOp.hs view
@@ -53,7 +53,6 @@ import Data.Bitraversable import Data.List ( elemIndex,- foldl', groupBy, intersperse, isPrefixOf,@@ -244,12 +243,12 @@ TC.TypeM rep () checkKernelResult (Returns _ cs what) t = do TC.checkCerts cs- TC.require [t] what+ TC.require t what checkKernelResult (TileReturns cs dims v) t = do TC.checkCerts cs forM_ dims $ \(dim, tile) -> do- TC.require [Prim int64] dim- TC.require [Prim int64] tile+ TC.require (Prim int64) dim+ TC.require (Prim int64) tile vt <- lookupType v unless (vt == t `arrayOfShape` Shape (map snd dims)) $ TC.bad $@@ -257,9 +256,9 @@ "Invalid type for TileReturns " <> prettyText v checkKernelResult (RegTileReturns cs dims_n_tiles arr) t = do TC.checkCerts cs- mapM_ (TC.require [Prim int64]) dims- mapM_ (TC.require [Prim int64]) blk_tiles- mapM_ (TC.require [Prim int64]) reg_tiles+ mapM_ (TC.require $ Prim int64) dims+ mapM_ (TC.require $ Prim int64) blk_tiles+ mapM_ (TC.require $ Prim int64) reg_tiles -- assert that arr is of element type t and shape (rev outer_tiles ++ reg_tiles) arr_t <- lookupType arr@@ -340,7 +339,7 @@ checkSegSpace :: (TC.Checkable rep) => SegSpace -> TC.TypeM rep () checkSegSpace (SegSpace _ dims) =- mapM_ (TC.require [Prim int64] . snd) dims+ mapM_ (TC.require (Prim int64) . snd) dims -- | A 'SegOp' is semantically a perfectly nested stack of maps, on -- top of some bottommost computation (scalar computation, reduction,@@ -482,10 +481,10 @@ TC.binding (scopeOfSegSpace space) $ do nes_ts <- forM ops $ \(HistOp dest_shape rf dests nes shape op) -> do- mapM_ (TC.require [Prim int64]) dest_shape- TC.require [Prim int64] rf+ mapM_ (TC.require (Prim int64)) dest_shape+ TC.require (Prim int64) rf nes' <- mapM TC.checkArg nes- mapM_ (TC.require [Prim int64]) $ shapeDims shape+ mapM_ (TC.require (Prim int64)) $ shapeDims shape -- Operator type must match the type of neutral elements. let stripVecDims = stripArray $ shapeRank shape@@ -502,7 +501,7 @@ -- Arrays must have proper type. let dest_shape' = Shape segment_dims <> dest_shape <> shape forM_ (zip nes_t dests) $ \(t, dest) -> do- TC.requireI [t `arrayOfShape` dest_shape'] dest+ TC.requireI (t `arrayOfShape` dest_shape') dest TC.consume =<< TC.lookupAliases dest pure $ map (`arrayOfShape` shape) nes_t@@ -537,7 +536,7 @@ TC.binding (scopeOfSegSpace space) $ do ne_ts <- forM ops $ \(lam, nes, shape) -> do- mapM_ (TC.require [Prim int64]) $ shapeDims shape+ mapM_ (TC.require (Prim int64)) $ shapeDims shape nes' <- mapM TC.checkArg nes -- Operator type must match the type of neutral elements.@@ -783,14 +782,14 @@ </> PP.align (pretty space) <+> PP.colon <+> ppTuple' (map pretty ts)- <+> PP.nestedBlock "{" "}" (pretty body)+ <+> PP.nestedBlock (pretty body) pretty (SegRed lvl space ts body reds) = "segred" <> pretty lvl </> PP.align (pretty space) </> PP.colon <+> ppTuple' (map pretty ts)- <+> PP.nestedBlock "{" "}" (pretty body)+ <+> PP.nestedBlock (pretty body) </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map pretty reds) pretty (SegScan lvl space ts body scans) = "segscan"@@ -798,7 +797,7 @@ </> PP.align (pretty space) </> PP.colon <+> ppTuple' (map pretty ts)- <+> PP.nestedBlock "{" "}" (pretty body)+ <+> PP.nestedBlock (pretty body) </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map pretty scans) pretty (SegHist lvl space ts body ops) = "seghist"@@ -806,7 +805,7 @@ </> PP.align (pretty space) </> PP.colon <+> ppTuple' (map pretty ts)- <+> PP.nestedBlock "{" "}" (pretty body)+ <+> PP.nestedBlock (pretty body) </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops) where ppOp (HistOp w rf dests nes shape op) =
src/Futhark/IR/SeqMem.hs view
@@ -36,7 +36,7 @@ instance PrettyRep SeqMem instance TC.Checkable SeqMem where- checkOp (Alloc size _) = TC.require [Prim int64] size+ checkOp (Alloc size _) = TC.require (Prim int64) size checkOp (Inner NoOp) = pure () checkFParamDec = checkMemInfo checkLParamDec = checkMemInfo
src/Futhark/IR/Syntax.hs view
@@ -440,6 +440,9 @@ -- 'Safe', perform a run-time bounds check and ignore the write if -- out of bounds (scatter-like). UpdateAcc Safety VName [SubExp] [SubExp]+ | -- | Value of a user-defined parameter (an implicit value provided at+ -- program startup), including a default if no value is provided.+ UserParam Name SubExp deriving (Eq, Ord, Show) -- | The input to a 'WithAcc' construct. Comprises the index space of
src/Futhark/IR/Traversals.hs view
@@ -175,6 +175,8 @@ <*> mapM (mapOnSubExp tv) is <*> mapM (mapOnSubExp tv) ses )+mapExpM tv (BasicOp (UserParam name def)) =+ BasicOp <$> (UserParam name <$> mapOnSubExp tv def) mapExpM tv (WithAcc inputs lam) = WithAcc <$> mapM onInput inputs <*> mapOnLambda tv lam where@@ -335,6 +337,8 @@ walkOnVName tv v mapM_ (walkOnSubExp tv) is mapM_ (walkOnSubExp tv) ses+walkExpM tv (BasicOp (UserParam _name def)) =+ walkOnSubExp tv def walkExpM tv (WithAcc inputs lam) = do forM_ inputs $ \(shape, vs, op) -> do walkOnShape tv shape
src/Futhark/IR/TypeCheck.hs view
@@ -64,7 +64,7 @@ -- instance for this type produces a human-readable description. data ErrorCase rep = TypeError T.Text- | UnexpectedType (Exp rep) Type [Type]+ | UnexpectedType (Exp rep) Type Type | ReturnTypeError Name [ExtType] [ExtType] | DupDefinitionError Name | DupParamError Name VName@@ -83,17 +83,13 @@ instance (Checkable rep) => Show (ErrorCase rep) where show (TypeError msg) = "Type error:\n" ++ T.unpack msg- show (UnexpectedType e _ []) =- "Type of expression\n"- ++ T.unpack (docText $ indent 2 $ pretty e)- ++ "\ncannot have any type - possibly a bug in the type checker."- show (UnexpectedType e t ts) =+ show (UnexpectedType e e_t t) = "Type of expression\n" ++ T.unpack (docText $ indent 2 $ pretty e)- ++ "\nmust be one of "- ++ intercalate ", " (map prettyString ts)- ++ ", but is "+ ++ "\nmust be " ++ prettyString t+ ++ ", but is "+ ++ prettyString e_t ++ "." show (ReturnTypeError fname rettype bodytype) = "Declaration of function "@@ -513,16 +509,16 @@ | t2 == t1 = pure () | otherwise = bad $ BadAnnotation desc t1 t2 --- | @require ts se@ causes a '(TypeError vn)' if the type of @se@ is--- not a subtype of one of the types in @ts@.-require :: (Checkable rep) => [Type] -> SubExp -> TypeM rep ()-require ts se = do- t <- checkSubExp se- unless (t `elem` ts) $ bad $ UnexpectedType (BasicOp $ SubExp se) t ts+-- | @require t se@ causes a '(TypeError vn)' if the type of @se@ is+-- not @t@.+require :: (Checkable rep) => Type -> SubExp -> TypeM rep ()+require t se = do+ se_t <- checkSubExp se+ unless (t == se_t) $ bad $ UnexpectedType (BasicOp $ SubExp se) se_t t -- | Variant of 'require' working on variable names.-requireI :: (Checkable rep) => [Type] -> VName -> TypeM rep ()-requireI ts ident = require ts $ Var ident+requireI :: (Checkable rep) => Type -> VName -> TypeM rep ()+requireI t ident = require t $ Var ident checkArrIdent :: (Checkable rep) =>@@ -638,8 +634,8 @@ where consumable = [ (paramName param, mempty)- | param <- params,- unique $ paramDeclType param+ | param <- params,+ unique $ paramDeclType param ] funParamsToNameInfos ::@@ -742,7 +738,7 @@ lookupType ident checkCerts :: (Checkable rep) => Certs -> TypeM rep ()-checkCerts (Certs cs) = mapM_ (requireI [Prim Unit]) cs+checkCerts (Certs cs) = mapM_ (requireI (Prim Unit)) cs checkSubExpRes :: (Checkable rep) => SubExpRes -> TypeM rep Type checkSubExpRes (SubExpRes cs se) = do@@ -835,10 +831,10 @@ checkSlice vt (Slice idxes) = do when (arrayRank vt /= length idxes) . bad $ SlicingError (arrayShape vt) (length idxes)- mapM_ (traverse $ require [Prim int64]) idxes+ mapM_ (traverse $ require (Prim int64)) idxes checkShape :: (Checkable rep) => Shape -> TypeM rep ()-checkShape = mapM_ (require [Prim int64])+checkShape = mapM_ (require (Prim int64)) checkBasicOp :: (Checkable rep) => BasicOp -> TypeM rep () checkBasicOp (SubExp es) =@@ -864,10 +860,10 @@ checkAnnotation "array-element" t et mapM_ (check et) es'-checkBasicOp (UnOp op e) = require [Prim $ unOpType op] e+checkBasicOp (UnOp op e) = require (Prim (unOpType op)) e checkBasicOp (BinOp op e1 e2) = checkBinOpArgs (binOpType op) e1 e2 checkBasicOp (CmpOp op e1 e2) = checkCmpOp op e1 e2-checkBasicOp (ConvOp op e) = require [Prim $ fst $ convOpType op] e+checkBasicOp (ConvOp op e) = require (Prim $ fst $ convOpType op) e checkBasicOp (Index ident slice) = do vt <- lookupType ident observe ident@@ -881,7 +877,7 @@ TypeError "The target of an Update must not alias the value to be written." checkSlice (arrayOf (Prim src_pt) src_shape NoUniqueness) slice- require [arrayOf (Prim src_pt) (sliceShape slice) NoUniqueness] se+ require (arrayOf (Prim src_pt) (sliceShape slice) NoUniqueness) se consume =<< lookupAliases src checkBasicOp (FlatIndex ident slice) = do vt <- lookupType ident@@ -898,14 +894,14 @@ TypeError "The target of an Update must not alias the value to be written." checkFlatSlice slice- requireI [arrayOf (Prim src_pt) (Shape (flatSliceDims slice)) NoUniqueness] v+ requireI (arrayOf (Prim src_pt) (Shape (flatSliceDims slice)) NoUniqueness) v consume =<< lookupAliases src checkBasicOp (Iota e x s et) = do- require [Prim int64] e- require [Prim $ IntType et] x- require [Prim $ IntType et] s+ require (Prim int64) e+ require (Prim $ IntType et) x+ require (Prim $ IntType et) s checkBasicOp (Replicate (Shape dims) valexp) = do- mapM_ (require [Prim int64]) dims+ mapM_ (require $ Prim int64) dims void $ checkSubExp valexp checkBasicOp (Scratch _ shape) = checkShape $ Shape shape@@ -937,15 +933,15 @@ unless (all ((== dropAt i 1 arr1_dims) . dropAt i 1) arr2s_dims) $ bad $ TypeError "Types of arguments to concat do not match."- require [Prim int64] ressize+ require (Prim int64) ressize checkBasicOp (Manifest arr perm) = checkBasicOp $ Rearrange arr perm -- Basically same thing! checkBasicOp (Assert e (ErrorMsg parts)) = do- require [Prim Bool] e+ require (Prim Bool) e mapM_ checkPart parts where checkPart ErrorString {} = pure ()- checkPart (ErrorVal t x) = require [Prim t] x+ checkPart (ErrorVal t x) = require (Prim t) x checkBasicOp (UpdateAcc _ acc is ses) = do (shape, ts) <- checkAccIdent acc @@ -964,10 +960,12 @@ <> prettyText (length is) <> " provided." - mapM_ (require [Prim int64]) is+ mapM_ (require (Prim int64)) is - zipWithM_ require (map pure ts) ses+ zipWithM_ require ts ses consume =<< lookupAliases acc+checkBasicOp (UserParam _ def) =+ require (Prim int64) def matchLoopResultExt :: (Checkable rep) =>@@ -1046,8 +1044,8 @@ let rettype = map paramDeclType mergepat consumable = [ (paramName param, mempty)- | param <- mergepat,- unique $ paramDeclType param+ | param <- mergepat,+ unique $ paramDeclType param ] ++ form_consumable @@ -1126,7 +1124,7 @@ let cert_params = take num_accs $ lambdaParams lam acc_args <- forM (zip inputs cert_params) $ \((shape, arrs, op), p) -> do- mapM_ (require [Prim int64]) (shapeDims shape)+ mapM_ (require (Prim int64)) (shapeDims shape) elem_ts <- forM arrs $ \arr -> do arr_t <- lookupType arr unless (shapeDims shape `isPrefixOf` arrayDims arr_t) $@@ -1188,10 +1186,10 @@ (Checkable rep) => TypeBase Shape u -> TypeM rep ()-checkType (Mem (ScalarSpace d _)) = mapM_ (require [Prim int64]) d+checkType (Mem (ScalarSpace d _)) = mapM_ (require (Prim int64)) d checkType (Acc cert shape ts _) = do- requireI [Prim Unit] cert- mapM_ (require [Prim int64]) $ shapeDims shape+ requireI (Prim Unit) cert+ mapM_ (require (Prim int64)) $ shapeDims shape mapM_ checkType ts checkType t = mapM_ checkSubExp $ arrayDims t @@ -1211,8 +1209,8 @@ SubExp -> TypeM rep () checkCmpOp (CmpEq t) x y = do- require [Prim t] x- require [Prim t] y+ require (Prim t) x+ require (Prim t) y checkCmpOp (CmpUlt t) x y = checkBinOpArgs (IntType t) x y checkCmpOp (CmpUle t) x y = checkBinOpArgs (IntType t) x y checkCmpOp (CmpSlt t) x y = checkBinOpArgs (IntType t) x y@@ -1229,8 +1227,8 @@ SubExp -> TypeM rep () checkBinOpArgs t e1 e2 = do- require [Prim t] e1- require [Prim t] e2+ require (Prim t) e1+ require (Prim t) e2 checkPatElem :: (Checkable rep) =>@@ -1244,14 +1242,14 @@ (Checkable rep) => FlatDimIndex SubExp -> TypeM rep ()-checkFlatDimIndex (FlatDimIndex n s) = mapM_ (require [Prim int64]) [n, s]+checkFlatDimIndex (FlatDimIndex n s) = mapM_ (require (Prim int64)) [n, s] checkFlatSlice :: (Checkable rep) => FlatSlice SubExp -> TypeM rep () checkFlatSlice (FlatSlice offset idxs) = do- require [Prim int64] offset+ require (Prim int64) offset mapM_ checkFlatDimIndex idxs checkStm ::@@ -1262,7 +1260,7 @@ checkStm stm@(Let pat aux e) m = do let Certs cs = stmAuxCerts aux (_, dec) = stmAuxDec aux- context "When checking certificates" $ mapM_ (requireI [Prim Unit]) cs+ context "When checking certificates" $ mapM_ (requireI $ Prim Unit) cs context "When checking expression annotation" $ checkExpDec dec context ("When matching\n" <> message " " pat <> "\nwith\n" <> message " " e) $ matchPat pat e@@ -1421,7 +1419,7 @@ checkPrimExp :: (Checkable rep) => PrimExp VName -> TypeM rep () checkPrimExp ValueExp {} = pure ()-checkPrimExp (LeafExp v pt) = requireI [Prim pt] v+checkPrimExp (LeafExp v pt) = requireI (Prim pt) v checkPrimExp (BinOpExp op x y) = do requirePrimExp (binOpType op) x requirePrimExp (binOpType op) y
src/Futhark/Internalise/Defunctionalise.hs view
@@ -8,7 +8,6 @@ import Data.Bifoldable (bifoldMap) import Data.Bifunctor import Data.Bitraversable-import Data.Foldable import Data.List (partition, sortOn) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as M
src/Futhark/Internalise/Exps.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Strict #-} {-# LANGUAGE TypeFamilies #-} @@ -395,7 +396,9 @@ let args'' = concatMap tag args' letValExp' desc $ I.Apply fname args'' [(I.Prim rettype, mempty)] Safe | otherwise -> do- args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)+ args' <-+ concat . reverse+ <$> mapM (internaliseArg arg_desc) (reverse args) funcall desc qfname args' internaliseAppExp desc _ (E.LetPat sizes pat e body _) = internalisePat desc sizes pat e $ internaliseExp desc body@@ -544,14 +547,24 @@ letBindNames [I.paramName p] $ BasicOp $ SubExp se- forM_ (zip mergepat' ses) $ \(p, se) ->- unless (se == I.Var (I.paramName p)) $- letBindNames [I.paramName p] $- case se of- I.Var v- | not $ primType $ paramType p ->- shapeCoerce (I.arrayDims $ paramType p) v- _ -> BasicOp $ SubExp se+ -- Is may be that one of the names in mergepat' are also in ses (and+ -- not in the same position), in which case we must be careful to+ -- avoid clobbering.+ let mergepat_names = map I.paramName mergepat'+ ses' <- forM ses $ \case+ I.Var v+ | v `elem` mergepat_names -> do+ v' <- newVName $ baseName v <> "_tmp"+ letBindNames [v'] $ I.BasicOp (I.SubExp $ I.Var v)+ pure $ I.Var v'+ se -> pure se+ forM_ (zip mergepat' ses') $ \(p, se) ->+ letBindNames [I.paramName p] $+ case se of+ I.Var v+ | not $ primType $ paramType p ->+ shapeCoerce (I.arrayDims $ paramType p) v+ _ -> BasicOp $ SubExp se subExpsRes <$> internaliseExp "loop_cond" cond loop_end_cond <- bodyBind loop_end_cond_body @@ -802,6 +815,14 @@ I.Prim pt -> pure $ constant $ blankPrimValue pt _ -> pure se+ I.AttrComp "param" [I.AttrName tag] -> do+ case e' of+ [se] -> do+ se_t <- I.subExpType se+ if se_t == I.Prim int64+ then fmap pure $ letSubExp desc $ I.BasicOp $ I.UserParam tag se+ else pure e'+ _ -> pure e' _ -> pure e' where
src/Futhark/Internalise/Lambdas.hs view
@@ -26,7 +26,7 @@ (params, body, rettype) <- internaliseLambda lam $ acctypes ++ rowtypes let rettype' = [ t `I.setArrayShape` I.arrayShape shape- | (t, shape) <- zip rettype acctypes+ | (t, shape) <- zip rettype acctypes ] -- The result of the body must have the exact same shape as the -- initial accumulator.
src/Futhark/Internalise/LiftLambdas.hs view
@@ -7,7 +7,6 @@ import Control.Monad.State import Data.Bifunctor import Data.Bitraversable-import Data.Foldable import Data.List (partition) import Data.Map.Strict qualified as M import Data.Maybe
src/Futhark/Internalise/Monomorphise.hs view
@@ -423,7 +423,7 @@ ) applySizeArgs fname' t size_args =- snd $+ setApplyLoc loc . snd $ foldl' (applySizeArg t) ( length size_args - 1,@@ -519,11 +519,9 @@ error "transformAppExp: LetFun is not supposed to occur" transformAppExp (If e1 e2 e3 loc) res = AppExp <$> (If <$> transformExp e1 <*> transformExp e2 <*> transformExp e3 <*> pure loc) <*> (Info <$> transformAppRes res)-transformAppExp (Apply fe args _) res =- mkApply- <$> transformExp fe- <*> mapM onArg (NE.toList args)- <*> transformAppRes res+transformAppExp (Apply fe args loc) res =+ setApplyLoc loc+ <$> (mkApply <$> transformExp fe <*> mapM onArg (NE.toList args) <*> transformAppRes res) where onArg (Info ext, e) = (ext,) <$> transformExp e transformAppExp (Loop sparams pat loopinit form body loc) res = do
src/Futhark/Internalise/TypesValues.hs view
@@ -28,7 +28,7 @@ import Data.Bifunctor import Data.Bitraversable (bitraverse) import Data.Foldable (toList)-import Data.List (delete, find, foldl')+import Data.List (delete, find) import Data.List qualified as L import Data.Map.Strict qualified as M import Data.Maybe@@ -149,7 +149,7 @@ [ if nonuniqueArray res_t then (res_t, RetAls pals rals) else (res_t, mempty)- | (res_t, pals, rals) <- zip3 (toList (Free res_ts)) palss ralss+ | (res_t, pals, rals) <- zip3 (toList (Free res_ts)) palss ralss ] where reorder [] = replicate (length (Free res_ts)) []
src/Futhark/LSP/Handlers.hs view
@@ -1,21 +1,34 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} -- | The handlers exposed by the language server. module Futhark.LSP.Handlers (handlers) where import Colog.Core (logStringStderr, (<&)) import Control.Lens ((^.))+import Control.Monad.Except (MonadError (throwError), liftEither)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Except (runExceptT) import Data.Aeson.Types (Value (Array, String))+import Data.Bifunctor (first)+import Data.Function ((&)) import Data.IORef import Data.Proxy (Proxy (..))+import Data.Text.Mixed.Rope qualified as R import Data.Vector qualified as V+import Futhark.Fmt.Printer (fmtToText) import Futhark.LSP.Compile (tryReCompile, tryTakeStateFromIORef) import Futhark.LSP.State (State (..)) import Futhark.LSP.Tool (findDefinitionRange, getHoverInfoFromState)+import Futhark.Util (showText)+import Futhark.Util.Pretty (prettyText)+import Language.Futhark.Core (locText)+import Language.Futhark.Parser.Monad (SyntaxError (SyntaxError)) import Language.LSP.Protocol.Lens (HasUri (uri)) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types-import Language.LSP.Server (Handlers, LspM, notificationHandler, requestHandler)+import Language.LSP.Server (Handlers, LspM, getVirtualFile, notificationHandler, requestHandler)+import Language.LSP.VFS (file_text) onInitializeHandler :: Handlers (LspM ()) onInitializeHandler = notificationHandler SMethod_Initialized $ \_msg ->@@ -81,6 +94,70 @@ notificationHandler SMethod_WorkspaceDidChangeConfiguration $ \_ -> logStringStderr <& "WorkspaceDidChangeConfiguration" +onDocumentFormattingHandler :: Handlers (LspM ())+onDocumentFormattingHandler =+ requestHandler SMethod_TextDocumentFormatting $ \message report ->+ let TRequestMessage _ _ _ formattingParams = message+ DocumentFormattingParams _progressToken textDoc _opts = formattingParams+ fileUri = textDoc ^. uri+ in do+ logStringStderr <& ("Formatting: " ++ show (textDoc ^. uri))+ result <- runExceptT $ do+ virtualFile <- getVirtualFile' fileUri+ let fileText = R.toText $ virtualFile ^. file_text+ formattedText <- fmtToText' (show fileUri) fileText+ pure $+ if formattedText == fileText+ then InR Null+ else InL [fullTextEdit formattedText]++ logStringStderr <& show result+ report result+ where+ fullTextEdit newText =+ TextEdit+ { _newText = newText,+ _range =+ Range+ { _start =+ Position+ { _line = 0,+ _character = 0+ },+ _end =+ Position+ { -- defaults back to real lines, as documented in @lsp-types@+ _line = maxBound,+ _character = maxBound+ }+ }+ }++ fmtToText' fname ftext =+ fmtToText fname ftext+ & first syntaxErrorResponse+ & liftEither++ getVirtualFile' fileUri = do+ maybeFile <- lift $ getVirtualFile (toNormalizedUri fileUri)+ case maybeFile of+ Nothing -> throwError $ noSuchDocumentResponse fileUri+ Just f -> pure f++ syntaxErrorResponse (SyntaxError loc msg) =+ TResponseError+ { _code = InR ErrorCodes_ParseError,+ _message = "Syntax Error at " <> locText loc <> ":\n" <> prettyText msg,+ _xdata = Nothing+ }++ noSuchDocumentResponse fileUri =+ TResponseError+ { _xdata = Nothing,+ _message = "Failed to retrieve document at " <> showText fileUri,+ _code = InR ErrorCodes_InvalidParams+ }+ -- | Given an 'IORef' tracking the state, produce a set of handlers. -- When we want to add more features to the language server, this is -- the thing to change.@@ -90,6 +167,7 @@ [ onInitializeHandler, onDocumentOpenHandler, onDocumentCloseHandler,+ onDocumentFormattingHandler, onDocumentSaveHandler state_mvar, onDocumentChangeHandler state_mvar, onDocumentFocusHandler state_mvar,
src/Futhark/Optimise/CSE.hs view
@@ -217,8 +217,8 @@ let lets = [ Let (Pat [patElem']) aux $ BasicOp (SubExp $ Var $ patElemName patElem)- | (name, patElem) <- zip (patNames pat') $ patElems subpat,- let patElem' = patElem {patElemName = name}+ | (name, patElem) <- zip (patNames pat') $ patElems subpat,+ let patElem' = patElem {patElemName = name} ] m lets _ ->
src/Futhark/Optimise/Fusion/Composing.hs view
@@ -69,14 +69,14 @@ lam2 { lambdaParams = [ Param mempty name t- | Ident name t <- lam2redparams ++ M.keys inputmap+ | Ident name t <- lam2redparams ++ M.keys inputmap ], lambdaBody = new_body2' } new_body2 = let stms res = [ certify cs $ mkLet [p] $ BasicOp $ SubExp e- | (p, SubExpRes cs e) <- zip pat res+ | (p, SubExpRes cs e) <- zip pat res ] bindLambda res = stmsFromList (stms res) `insertStms` makeCopiesInner (lambdaBody lam2)
src/Futhark/Optimise/Fusion/TryFusion.hs view
@@ -574,7 +574,7 @@ where inps' = [ (SOAC.inputArray inp `elem` interesting, inp)- | inp <- inps+ | inp <- inps ] commonTransforms' :: [(Bool, SOAC.Input)] -> (SOAC.ArrayTransforms, [SOAC.Input])
src/Futhark/Optimise/InliningDeadFun.hs view
@@ -185,6 +185,10 @@ any arrayInBody $ defbody : map caseBody cases arrayInExp (Loop _ _ body) = arrayInBody body+ -- Might be indexing a global array, see #2341. This one could perhaps be+ -- fixed.+ arrayInExp (BasicOp Index {}) =+ True arrayInExp _ = False -- Conservative inlining of functions that are called just once, or@@ -265,7 +269,9 @@ | Just fd <- M.lookup fname fdmap, not $ "noinline" `inAttrs` funDefAttrs fd, not $ "noinline" `inAttrs` stmAuxAttrs aux =- (<>) <$> inlineFunction pat aux args safety (stmAuxLoc aux) fd <*> inline rest+ (<>)+ <$> inlineFunction pat aux args safety (stmAuxLoc aux) fd+ <*> inline rest inline (stm@(Let _ _ BasicOp {}) : rest) = (oneStm stm <>) <$> inline rest inline (stm : rest) =
src/Futhark/Optimise/ReduceDeviceSyncs.hs view
@@ -11,7 +11,6 @@ import Control.Monad.Reader import Control.Monad.State hiding (State) import Data.Bifunctor (second)-import Data.Foldable import Data.IntMap.Strict qualified as IM import Data.List (transpose, zip4) import Data.Map.Strict qualified as M
src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs view
@@ -502,6 +502,9 @@ -- END BasicOp UpdateAcc {} -> graphUpdateAcc (one bs) e+ BasicOp (UserParam _name def) -> do+ graphSimple bs e+ one bs `reusesSubExp` def Apply fn _ _ _ -> graphApply fn bs e Match ses cases defbody _ ->
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -68,7 +68,7 @@ import Control.Monad.State.Strict import Data.Bitraversable import Data.Either-import Data.List (find, foldl', inits, mapAccumL)+import Data.List (find, inits, mapAccumL) import Data.Map qualified as M import Data.Maybe import Futhark.Analysis.SymbolTable qualified as ST
src/Futhark/Optimise/Simplify/Rules/BasicOp.hs view
@@ -8,7 +8,7 @@ where import Control.Monad-import Data.List (find, foldl', isSuffixOf, sort)+import Data.List (find, isSuffixOf, sort) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import Futhark.Analysis.PrimExp.Convert
src/Futhark/Optimise/Simplify/Rules/Loop.hs view
@@ -105,32 +105,28 @@ namesOfLoopParams = namesFromList $ map (paramName . fst) merge - removeFromResult cs (mergeParam, mergeInit) explpat' =+ removeFromResult (mergeParam, mergeInit) explpat' = case partition ((== paramName mergeParam) . snd) explpat' of ([(patelem, _)], rest) ->- (Just (patElemIdent patelem, (mergeInit, cs)), rest)+ (Just (patElemIdent patelem, (mergeInit, mempty)), rest) (_, _) -> (Nothing, explpat') checkInvariance (pat_name, (mergeParam, mergeInit), resExp) (invariant, explpat', merge', resExps)- | isInvariant,- -- Certificates must be available.- all (`ST.elem` vtable) $ unCerts $ resCerts resExp =- let (stm, explpat'') =- removeFromResult- (resCerts resExp)- (mergeParam, mergeInit)- explpat'+ | isInvariant =+ let -- Remove certificates (some of which may be loop-variant)+ -- because this corresponds to dead code anyway.+ (stm, explpat'') = removeFromResult (mergeParam, mergeInit) explpat' in ( maybe id (:) stm $- (paramIdent mergeParam, (mergeInit, resCerts resExp)) : invariant,+ (paramIdent mergeParam, (mergeInit, mempty)) : invariant, explpat'', merge', resExps ) where- -- A non-unique merge variable is invariant if one of the+ -- A loop parameter is invariant if one of the -- following is true: isInvariant -- (0) The result is a variable of the same name as the
src/Futhark/Optimise/Simplify/Rules/Match.hs view
@@ -90,7 +90,7 @@ addStms $ bodyStms tbranch sequence_ [ certifying cs $ letBindNames [patElemName p] $ BasicOp $ SubExp se- | (p, SubExpRes cs se) <- zip (patElems pat) ses+ | (p, SubExpRes cs se) <- zip (patElems pat) ses ] ruleMatch _ pat _ ([cond], [Case [Just (BoolValue True)] tb], fb, _) | Body _ _ [SubExpRes tcs (Constant (IntValue t))] <- tb,
src/Futhark/Optimise/Sink.hs view
@@ -45,7 +45,6 @@ import Control.Monad.State import Data.Bifunctor-import Data.List (foldl') import Data.Map qualified as M import Futhark.Analysis.Alias qualified as Alias import Futhark.Analysis.SymbolTable qualified as ST
src/Futhark/Optimise/TileLoops.hs view
@@ -1108,8 +1108,7 @@ fmap varsRes $ letTupExp "acc" =<< eIf- ( toExp $ le64 gtid_x .<. pe64 kdim_x .&&. le64 gtid_y .<. pe64 kdim_y- )+ (toExp $ le64 gtid_x .<. pe64 kdim_x .&&. le64 gtid_y .<. pe64 kdim_y) (eBody [pure $ Op $ OtherOp $ Screma actual_tile_size tiles' form']) (resultBodyM thread_accs)
@@ -21,7 +21,7 @@ import Control.Monad import Control.Monad.Reader import Control.Monad.State-import Data.List (foldl', zip4)+import Data.List (zip4) import Data.Map qualified as M import Data.Maybe import Futhark.IR.GPU
src/Futhark/Pass/ExpandAllocations.hs view
@@ -10,7 +10,7 @@ import Control.Monad.Writer import Data.Bifunctor import Data.Either (rights)-import Data.List (find, foldl')+import Data.List (find) import Data.Map.Strict qualified as M import Data.Maybe import Data.Sequence qualified as Seq
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -40,7 +40,7 @@ import Control.Monad.Writer import Data.Bifunctor (first) import Data.Either (partitionEithers)-import Data.List (foldl', transpose, zip4)+import Data.List (transpose, zip4) import Data.Map.Strict qualified as M import Data.Maybe import Data.Set qualified as S
src/Futhark/Pass/ExtractKernels/Distribution.hs view
@@ -280,7 +280,7 @@ i <- newVName "gtid" let inps = [ KernelInput pname ptype arr [Var i]- | (Param _ pname ptype, arr) <- params_and_arrs+ | (Param _ pname ptype, arr) <- params_and_arrs ] pure ([(i, nesting_w)], inps) flatKernel (MapNesting _ _ nesting_w params_and_arrs, nest : nests) = do@@ -303,7 +303,7 @@ where extra_inps i = [ KernelInput pname ptype arr [Var i]- | (Param _ pname ptype, arr) <- params_and_arrs+ | (Param _ pname ptype, arr) <- params_and_arrs ] -- | Description of distribution to do.
src/Futhark/Pkg/Info.hs view
@@ -2,8 +2,6 @@ module Futhark.Pkg.Info ( -- * Package info PkgInfo (..),- lookupPkgRev,- pkgInfo, PkgRevInfo (..), GetManifest (getManifest), GetFiles (getFiles),
src/Futhark/Pkg/Types.hs view
@@ -261,7 +261,7 @@ required <- ( lexstr "require" *> braces (many $ (Left <$> pComment) <|> (Right <$> pRequired))- )+ ) <|> pure [] c3 <- pComments eof
+ src/Futhark/Profile/Details.hs view
@@ -0,0 +1,34 @@+module Futhark.Profile.Details (CostCentreDetails (..), SourceRangeDetails (..), CostCentreName (..), sourceRangeDetailsFraction, CostCentres, SourceRanges) where++import Control.Arrow ((>>>))+import Data.Map (Map)+import Data.Monoid (Sum (Sum, getSum))+import Data.Text (Text)+import Futhark.Profile.EventSummary (EvSummary)+import Futhark.Profile.SourceRange (SourceRange)++type CostCentres = Map CostCentreName CostCentreDetails++type SourceRanges = Map SourceRange SourceRangeDetails++newtype CostCentreName = CostCentreName {getCostCentreName :: Text}+ deriving (Eq, Ord)++data CostCentreDetails = CostCentreDetails+ { -- | Fraction of total program time spent in this cost centre+ fraction :: Double,+ -- | all source ranges included in this cost centre+ sourceRanges :: Map SourceRange SourceRangeDetails,+ -- | statistics about the runtime characteristics+ summary :: EvSummary+ }++newtype SourceRangeDetails = SourceRangeDetails+ { containingCostCentres :: Map CostCentreName CostCentreDetails+ }++sourceRangeDetailsFraction :: SourceRangeDetails -> Double+sourceRangeDetailsFraction =+ containingCostCentres+ >>> foldMap (Sum . fraction)+ >>> getSum
+ src/Futhark/Profile/EventSummary.hs view
@@ -0,0 +1,21 @@+module Futhark.Profile.EventSummary (EvSummary (..), eventSummaries) where++import Data.Map qualified as M (Map, fromListWith)+import Data.Text qualified as T (Text)+import Futhark.Profile (ProfilingEvent (ProfilingEvent))++data EvSummary = EvSummary+ { evCount :: Integer,+ evSum :: Double,+ evMin :: Double,+ evMax :: Double+ }+ deriving (Show)++eventSummaries :: [ProfilingEvent] -> M.Map (T.Text, T.Text) EvSummary+eventSummaries = M.fromListWith comb . map pair+ where+ pair (ProfilingEvent name dur provenance _details) =+ ((name, provenance), EvSummary 1 dur dur dur)+ comb (EvSummary xn xdur xmin xmax) (EvSummary yn ydur ymin ymax) =+ EvSummary (xn + yn) (xdur + ydur) (min xmin ymin) (max xmax ymax)
+ src/Futhark/Profile/Html.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE QuasiQuotes #-}++module Futhark.Profile.Html (securedHashPath, generateHeatmapHtml, generateCCOverviewHtml, generateHtmlIndex) where++import Control.Monad (join)+import Control.Monad.State.Strict (State, evalState, get, modify)+import Data.Bifunctor (bimap, first, second)+import Data.Function ((&))+import Data.List (sortOn)+import Data.Loc (posFile)+import Data.Map qualified as M+import Data.Ord (Down (Down))+import Data.Set (Set)+import Data.String (IsString (fromString))+import Data.Text qualified as T+import Data.Word (Word8)+import Futhark.Profile.Details (CostCentreDetails (CostCentreDetails, summary), CostCentreName (CostCentreName, getCostCentreName), CostCentres, SourceRangeDetails (SourceRangeDetails, containingCostCentres), SourceRanges, sourceRangeDetailsFraction)+import Futhark.Profile.Details qualified as D+import Futhark.Profile.EventSummary qualified as ES+import Futhark.Profile.SourceRange qualified as SR+import Futhark.Util (hashText, showText)+import Futhark.Util.Html (headHtml, headHtmlWithCss, relativise)+import NeatInterpolation qualified as NI (text, trimming)+import System.FilePath (takeFileName, (<.>), (</>))+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A+import Text.Printf (printf)+import Prelude hiding (span)++securedHashPath :: FilePath -> FilePath+securedHashPath p =+ T.unpack (hashText $ T.pack p) <> "-" <> takeFileName p++type SourcePos = (Int, Int)++data RenderState = RenderState+ { _renderPos :: !SourcePos,+ remainingText :: !T.Text+ }++generateHtmlIndex ::+ -- | Path of the bench dir+ FilePath ->+ M.Map FilePath SourceRanges ->+ CostCentres ->+ H.Html+generateHtmlIndex benchDir _pathToSourceRanges _costCentres = do+ H.docTypeHtml $ do+ headHtmlWithCss (benchDir </> "style.css") pageTitle+ H.h2 $ H.string pageTitle+ introductionIndex (T.pack benchDir)+ sourceFileIndex benchDir (M.keysSet _pathToSourceRanges)+ where+ pageTitle = "Source File Index"++introductionIndex :: T.Text -> H.Html+introductionIndex benchDir = do+ H.text+ [NI.trimming|+ This is the index file for the benchmark files in $benchDir.+ The generated profile markup consists of highlighted source files+ and the cost centre overview.+ |]+ H.h4 "Highlighted Source Files"+ H.text+ [NI.trimming|+ All the source files that were contained in any cost centre for this+ benchmark were higlighted and rendered.+ This means that source ranges are shown with a background+ color progressing from green to yellow to red, depending on the+ amount of total time spent in cost centres containing this range.+ Not every source location gets a color, that is because some parts+ are simply optimized out or were not needed for the compilation of+ this benchmark.+ At the bottom of each Source File there is a listing of all ranges+ in the source file and which cost centres affected the coloring.+ |]+ H.h4 $+ H.a ! A.href (fromString $ T.unpack benchDir </> "cost-centres.html") $+ H.text "Cost Centre Overview"+ H.text+ [NI.trimming|+ The Cost Centre Overview contains all the cost centres recorded+ during the last run of the benchmark. For every cost centre, there+ is a table with statistics and also a list with links to all+ relevant source ranges.+ |]++sourceFileIndex :: FilePath -> Set FilePath -> H.Html+sourceFileIndex benchDir paths = do+ H.h3 $ H.text "Source Files (ordered alphabetically)"+ H.ul $ do+ mapM_ pathListEntry paths+ where+ pathListEntry path =+ H.li+ $ H.a+ ! A.href (fromString pathRef)+ $ H.string path+ where+ pathRef = benchDir </> securedHashPath path <.> ".html"++generateHeatmapHtml ::+ -- | Path where this Html will be placed+ FilePath ->+ -- | Path where the corresponding source was+ FilePath ->+ -- | Source File Text+ T.Text ->+ -- | Non-Overlapping Source Ranges+ M.Map SR.SourceRange SourceRangeDetails ->+ H.Html+generateHeatmapHtml htmlPath sourcePath sourceText sourceRanges =+ H.docTypeHtml $ do+ headHtml htmlPath (sourcePath <> " - Source-Heatmap")+ heatmapBodyHtml htmlPath sourceText sourceRanges++generateCCOverviewHtml :: M.Map CostCentreName CostCentreDetails -> H.Html+generateCCOverviewHtml costCentres = do+ headHtml "cost-centres.html" "Cost Centre Overview"+ H.body $ do+ H.h2 $ H.text "Cost Centre Table (ordered by fraction)"+ ccTable++ H.h2 $ H.text "Cost Centre Details (ordered by fraction)"+ ccDetailTables+ where+ orderAscending = sortOn (Down . D.fraction . snd)+ ccTable = H.table ! A.class_ "cctable" $ do+ H.tr $+ mapM_+ H.th+ [ "Name",+ "Fraction",+ "Event Count",+ "Total Time (µs)",+ "Minimum Time (µs)",+ "Maximum Time (µs)"+ ]+ mapM_ (uncurry row) . orderAscending $ M.toList costCentres+ where+ row (CostCentreName name) (CostCentreDetails fraction _ summary) =+ H.tr $ do+ H.td+ $ fractionColored fraction+ $ H.a+ ! A.href (fromString $ '#' : T.unpack name)+ ! A.class_ "silent-anchor"+ ! A.title "Click to jump to details"+ $ H.text name+ mapM_+ (H.td . H.string)+ [ printf "%.4f" fraction,+ show $ ES.evCount summary,+ printf "%.2f" $ ES.evSum summary,+ printf "%.2f" $ ES.evMin summary,+ printf "%.2f" $ ES.evMax summary+ ]++ ccDetailTables =+ M.toList costCentres+ & orderAscending+ & mapM_ (uncurry renderCostCentreDetails)++renderCostCentreDetails :: CostCentreName -> CostCentreDetails -> H.Html+renderCostCentreDetails (CostCentreName ccName) (CostCentreDetails ratio sourceRanges summary) = do+ title+ summaryTable+ sourceRangeListing+ where+ title =+ H.h3+ ! A.id (fromString $ T.unpack ccName)+ $ fractionColored ratio+ $ H.a+ ! A.href (fromString $ '#' : T.unpack ccName)+ ! A.class_ "silent-anchor"+ $ H.text ccName++ summaryTable =+ H.table ! A.class_ "cctable" $+ mapM_+ row+ [ ("Fraction", T.pack $ printf "%.4f" ratio),+ ("Event Count", showText count),+ ("Total Time (µs)", T.pack $ printf "%.2f" sum_),+ ("Minimum Time (µs)", T.pack $ printf "%.2f" min_),+ ("Maximum Time (µs)", T.pack $ printf "%.2f" max_)+ ]+ where+ (ES.EvSummary count sum_ min_ max_) = summary+ row (h, d) = H.tr $ do+ H.th $ H.text h+ H.td $ H.text d++ sourceRangeListing = do+ H.h4 $ H.text "Source Ranges"+ H.ol $+ mapM_ (uncurry entry) (M.toList sourceRanges)+ where+ entry range details =+ H.li+ $ fractionColored (sourceRangeDetailsFraction details)+ $ H.a+ ! A.href (fromString entryRef)+ ! A.class_ "silent-anchor"+ ! A.title "Click to Jump to Source"+ $ H.text+ $ sourceRangeText range <> " in " <> T.pack rangeFile+ where+ rangeFile = posFile $ SR.startPos range+ rangeHtmlFile = securedHashPath rangeFile+ entryRef = rangeHtmlFile <> ".html#" <> sourceRangeSpanCssId range++heatmapBodyHtml :: FilePath -> T.Text -> M.Map SR.SourceRange SourceRangeDetails -> H.Html+heatmapBodyHtml sourcePath sourceText sourceRanges =+ H.body $ do+ sourceCodeListing+ detailTables+ where+ rangeList = M.toAscList sourceRanges++ sourceCodeListing =+ H.code . H.pre $+ renderRanges (RenderState (1, 1) sourceText) rangeList++ detailTables = mapM_ (uncurry $ sourceRangeDetails sourcePath) rangeList++sourceRangeDetails :: FilePath -> SR.SourceRange -> SourceRangeDetails -> H.Html+sourceRangeDetails currentPath range details@(SourceRangeDetails ccs) = detailDiv $ do+ H.h3 $ do+ H.text "Source Range from "+ toSpanAnchor $ fractionColored ratio $ H.span $ H.text rangeText++ costCentreTable+ where+ ratio = sourceRangeDetailsFraction details+ costCentreTable = do+ H.h4 $ H.text "Cost Centres"+ H.table $ do+ H.tr $ do+ mapM_+ H.th+ [ "Name",+ "Event Count",+ "Total Time (µs)",+ "Minimum Time (µs)",+ "Maximum Time (µs)",+ "Fraction"+ ]++ mapM_ evRow $+ M.toAscList ccs+ & fmap (first getCostCentreName)++ H.tr $ do+ H.td $ H.text "Total"+ H.td $ H.text $ showText $ ES.evCount evTotal+ mapM_+ (H.td . H.text . T.pack . printf "%.2f")+ [ ES.evSum evTotal,+ ES.evMin evTotal,+ ES.evMax evTotal,+ ratio+ ]+ where+ evRow (ccName, CostCentreDetails fraction _ ev) = H.tr $ do+ mapM_+ H.td+ [ fractionColored fraction+ $ H.span+ ! A.title "Click to jump to Cost Centre Overview"+ $ H.a+ ! A.href+ ( fromString $+ relativise "cost-centres.html" currentPath+ <> "#"+ <> T.unpack ccName+ )+ ! A.class_ "silent-anchor"+ $ H.text ccName,+ H.text . showText . ES.evCount $ ev,+ H.text . T.pack . printf "%.2f" . ES.evSum $ ev,+ H.text . T.pack . printf "%.2f" . ES.evMin $ ev,+ H.text . T.pack . printf "%.2f" . ES.evMax $ ev,+ H.text . T.pack . printf "%.4f" $ fraction+ ]+ evTotal =+ M.toList ccs+ & fmap (summary . snd)+ & foldl' combine (ES.EvSummary 0 0 infPos infNeg)+ where+ combine (ES.EvSummary c s lo hi) (ES.EvSummary c' s' lo' hi') =+ ES.EvSummary (c + c') (s + s') (min lo lo') (max hi hi')+ infPos = read "Infinity"+ infNeg = negate infPos++ toSpanAnchor =+ H.a+ ! A.href (fromString $ '#' : sourceRangeSpanCssId range)+ ! A.class_ "silent-anchor"+ ! A.title "Click to jump to source"++ detailDiv =+ H.div+ ! A.id (fromString $ sourceRangeDetailsCssId range)++ rangeText = sourceRangeText range++sourceRangeText :: SR.SourceRange -> T.Text+sourceRangeText range = [NI.text|$lineStart:$colStart to $lineEnd:$colEnd|]+ where+ (lineStart, colStart) = join bimap showText $ SR.startLineCol range+ (lineEnd, colEnd) = join bimap showText $ SR.endLineCol range++-- | Assumes that the annotated ranges are non-overlapping and in ascending order+renderRanges ::+ RenderState ->+ [(SR.SourceRange, SourceRangeDetails)] ->+ -- range, fraction, costCentreCount+ H.Html+renderRanges state [] = H.text . remainingText $ state+renderRanges (RenderState pos text) rs@((range, details) : rest) =+ let rangePos = SR.startLineCol range+ in case pos `compare` rangePos of+ GT -> error "Impossible: Ranges were not in ascending order"+ EQ -> do+ let rangeEndPos = SR.endLineCol range+ let (textHtml, text') = renderTextFromUntil pos rangeEndPos text+ let fraction = sourceRangeDetailsFraction details+ let evCount = M.size $ containingCostCentres details++ decorateSpan range fraction evCount textHtml+ renderRanges (RenderState rangeEndPos text') rest+ LT -> do+ let (textHtml, text') = renderTextFromUntil pos rangePos text+ textHtml+ renderRanges (RenderState rangePos text') rs++sourceRangeSpanCssId :: SR.SourceRange -> String+sourceRangeSpanCssId range = printf "range-l%i-c%i" startLine startCol+ where+ (startLine, startCol) = SR.startLineCol range++sourceRangeDetailsCssId :: SR.SourceRange -> String+sourceRangeDetailsCssId range = "detail-table-" <> sourceRangeSpanCssId range++decorateSpan :: SR.SourceRange -> Double -> Int -> H.Html -> H.Html+decorateSpan range fraction evCount = span . anchor+ where+ anchor =+ H.a+ ! A.class_ "silent-anchor"+ ! A.href (fromString $ '#' : sourceRangeDetailsCssId range)++ spanCssId = sourceRangeSpanCssId range++ span =+ fractionColored fraction+ . ( H.span+ ! A.id (fromString spanCssId)+ ! A.title (fromString $ T.unpack cssHoverText)+ )+ where+ cssHoverText =+ [NI.trimming|Fraction of the total runtime: $textFraction+ Part of $textEvCount cost centres.+ (Click to jump to detail table)+ |]+ where+ textEvCount = showText evCount+ textFraction = T.pack $ printf "%.4f" fraction++fractionColored :: Double -> H.Html -> H.Html+fractionColored fraction = (! A.style cssColorValue)+ where+ cssColorValue =+ fromString . T.unpack $+ [NI.text|background: rgba($textR, $textG, $textB, 1)|]+ where+ (textR, textG, textB) = (showText r, showText g, showText b)+ (r, g, b) = interpolateHeatmapColor fraction++-- | Percentage Argument must be smaller in [0; 1]+interpolateHeatmapColor :: Double -> (Word8, Word8, Word8)+interpolateHeatmapColor percentage =+ if percentage >= 0.5+ then+ let point = (percentage - 0.5) * 2+ -- less is more red, interpolate towards 0+ g = 255 - point * 255+ in (255, round g, 0)+ else+ let point = percentage * 2+ r = 128 + 127 * point+ in (round r, 255, 0)+ where+ _red, _yellow, _green :: (Word8, Word8, Word8)+ _red = (255, 0, 0)+ _yellow = (255, 255, 0)+ _green = (128, 255, 0)++-- >>> splitTextFromTo (4, 40) (4, 43) "abc\ndef"+-- ("abc","\ndef")++splitTextFromTo :: SourcePos -> (Int, Int) -> T.Text -> (T.Text, T.Text)+splitTextFromTo startPos endPos t =+ flip evalState startPos $+ T.spanM stepChar t+ where+ -- general category @LineSeparator@ is not used for Newlines+ isNewline c = case c of+ '\n' -> True+ '\r' -> True+ _ -> False++ stepChar :: Char -> State SourcePos Bool+ stepChar char = do+ -- do the check at the start, this way the last character is always included+ oldPos <- get++ modify $+ if isNewline char+ then \(l, _) -> (succ l, 1)+ else second succ++ pure (oldPos /= endPos)++renderTextFromUntil :: SourcePos -> SourcePos -> T.Text -> (H.Html, T.Text)+renderTextFromUntil startPos endPos t =+ let (included, rest) = splitTextFromTo startPos endPos t+ in (H.text included, rest)
+ src/Futhark/Profile/SourceRange.hs view
@@ -0,0 +1,175 @@+module Futhark.Profile.SourceRange (SourceRange (..), startLineCol, endLineCol, filter123, overlapsWith, mergeSemigroup, parse, fileName) where++import Control.Arrow ((&&&))+import Control.Monad (void, when)+import Data.Bifunctor (first)+import Data.Loc (Pos (Pos), posCol, posFile, posLine)+import Data.Text qualified as T+import Data.Void (Void)+import Text.Megaparsec qualified as P+import Text.Megaparsec.Char.Lexer qualified as L++-- | I chose this representation over `Loc` from `srcLoc` because it guarantees the presence of a range.+-- Loc is essentially a 'Maybe (Pos, Pos)', because of the 'NoLoc' constructor.+-- I cannot even imagine dealing with cross-file ranges anyway.++-- The end of the range is exclusive+data SourceRange = SourceRange+ { startPos :: !Pos,+ -- | invariant: at least a big as start.line+ endLine :: !Int,+ -- | invariant: at least as big as start.col, unless the range spans multiple lines+ endColumn :: !Int+ }+ deriving (Show, Eq, Ord)++fileName :: SourceRange -> FilePath+fileName = posFile . startPos++-- | Extract start line and column+startLineCol :: SourceRange -> (Int, Int)+startLineCol (SourceRange pos _ _) = (posLine pos, posCol pos)++-- | Extract end line and column+endLineCol :: SourceRange -> (Int, Int)+endLineCol (SourceRange _ line col) = (line, col)++overlapsWith :: SourceRange -> SourceRange -> Bool+overlapsWith a b =+ -- since the end is exclusive, I need to use a different operator+ let rangeOverlaps (sa, ea) (sb, eb) = sa < eb && sb < ea+ startA = startLineCol a+ endA = endLineCol a+ startB = startLineCol b+ endB = endLineCol b+ in rangeOverlaps (startA, endA) (startB, endB)++-- >>> isEmpty $ SourceRange {sourceRangeStartPos = Pos "Futhark.fut" 4 40 (-1), sourceRangeEndLine = 4, sourceRangeEndColumn = 40}+-- True++isEmpty :: SourceRange -> Bool+isEmpty (SourceRange (Pos _ startLine startCol _) endLine endCol) =+ startLine == endLine && startCol == endCol++-- | Parse a source range, respect the invariants noted in the definition+-- and print the MegaParsec errorbundle into a Text.+--+-- >>> parse "example.fut:1:1-5"+-- Right (SourceRange {start = Pos "example.fut" 1 1 (-1), endLine = 1, endColumn = 5})+--+-- >>> parse "directory/example.fut:15:12-17:1"+-- Right (SourceRange {start = Pos "directory/example.fut" 15 12 (-1), endLine = 17, endColumn = 1})+parse :: T.Text -> Either T.Text SourceRange+parse text = first textErrorBundle $ P.parse pSourceRange fname text+ where+ fname = ""+ textErrorBundle = T.pack . P.errorBundlePretty++ lineRangeInvariantMessage =+ "End of Line Range is not bigger than or equal to Start of Line Range."+ columnRangeInvariantMessage =+ "End of Column Range is not bigger than or equal to Start of Column Range"++ pSourceRange :: P.Parsec Void T.Text SourceRange+ pSourceRange = do+ filePath <- L.charLiteral `P.manyTill` P.single ':' -- separator+ startLine <- L.decimal+ void $ P.single ':' -- separator+ startCol <- L.decimal++ void $ P.single '-' -- range begin+ rangeEnd1 <- L.decimal+ -- we can't know yet whether this is going to be a line or column position++ (lineRangeEnd, columnRangeEnd) <-+ P.choice+ [ do+ endCol <- P.single ':' *> L.decimal+ pure (rangeEnd1, endCol),+ pure (startLine, rangeEnd1)+ ]++ let lineRangeInvalid = startLine > lineRangeEnd+ when lineRangeInvalid $ fail lineRangeInvariantMessage++ let columnRangeInvalid =+ startLine == lineRangeEnd && startCol > columnRangeEnd+ when columnRangeInvalid $ fail columnRangeInvariantMessage++ pure $+ SourceRange+ { startPos = Pos filePath startLine startCol (-1),+ endLine = lineRangeEnd,+ endColumn = columnRangeEnd+ }++-- | Assumes that the ranges overlap+mergeSemigroup ::+ (Semigroup s) =>+ (SourceRange, s) ->+ (SourceRange, s) ->+ OneTwoThree (SourceRange, s)+mergeSemigroup a@(rangeA, auxA) b@(rangeB, auxB) =+ let orderedBy f x y = if f x < f y then (x, y) else (y, x)+ (startsEarlier, startsLater) = orderedBy (startLineCol . fst) a b++ startsLaterStart = startLineCol . fst $ startsLater+ fname = posFile . startPos $ rangeA++ (endsEarlier, endsLater) =+ orderedBy+ ((endLine &&& endColumn) . fst)+ a+ b++ firstRange =+ (fst startsEarlier)+ { endLine = fst startsLaterStart,+ endColumn = snd startsLaterStart+ }+ secondRange =+ (fst startsLater)+ { endLine = endLine . fst $ endsEarlier,+ endColumn = endColumn . fst $ endsEarlier+ }++ thirdRange =+ let startLine = endLine secondRange+ startCol = endColumn secondRange+ in (fst endsLater)+ { startPos = Pos fname startLine startCol (-1)+ }++ rawRanges =+ Three+ (firstRange, snd startsEarlier)+ (secondRange, auxA <> auxB)+ (thirdRange, snd endsLater)+ in case filter123 (not . isEmpty . fst) rawRanges of+ Nothing ->+ error . unwords $+ [ "Impossible! `mergeRanges` produced no range at all, input ranges:",+ show rangeA,+ show rangeB+ ]+ Just merged -> merged++data OneTwoThree a = One a | Two a a | Three a a a+ deriving (Show, Functor, Foldable)++filter123 :: (a -> Bool) -> OneTwoThree a -> Maybe (OneTwoThree a)+filter123 p self@(One x) = if p x then Just self else Nothing+filter123 p self@(Two x y) = case (p x, p y) of+ (True, True) -> Just self+ (True, False) -> Just (One x)+ (False, True) -> Just (One y)+ (False, False) -> Nothing+filter123 p self@(Three x y z) = case (p x, p y, p z) of+ (False, False, False) -> Nothing+ (False, False, True) -> Just (One z)+ (False, True, False) -> Just (One y)+ (False, True, True) -> Just (Two y z)+ (True, False, False) -> Just (One x)+ (True, False, True) -> Just (Two x z)+ (True, True, False) -> Just (Two x y)+ (True, True, True) -> Just self
src/Futhark/Script.hs view
@@ -42,7 +42,6 @@ import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Char-import Data.Foldable (toList) import Data.Functor import Data.IORef import Data.List (intersperse)@@ -306,11 +305,11 @@ -- | The set of server-side variables in the value. serverVarsInValue :: ExpValue -> S.Set VarName-serverVarsInValue = S.fromList . concatMap isVar . toList+serverVarsInValue = S.fromList . concatMap isVar where isVar (SValue _ (VVar x)) = [x] isVar (SValue _ (VVal _)) = []- isVar (SFun _ _ _ closure) = concatMap isVar $ toList closure+ isVar (SFun _ _ _ closure) = concatMap isVar closure -- | Convert a value into a corresponding expression. valueToExp :: ExpValue -> Exp@@ -654,7 +653,8 @@ -- Allow automatic uncurrying if applicable. case es' of- [V.ValueTuple es''] | length es'' == length in_types -> tryApply es''+ [V.ValueTuple es'']+ | length es'' == length in_types -> tryApply es'' _ -> tryApply es' evalExp' _ (StringLit s) = case V.putValue s of
src/Futhark/Test.hs view
@@ -198,8 +198,16 @@ | otherwise = cmdMaybe $ cmdRestore server (dir </> file) names_and_types valuesAsVars server names_and_types futhark dir (GenValues gens) = do- unless (length gens == length names_and_types) $- throwError "Mismatch between number of expected and generated values."+ unless (length gens == length names_and_types) . throwError . T.unlines $+ [ "Expected "+ <> showText (length names_and_types)+ <> " input values of types",+ " " <> T.unwords (map snd names_and_types),+ "Provided "+ <> showText (length gens)+ <> " input values of types",+ " " <> T.unwords (map genValueType gens)+ ] gen_fs <- mapM (getGenFile futhark dir) gens forM_ (zip gen_fs names_and_types) $ \(file, (v, t)) -> cmdMaybe $ cmdRestore server (dir </> file) [(v, t)]
src/Futhark/Transform/FirstOrderTransform.hs view
@@ -410,7 +410,7 @@ loopMerge' :: [(Ident, Uniqueness)] -> [SubExp] -> [(Param DeclType, SubExp)] loopMerge' vars vals = [ (Param mempty pname $ toDecl ptype u, val)- | ((Ident pname ptype, u), val) <- zip vars vals+ | ((Ident pname ptype, u), val) <- zip vars vals ] -- Note [Translation of Screma]
+ src/Futhark/Util/Html.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}++module Futhark.Util.Html+ ( relativise,+ headHtmlWithCss,+ headHtml,+ cssFile,+ )+where++import Data.FileEmbed (embedStringFile)+import Data.String (fromString)+import Data.Text qualified as T+import System.FilePath (makeRelative, splitPath)+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A++cssFile :: T.Text+cssFile = $(embedStringFile "rts/style.css")++relativise :: FilePath -> FilePath -> FilePath+relativise dest src =+ concat (replicate (length (splitPath src) - 1) "../") ++ makeRelative "/" dest++headHtmlWithCss :: String -> String -> H.Html+headHtmlWithCss cssPath titleText =+ H.head $+ H.meta+ ! A.charset "utf-8"+ <> H.title (fromString titleText)+ <> H.link+ ! A.href (fromString cssPath)+ ! A.rel "stylesheet"+ ! A.type_ "text/css"++headHtml :: FilePath -> String -> H.Html+headHtml current = headHtmlWithCss (relativise "style.css" current)
src/Futhark/Util/Pretty.hs view
@@ -161,10 +161,10 @@ annot [] s = s annot l s = vsep (l ++ [s]) --- | Surround the given document with enclosers and add linebreaks and+-- | Surround the given document with braces and add linebreaks and -- indents.-nestedBlock :: Doc a -> Doc a -> Doc a -> Doc a-nestedBlock pre post body = vsep [pre, indent 2 body, post]+nestedBlock :: Doc a -> Doc a+nestedBlock body = vsep ["{", indent 2 body, "}"] -- | Prettyprint on a single line up to at most some appropriate -- number of characters, with trailing ... if necessary. Used for
src/Language/Futhark/Interpreter.hs view
@@ -38,7 +38,6 @@ import Data.Functor (($>), (<&>)) import Data.List ( find,- foldl', genericLength, genericTake, transpose,@@ -745,13 +744,13 @@ where p_t = evalToStruct $ expandType env $ patternStructType p -evalFunction :: Env -> [VName] -> [Pat ParamType] -> Exp -> ResType -> EvalM Value+evalBinding :: Env -> [VName] -> [Pat ParamType] -> Exp -> ResType -> EvalM Value -- We treat zero-parameter lambdas as simply an expression to -- evaluate immediately. Note that this is *not* the same as a lambda -- that takes an empty tuple '()' as argument! Zero-parameter lambdas -- can never occur in a well-formed Futhark program, but they are -- convenient in the interpreter.-evalFunction env missing_sizes [] body rettype =+evalBinding env missing_sizes [] body rettype = -- Eta-expand the rest to make any sizes visible. etaExpand [] env rettype where@@ -763,20 +762,20 @@ etaExpand vs env' _ = do f <- eval env' body foldM (apply noLoc mempty) f $ reverse vs-evalFunction env missing_sizes (p : ps) body rettype =+evalBinding env missing_sizes (p : ps) body rettype = pure . ValueFun $ \v -> do env' <- linkMissingSizes missing_sizes p v <$> matchPat env p v- evalFunction env' missing_sizes ps body rettype+ evalBinding env' missing_sizes ps body rettype -evalFunctionBinding ::+evalValBinding :: Env -> [TypeParam] -> [Pat ParamType] -> ResRetType -> Exp -> EvalM TermBinding-evalFunctionBinding env tparams ps ret fbody = do- let ftype = funType ps ret+evalValBinding env tparams ps ret fbody = do+ let ftype = evalToStruct $ expandType env $ funType ps ret retext = case ps of [] -> retDims ret _ -> []@@ -786,9 +785,10 @@ then fmap (TermValue (Just $ T.BoundV [] ftype)) . returned env (retType ret) retext- =<< evalFunction env [] ps fbody (retType ret)+ =<< evalBinding env [] ps fbody (retType ret) else pure . TermPoly (Just $ T.BoundV [] ftype) $ \ftype' -> do- let resolved = resolveTypeParams (map typeParamName tparams) ftype ftype'+ let resolved =+ resolveTypeParams (map typeParamName tparams) ftype ftype' tparam_env <- evalResolved resolved let env' = tparam_env <> env -- In some cases (abstract lifted types) there may be@@ -799,7 +799,7 @@ filter (`M.notMember` envTerm env') $ map typeParamName (filter isSizeParam tparams) returned env (retType ret) retext- =<< evalFunction env' missing_sizes ps fbody (retType ret)+ =<< evalBinding env' missing_sizes ps fbody (retType ret) evalArg :: Env -> Exp -> Maybe VName -> EvalM Value evalArg env e ext = do@@ -875,7 +875,7 @@ env'' = env' <> i64Env (resolveExistentials (map sizeName sizes) p_t v_s) eval env'' body evalAppExp env (LetFun (f, _) (tparams, ps, _, Info ret, fbody) body _) = do- binding <- evalFunctionBinding env tparams ps ret fbody+ binding <- evalValBinding env tparams ps ret fbody eval (env {envTerm = M.insert f binding $ envTerm env}) body evalAppExp env (BinOp (op, _) op_t (x, Info xext) (y, Info yext) loc) | baseName (qualLeaf op) == "&&" = do@@ -1072,7 +1072,7 @@ -- can never occur in a well-formed Futhark program, but they are -- convenient in the interpreter. eval env (Lambda ps body _ (Info (RetType _ rt)) _) =- evalFunction env [] ps body rt+ evalBinding env [] ps body rt eval env (OpSection qv (Info t) _) = evalTermVar env qv $ toStruct t eval env (OpSectionLeft qv _ e (Info (_, _, argext), _) (Info (RetType _ t), _) loc) = do@@ -1219,7 +1219,7 @@ evalDec :: Env -> Dec -> EvalM Env evalDec env (ValDec (ValBind _ v _ (Info ret) tparams ps fbody _ _ _)) = localExts $ do- binding <- evalFunctionBinding env tparams ps ret fbody+ binding <- evalValBinding env tparams ps ret fbody sizes <- extEnv pure $ mempty {envTerm = M.singleton v binding} <> sizes evalDec env (OpenDec me _) = do
src/Language/Futhark/Pretty.hs view
@@ -487,7 +487,7 @@ prettyModExp _ (ModImport v _ _) = "import" <+> pretty (show v) prettyModExp _ (ModDecs ds _) =- nestedBlock "{" "}" $ stack $ punctuate line $ map pretty ds+ nestedBlock $ stack $ punctuate line $ map pretty ds prettyModExp p (ModApply f a _ _ _) = parensIf (p >= 10) $ prettyModExp 0 f <+> prettyModExp 10 a prettyModExp p (ModAscript me se _ _) =@@ -565,7 +565,7 @@ instance (IsName vn, Annot f) => Pretty (ModTypeExpBase f vn) where pretty (ModTypeVar v _ _) = pretty v pretty (ModTypeParens e _) = parens $ pretty e- pretty (ModTypeSpecs ss _) = nestedBlock "{" "}" (stack $ punctuate line $ map pretty ss)+ pretty (ModTypeSpecs ss _) = nestedBlock (stack $ punctuate line $ map pretty ss) pretty (ModTypeWith s (TypeRef v ps td _) _) = pretty s <+> "with" <+> pretty v <+> hsep (map pretty ps) <> " =" <+> pretty td pretty (ModTypeArrow (Just v) e1 e2 _) =
src/Language/Futhark/Primitive.hs view
@@ -1581,7 +1581,7 @@ _ -> Nothing ) )- | t <- allPrimTypes+ | t <- allPrimTypes ] where i8 s f = (s, ([IntType Int8], IntType Int32, i8PrimFun f))
src/Language/Futhark/Prop.hs view
@@ -23,6 +23,7 @@ paramName, anySize, isAnySize,+ setApplyLoc, -- * Queries on expressions typeOf,@@ -377,6 +378,17 @@ isAnySize (StringLit xs _) = Just $ read $ map (chr . fromIntegral) xs isAnySize _ = Nothing +-- | Override the location of an 'Apply' expression.+--+-- This is useful because 'mkApply' sets the location to be the span of the+-- function and all arguments, but during many frontend transformations we+-- insert additional arguments for which we do not care about the original+-- source location. Our goal is to maintain a correspondence between the+-- original source code and the generated code.+setApplyLoc :: SrcLoc -> Exp -> Exp+setApplyLoc loc (AppExp (Apply f args _) info) = AppExp (Apply f args loc) info+setApplyLoc _ e = e+ -- | Match the dimensions of otherwise assumed-equal types. The -- combining function is also passed the names bound within the type -- (from named parameters or return types).@@ -634,11 +646,11 @@ namesToPrimTypes = M.fromList [ (nameFromString $ prettyString t, t)- | t <-- Bool- : map Signed [minBound .. maxBound]- ++ map Unsigned [minBound .. maxBound]- ++ map FloatType [minBound .. maxBound]+ | t <-+ Bool+ : map Signed [minBound .. maxBound]+ ++ map Unsigned [minBound .. maxBound]+ ++ map FloatType [minBound .. maxBound] ] -- | The nature of something predefined. For functions, these can
src/Language/Futhark/Semantic.hs view
@@ -169,7 +169,7 @@ instance Pretty Env where pretty (Env vtable ttable sigtable modtable _) =- nestedBlock "{" "}" $+ nestedBlock $ stack $ punctuate line $ concat
src/Language/Futhark/TypeChecker/Terms/Loop.hs view
@@ -88,12 +88,12 @@ wellTypedLoopArg :: ArgSource -> [VName] -> Pat ParamType -> Exp -> TermTypeM () wellTypedLoopArg src sparams pat arg = do- (merge_t, _) <-+ (loop_t, _) <- freshDimsInType (mkUsage arg desc) Nonrigid "loop" sparams $ toStruct (patternType pat) arg_t <- toStruct <$> expTypeFully arg- onFailure (checking merge_t arg_t) $- unify (mkUsage arg desc) merge_t arg_t+ onFailure (checking loop_t arg_t) $+ unify (mkUsage arg desc) loop_t arg_t where (checking, desc) = case src of@@ -126,6 +126,30 @@ problem : _ -> problem [] -> pure () +-- Check if any sparams have reduced levels, which indicates they escaped the+-- loop scope and got constrained by something at a lower (outer) level. This+-- means they cannot actually be variant across the loop.+checkForEscaped :: SrcLoc -> M.Map VName Level -> [VName] -> TermTypeM ()+checkForEscaped loc initial_levels sparams = do+ cs <- getConstraints+ let checkSparamLevel sparam = do+ let current_level = fst <$> M.lookup sparam cs+ original_level = M.lookup sparam initial_levels+ case (original_level, current_level) of+ (Just orig, Just curr)+ | curr < orig ->+ Just+ . typeError loc mempty+ . withIndexLink "loop-variant-escape"+ $ "Loop-variant size"+ <+> "has escaped into type that occurs outside of loop."+ </> "This is likely because the loop body uses a variable whose type"+ </> "depends on the loop parameter."+ _ -> Nothing+ case mapMaybe checkSparamLevel sparams of+ problem : _ -> problem+ [] -> pure ()+ -- | Type-check a @loop@ expression, passing in a function for -- type-checking subexpressions. checkLoop ::@@ -133,7 +157,7 @@ UncheckedLoop -> SrcLoc -> TermTypeM (CheckedLoop, AppRes)-checkLoop checkExp (mergepat, loopinit, form, loopbody) loc = do+checkLoop checkExp (looppat, loopinit, form, loopbody) loc = do loopinit' <- checkExp $ case loopinit of LoopInitExplicit e -> e LoopInitImplicit _ ->@@ -150,13 +174,13 @@ -- similar to checking a function, followed by checking a call to -- it. The overall procedure is as follows: --- -- (1) All empty dimensions in the merge pattern are instantiated+ -- (1) All empty dimensions in the loop pattern are instantiated -- with nonrigid size variables. All explicitly specified -- dimensions are preserved. -- -- (2) The body of the loop is type-checked. The result type is- -- combined with the merge pattern type to determine which sizes are- -- variant, and these are turned into size parameters for the merge+ -- combined with the loop pattern type to determine which sizes are+ -- variant, and these are turned into size parameters for the loop -- pattern. -- -- (3) We now conceptually have a function parameter type and@@ -164,25 +188,33 @@ -- as argument. -- -- (4) Similarly to (3), we check that the "function" can be- -- called with the initial merge values as argument. The result+ -- called with the initial loop values as argument. The result -- of this is the type of the loop as a whole. - (merge_t, new_dims_map) <-+ (loop_t, new_dims_map) <- -- dim handling (1)- allDimsFreshInType (mkUsage loc "loop parameter type inference") Nonrigid "loop_d"+ allDimsFreshInType+ (mkUsage loc "loop parameter type inference")+ Nonrigid+ "loop_d" =<< expTypeFully loopinit' let new_dims_to_initial_dim = M.toList new_dims_map new_dims = map fst new_dims_to_initial_dim + -- Save the initial levels of new_dims for later checking+ initial_levels <- do+ cs <- getConstraints+ pure $ M.fromList [(v, lvl) | v <- new_dims, Just (lvl, _) <- [M.lookup v cs]]+ -- dim handling (2)- let checkLoopReturnSize mergepat' loopbody' = do+ let checkLoopReturnSize looppat' loopbody' = do loopbody_t <- expTypeFully loopbody'- mergepat_t <- normTypeFully (patternType mergepat')+ looppat_t <- normTypeFully (patternType looppat') let ok_names = known_before <> S.fromList new_dims- checkForImpossible (locOf mergepat) ok_names mergepat_t+ checkForImpossible (locOf looppat) ok_names looppat_t - pat_t <- someDimsFreshInType loc "loop" new_dims mergepat_t+ pat_t <- someDimsFreshInType loc "loop" new_dims looppat_t -- We are ignoring the dimensions here, because any mismatches -- should be turned into fresh size variables.@@ -211,11 +243,13 @@ pure () pure e loopbody_t' <- normTypeFully loopbody_t- merge_t' <- normTypeFully merge_t+ loop_t' <- normTypeFully loop_t let (init_substs, sparams) =- execState (matchDims onDims merge_t' loopbody_t') mempty+ execState (matchDims onDims loop_t' loopbody_t') mempty + checkForEscaped loc initial_levels sparams+ -- Make sure that any of new_dims that are invariant will be -- replaced with the invariant size in the loop body. Failure -- to do this can cause type annotations to still refer to@@ -226,7 +260,7 @@ pure () mapM_ dimToInit $ M.toList init_substs - mergepat'' <- applySubst (`M.lookup` init_substs) <$> updateTypes mergepat'+ looppat'' <- applySubst (`M.lookup` init_substs) <$> updateTypes looppat' -- Eliminate those new_dims that turned into sparams so it won't -- look like we have ambiguous sizes lying around.@@ -238,11 +272,11 @@ -- of loop parameters in the type of loopbody' rigid, -- because we are no longer in a position to change them, -- really.- wellTypedLoopArg BodyResult sparams mergepat'' loopbody'+ wellTypedLoopArg BodyResult sparams looppat'' loopbody' - pure (nubOrd sparams, mergepat'')+ pure (nubOrd sparams, looppat'') - (sparams, mergepat', form', loopbody') <-+ (sparams, looppat', form', loopbody') <- case form of For i uboundexp -> do uboundexp' <-@@ -250,12 +284,12 @@ =<< checkExp uboundexp bound_t <- expTypeFully uboundexp' bindingIdent i bound_t $ \i' ->- bindingPat [] mergepat merge_t $ \mergepat' -> incLevel $ do+ bindingPat [] looppat loop_t $ \looppat' -> incLevel $ do loopbody' <- checkExp loopbody- (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'+ (sparams, looppat'') <- checkLoopReturnSize looppat' loopbody' pure ( sparams,- mergepat'',+ looppat'', For i' uboundexp', loopbody' )@@ -267,12 +301,12 @@ _ | Just t' <- peelArray 1 t -> bindingPat [] xpat t' $ \xpat' ->- bindingPat [] mergepat merge_t $ \mergepat' -> incLevel $ do+ bindingPat [] looppat loop_t $ \looppat' -> incLevel $ do loopbody' <- checkExp loopbody- (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'+ (sparams, looppat'') <- checkLoopReturnSize looppat' loopbody' pure ( sparams,- mergepat'',+ looppat'', ForIn (fmap toStruct xpat') e', loopbody' )@@ -281,22 +315,22 @@ "Iteratee of a for-in loop must be an array, but expression has type" <+> pretty t While cond ->- bindingPat [] mergepat merge_t $ \mergepat' ->+ bindingPat [] looppat loop_t $ \looppat' -> incLevel $ do cond' <- checkExp cond >>= unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool) loopbody' <- checkExp loopbody- (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'+ (sparams, looppat'') <- checkLoopReturnSize looppat' loopbody' pure ( sparams,- mergepat'',+ looppat'', While cond', loopbody' ) -- dim handling (4)- wellTypedLoopArg Initial sparams mergepat' loopinit'+ wellTypedLoopArg Initial sparams looppat' loopinit' (loopt, retext) <- freshDimsInType@@ -304,8 +338,8 @@ (Rigid RigidLoop) "loop" sparams- (patternType mergepat')+ (patternType looppat') pure- ( (sparams, mergepat', LoopInitExplicit loopinit', form', loopbody'),+ ( (sparams, looppat', LoopInitExplicit loopinit', form', loopbody'), AppRes (toStruct loopt) retext )