futhark 0.25.37 → 0.26.1
raw patch · 47 files changed
+1042/−580 lines, 47 filesdep ~futhark-manifestdep ~futhark-server
Dependency ranges changed: futhark-manifest, futhark-server
Files
- CHANGELOG.md +28/−0
- docs/c-api.rst +3/−3
- docs/js-api.rst +138/−51
- docs/server-protocol.rst +12/−12
- docs/usage.rst +5/−8
- futhark.cabal +4/−3
- rts/c/scheduler.h +1/−0
- rts/c/server.h +24/−40
- rts/c/timing.h +1/−0
- rts/javascript/server.js +23/−53
- rts/python/memory.py +32/−1
- rts/python/server.py +32/−16
- src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs +1/−3
- src/Futhark/AD/Rev.hs +13/−2
- src/Futhark/Bench.hs +10/−10
- src/Futhark/CLI/Dev.hs +2/−0
- src/Futhark/CLI/Literate.hs +14/−11
- src/Futhark/CLI/Test.hs +9/−9
- src/Futhark/CodeGen/Backends/GenericC/CLI.hs +3/−3
- src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs +11/−11
- src/Futhark/CodeGen/Backends/GenericC/Server.hs +6/−24
- src/Futhark/CodeGen/Backends/GenericPython.hs +72/−47
- src/Futhark/CodeGen/Backends/GenericWASM.hs +6/−8
- src/Futhark/CodeGen/Backends/MulticoreWASM.hs +1/−1
- src/Futhark/CodeGen/Backends/SequentialWASM.hs +1/−1
- src/Futhark/CodeGen/Backends/SimpleRep.hs +7/−1
- src/Futhark/CodeGen/ImpCode.hs +4/−4
- src/Futhark/CodeGen/ImpGen.hs +15/−16
- src/Futhark/CodeGen/ImpGen/GPU/Block.hs +9/−7
- src/Futhark/Construct.hs +8/−0
- src/Futhark/IR/Parse.hs +1/−2
- src/Futhark/IR/Pretty.hs +1/−1
- src/Futhark/IR/Prop.hs +14/−0
- src/Futhark/IR/SOACS/SOAC.hs +0/−14
- src/Futhark/IR/Syntax.hs +1/−1
- src/Futhark/Internalise/Entry.hs +2/−16
- src/Futhark/Internalise/FullNormalise.hs +4/−18
- src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs +16/−8
- src/Futhark/Optimise/Fusion/RulesWithAccs.hs +94/−122
- src/Futhark/Pass/AddGlobalParams.hs +292/−0
- src/Futhark/Pass/ExplicitAllocations/GPU.hs +2/−1
- src/Futhark/Pass/LiftAllocations.hs +2/−2
- src/Futhark/Passes.hs +2/−0
- src/Futhark/Script.hs +36/−24
- src/Futhark/Test.hs +71/−20
- src/Language/Futhark/Interpreter/AD.hs +7/−4
- src/Language/Futhark/Pretty.hs +2/−2
CHANGELOG.md view
@@ -5,6 +5,34 @@ 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.26.1]++### Changed++* In the C and Python APIs, entry points returning tuples no longer implicitly+ unpack them.++### Fixed++* The C-based backends no longer emit constants `-9223372036854775808`, as these+ cause C compilers to issue warnings.++* A case where user-defined assertions could be removed when used in conjunction+ with `#[scratch]`. (#2417)++* Various miscompilations and compiler crashes in fusion of `scatter`+ operations.++* Multi-dimensional histograms (`reduce_by_index_2d`) were not handled correctly+ by the intrablock code generator in the GPU backends.++* The interpreter implementation of AD handled some integer/floating-point+ conversions incorrectly. (#2425)++* Compiler crash when inserting memory information. (#2432)++* Out-of-bounds indexing in generated code for reverse-mode AD of `scatter`.+ ## [0.25.37] ### Added
docs/c-api.rst view
@@ -566,8 +566,8 @@ Entry points ------------ -Entry points are mapped 1:1 to C functions. Return values are handled-with *out*-parameters.+Entry points are mapped 1:1 to C functions. The return value is stored in an+*out*-parameter. For example, this Futhark entry point:: @@ -582,7 +582,7 @@ of ``out0``. Errors are indicated by a nonzero return value. On error, the-*out*-parameters are not touched.+*out*-parameter is not touched. The precise semantics of the return value depends on the backend. For the sequential C backend, errors will always be available when the
docs/js-api.rst view
@@ -3,27 +3,43 @@ JavaScript API Reference ======================== -The :ref:`futhark-wasm(1)` and :ref:`futhark-wasm-multicore(1)`-compilers produce JavaScript wrapper code to allow JavaScript programs-to invoke the generated WebAssembly code. This chapter describes the-API exposed by the wrapper.+The :ref:`futhark-wasm(1)`, :ref:`futhark-wasm-multicore(1)`, and+:ref:`futhark-webgpu(1)` compilers can generate JavaScript wrapper code+when used with ``--library``. This chapter describes the API exposed by+those wrappers. +The exact generated files and the top-level JavaScript interface differ+somewhat between the WASM-style backends and the WebGPU backend, so the+relevant differences are described below.+ First a warning: **the JavaScript API is experimental**. It may change incompatibly even in minor versions of the compiler. -A Futhark program ``futlib.fut`` compiled with a WASM backend as a library-with the ``--library`` command line option produces four files:+A Futhark program ``futlib.fut`` compiled with ``--library`` produces+generated C code as well as JavaScript-facing runtime files. Some of+these files are backend-specific. -* ``futlib.c``, ``futlib.h``: Implementation and header C files- generated by the compiler, similar to ``futhark c``. You can delete- these - they are not needed at run-time.-* ``futlib.class.js``: An intermediate build artifact. Feel free to- delete it.-* ``futlib.wasm``: A compiled WebAssembly module, which must be- present at runtime.-* ``futlib.mjs``: An ES6 module that can can be imported by other- JavaScript code, and implements the API given in the following.+For the WASM backend, a build typically produces: +* ``futlib.c``, ``futlib.h``: implementation and header C files+ generated by the compiler, similar to ``futhark c``.+* ``futlib.class.js``: an intermediate JavaScript build artifact.+* ``futlib.wasm``: the compiled WebAssembly module, which must be+ present at runtime.+* ``futlib.mjs``: an ES module that exports the JavaScript wrapper API.++For the WebGPU backend, a build typically produces:++* ``futlib.c``, ``futlib.h``: implementation and header C files+ generated by the compiler.+* ``futlib.js``: the generated backend runtime module.+* ``futlib.wrapper.js``: the JavaScript wrapper that exposes the+ Futhark-facing API.+* ``futlib.json``: manifest data used by the generated wrapper.+* ``futlib.wasm``: a generated WebAssembly artifact used by the runtime.++The exact file set is backend-dependent and may change over time.+ The module exports a function, ``newFutharkContext``, which is a factory function that returns a Promise producing a ``FutharkContext`` instance (see below). A simple usage example:@@ -42,49 +58,94 @@ You are responsible for eventually freeing all objects produced by the API, using the appropriate methods. -FutharkContext---------------+Top-level wrapper objects+------------------------- -FutharkContext is a class that contains information about the context-and configuration from the C API. It has methods for invoking the-Futhark entry points and creating FutharkArrays on the WebAssembly-heap.+The top-level JavaScript interface differs between backends. +WASM wrapper+~~~~~~~~~~~~++The WASM backend exports a ``newFutharkContext()`` factory function that+asynchronously constructs a ``FutharkContext``.+ .. js:function:: newFutharkContext() Asynchronously create a new ``FutharkContext`` object. .. js:class:: FutharkContext() - A bookkeeping class representing an instance of a Futhark program.- Do *not* directly invoke its constructor - always use the- ``newFutharkContext()`` factory function.+ A bookkeeping class representing an instance of a compiled Futhark+ program. .. js:function:: FutharkContext.free() - Frees all memory created by the ``FutharkContext`` object. Should- be called when the ``FutharkContext`` is done being used. It is an- error use a ``FutharkArray`` or ``FutharkOpaque`` after the+ Frees all memory created by the ``FutharkContext`` object. It is an+ error to use a ``FutharkArray`` or ``FutharkOpaque`` after the ``FutharkContext`` on which they were defined has been freed. +WebGPU wrapper+~~~~~~~~~~~~~~++The WebGPU backend generates a ``FutharkModule`` wrapper class. This+wrapper is initialised with the generated backend runtime module.++.. js:class:: FutharkModule()++ A bookkeeping class representing an instance of a compiled Futhark+ program.++.. js:function:: FutharkModule.init(module)++ Asynchronously initialise the ``FutharkModule`` object with the+ generated backend runtime module.++.. js:function:: FutharkModule.free()++ Frees the Futhark context and configuration associated with the+ module.++.. js:function:: FutharkModule.context_sync()++ Wait for pending backend work associated with the context to finish.++.. js:function:: FutharkModule.clear_caches()++ Clear backend caches associated with the context.++.. js:function:: FutharkModule.report()++ Return a profiling report string.++.. js:function:: FutharkModule.pause_profiling()++ Pause profiling.++.. js:function:: FutharkModule.unpause_profiling()++ Resume profiling.+ Values ------ -Numeric types ``u8``, ``u16``, ``u32``, ``i8``, ``i16``, ``i32``, ``f32``,-and ``f64`` are mapped to JavaScript's standard number type. 64-bit integers-``u64``, and ``i64`` are mapped to ``BigInt``. ``bool`` is mapped to-JavaScript's ``boolean`` type. Arrays are represented by the ``FutharkArray``.-complex types (records, nested tuples, etc) are represented by the-``FutharkOpaque`` class.+Numeric types ``u8``, ``u16``, ``u32``, ``i8``, ``i16``, ``i32``, ``f16``,+``f32``, and ``f64`` are mapped to JavaScript's standard number type.+64-bit integers ``u64`` and ``i64`` are mapped to ``BigInt``. ``bool``+is mapped to JavaScript's ``boolean`` type. Arrays are represented by+``FutharkArray`` objects. Complex types (records, nested tuples, etc.)+are represented by ``FutharkOpaque`` objects. FutharkArray ------------ -``FutharkArray`` has the following API+The exact ``FutharkArray`` API differs slightly between backends. +WASM wrapper+~~~~~~~~~~~~+ .. js:function:: FutharkArray.toArray() - Returns a nested JavaScript array+ Returns a nested JavaScript array. .. js:function:: FutharkArray.toTypedArray() @@ -92,29 +153,55 @@ .. js:function:: FutharkArray.shape() - Returns the shape of the FutharkArray as an array of BigInts.+ Returns the shape of the ``FutharkArray`` as an array of ``BigInt`` values. .. js:function:: FutharkArray.free() - Frees the memory used by the FutharkArray class+ Frees the memory used by the ``FutharkArray``. -``FutharkContext`` also contains two functions for creating-``FutharkArrays`` from JavaScript arrays, and typed arrays for each-array type that appears in an entry point. All array types share-similar API methods on the ``FutharkContext``, which is illustrated-here for the case of the type ``[]i32``.+WebGPU wrapper+~~~~~~~~~~~~~~ +The WebGPU backend generates per-type subclasses of ``FutharkArray``.++.. js:function:: FutharkArray.get_shape()++ Returns the shape of the array as a ``BigInt64Array``.++.. js:function:: FutharkArray.values()++ Asynchronously returns a flat typed array containing the array data.++.. js:function:: FutharkArray.free()++ Frees the memory used by the ``FutharkArray``.++Array construction also differs a bit between backends.++For the WASM wrapper, ``FutharkContext`` contains constructor methods for+each array type that appears in an entry point. For example, for the+type ``[]i32``:+ .. js:function:: FutharkContext.new_i32_1d_from_jsarray(jsarray) - Creates and returns a one-dimensional ``i32`` ``FutharkArray`` representing- the JavaScript array jsarray+ Creates and returns a one-dimensional ``i32`` ``FutharkArray``+ representing the JavaScript array ``jsarray``. -.. js:function:: FutharkContext.new_i32_1d(array, dim1)+.. js:function:: FutharkContext.new_i32_1d(array, dim0) - Creates and returns a one-dimensional ``i32`` ``FutharkArray`` representing- the typed array of array, with the size given by dim1.+ Creates and returns a one-dimensional ``i32`` ``FutharkArray``+ representing the typed array ``array``, with shape ``dim0``. +For the WebGPU wrapper, each generated array type is represented by its+own generated class, available through the ``FutharkModule`` object. +.. js:function:: fut.i32_1d.from_data(data, dim0)++ Creates and returns a one-dimensional ``i32`` ``FutharkArray`` from+ a JavaScript ``Array`` or the corresponding typed array, with the+ given shape.++ FutharkOpaque ------------- @@ -132,11 +219,11 @@ Entry Points ------------ -Each entry point in the compiled futhark program has an entry point method on-the FutharkContext+Each entry point in the compiled futhark program for the WASM wrapper has an entry point method on+the ``FutharkContext``, and for the WebGPU wrapper, each entry point is exposed through the ``entry`` field of the ``FutharkModule`` object: .. js:function:: FutharkContext.<entry_point_name>(in1, ..., inN) The entry point function taking the N arguments of the Futhark entry point- function, and returns the result. If the result is a tuple the return value- is an array.+ function, and returns the result. For the WASM wrapper, if the result is a tuple the return value+ is an array. For the WebGPU wrapper, if there are multiple outputs, the return value is an array of outputs in order.
docs/server-protocol.rst view
@@ -45,13 +45,13 @@ Types ----- -All variables have types, and all entry points accept inputs and produce outputs-of defined types. The notion of transparent and opaque types are the same as in-the C API: primitives and array of primitives are directly supported, and-everything else is treated as opaque. See also :ref:`valuemapping`. When+All variables have types, and all entry points accept inputs and produce an+output of defined types. The notion of transparent and opaque types are the same+as in the C API: primitives and array of primitives are directly supported, and+everything else is treated as opaque. See also :ref:`valuemapping`. When printed, types follow basic Futhark type syntax *without* sizes (e.g. ``[][]i32``). Uniqueness is not part of the types, but is indicated with an-asterisk in the ``inputs`` and ``outputs`` commands (see below).+asterisk in the ``inputs`` and ``output`` commands (see below). Consumption and aliasing ------------------------@@ -79,11 +79,11 @@ Print the names of available entry points. -``call`` *entry* *o1* ... *oN* *i1* ... *iM*-............................................+``call`` *entry* *o* *i1* ... *iM*+.................................. Call the given entry point with input from the variables *i1* to *iM*. The-results are stored in *o1* to *oN*, which must not already exist.+results are stored in *o*, which must not already exist. ``restore`` *file* *v1* *t1* ... *vN* *tN* ..........................................@@ -112,11 +112,11 @@ Print the types of inputs accepted by the given entry point, one per line. If the given input is consumed, the type is prefixed by `*`. -``outputs`` *entry*-...................+``output`` *entry*+.................. -Print the types of outputs produced by the given entry point, one per line. If-the given output is guaranteed to be unique (does not alias any inputs), the+Print the type of the output produced by the given entry point, on a single+line. If the output is guaranteed to be unique (does not alias any inputs), the type is prefixed by `*`. ``clear``
docs/usage.rst view
@@ -324,14 +324,11 @@ General Concerns ^^^^^^^^^^^^^^^^ -Futhark entry points are mapped to some form of function or method in-the target language. Generally, an entry point taking *n* parameters-will result in a function taking *n* parameters. If the entry point-returns an *m*-element tuple, then the function will return *m* values-(although the tuple can be replaced with a single opaque value, see-below). Extra parameters may be added to pass in context data, or-*out*-parameters for writing the result, for target languages that do-not support multiple return values from functions.+Futhark entry points are mapped to some form of function or method in the target+language. Generally, an entry point taking *n* parameters will result in a+function taking *n* parameters. Extra parameters may be added to pass in context+data, or results may be passed in an *out*-parameter for writing the result, for+target languages that do not support multiple return values from functions. The entry point should have a name that is also a valid identifier in the target language (usually C).
futhark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: futhark-version: 0.25.37+version: 0.26.1 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to@@ -361,6 +361,7 @@ Futhark.Optimise.Unstream Futhark.Pass Futhark.Pass.AD+ Futhark.Pass.AddGlobalParams Futhark.Pass.ExpandAllocations Futhark.Pass.ExplicitAllocations Futhark.Pass.ExplicitAllocations.GPU@@ -478,8 +479,8 @@ , filepath >=1.4.1.1 , free >=5.1.10 , futhark-data >= 1.1.3.0- , futhark-server >= 1.3.3.0- , futhark-manifest == 1.7.0.0+ , futhark-server >= 1.4.0.0+ , futhark-manifest == 1.8.0.0 , githash >=0.1.6.1 , half >= 0.3 , haskeline
rts/c/scheduler.h view
@@ -90,6 +90,7 @@ #include <signal.h> #if defined(_WIN32)+#define NOGDI #include <windows.h> #elif defined(__APPLE__) #include <sys/sysctl.h>
rts/c/server.h view
@@ -190,15 +190,15 @@ struct value value; }; -typedef int (*entry_point_fn)(struct futhark_context*, void**, void**);+typedef int (*entry_point_fn)(struct futhark_context*, void*, void**); struct entry_point { const char *name; entry_point_fn f; const char** tuning_params; const char** attrs;- const struct type **out_types;- bool *out_unique;+ const struct type *out_type;+ bool out_unique; const struct type **in_types; bool *in_unique; };@@ -211,14 +211,6 @@ return count; } -int entry_num_outs(struct entry_point *e) {- int count = 0;- while (e->out_types[count]) {- count++;- }- return count;-}- struct futhark_prog { // Last entry point identified by NULL name. struct entry_point *entry_points;@@ -354,14 +346,13 @@ return; } - int num_outs = entry_num_outs(e); int num_ins = entry_num_ins(e); // +1 to avoid zero-size arrays, which is UB.- void* outs[num_outs+1];+ void* out; void* ins[num_ins+1]; for (int i = 0; i < num_ins; i++) {- const char *in_name = get_arg(args, 1+num_outs+i);+ const char *in_name = get_arg(args, 2+i); struct variable *v = get_variable(s, in_name); if (v == NULL) { failure();@@ -377,19 +368,17 @@ ins[i] = value_ptr(&v->value); } - for (int i = 0; i < num_outs; i++) {- const char *out_name = get_arg(args, 1+i);- struct variable *v = create_variable(s, out_name, e->out_types[i]);- if (v == NULL) {- failure();- printf("Variable already exists: %s\n", out_name);- return;- }- outs[i] = value_ptr(&v->value);+ const char *out_name = get_arg(args, 1);+ struct variable *v = create_variable(s, out_name, e->out_type);+ if (v == NULL) {+ failure();+ printf("Variable already exists: %s\n", out_name);+ return; }+ out = value_ptr(&v->value); int64_t t_start = get_wall_time();- int err = e->f(s->ctx, outs, ins);+ int err = e->f(s->ctx, out, ins); err |= futhark_context_sync(s->ctx); int64_t t_end = get_wall_time(); long long int elapsed_usec = t_end - t_start;@@ -397,14 +386,12 @@ error_check(s, err); if (err != 0) {- // Need to uncreate the output variables, which would otherwise be left+ // Need to uncreate the output variable, which would otherwise be left // in an uninitialised state.- for (int i = 0; i < num_outs; i++) {- const char *out_name = get_arg(args, 1+i);- struct variable *v = get_variable(s, out_name);- if (v) {- drop_variable(v);- }+ const char *out_name = get_arg(args, 1);+ struct variable *v = get_variable(s, out_name);+ if (v) {+ drop_variable(v); } } }@@ -546,7 +533,7 @@ } } -void cmd_outputs(struct server_state *s, const char *args[]) {+void cmd_output(struct server_state *s, const char *args[]) { const char *name = get_arg(args, 0); struct entry_point *e = get_entry_point(s, name); @@ -556,13 +543,10 @@ return; } - int num_outs = entry_num_outs(e);- for (int i = 0; i < num_outs; i++) {- if (e->out_unique[i]) {- putchar('*');- }- puts(e->out_types[i]->name);+ if (e->out_unique) {+ putchar('*'); }+ puts(e->out_type->name); } void cmd_clear(struct server_state *s, const char *args[]) {@@ -1319,8 +1303,8 @@ cmd_rename(s, tokens+1); } else if (strcmp(command, "inputs") == 0) { cmd_inputs(s, tokens+1);- } else if (strcmp(command, "outputs") == 0) {- cmd_outputs(s, tokens+1);+ } else if (strcmp(command, "output") == 0) {+ cmd_output(s, tokens+1); } else if (strcmp(command, "clear") == 0) { cmd_clear(s, tokens+1); } else if (strcmp(command, "pause_profiling") == 0) {
rts/c/timing.h view
@@ -5,6 +5,7 @@ #ifdef _WIN32 +#define NOGDI #include <windows.h> static int64_t get_wall_time(void) {
rts/javascript/server.js view
@@ -6,21 +6,6 @@ this.ctx = ctx; this._vars = {}; this._types = {};- this._commands = [ 'inputs',- 'outputs',- 'call',- 'restore',- 'store',- 'free',- 'clear',- 'pause_profiling',- 'unpause_profiling',- 'report',- 'rename',- 'types',- 'fields',- 'project'- ]; } _get_arg(args, i) {@@ -68,12 +53,9 @@ } } - _cmd_outputs(args) {+ _cmd_output(args) { var entry = this._get_arg(args, 0);- var outputs = this._get_entry_point(entry)[2];- for (var i = 0; i < outputs.length; i++) {- console.log(outputs[i]);- }+ console.log(this._get_entry_point(entry)[2]); } _cmd_dummy(args) {@@ -160,19 +142,16 @@ _cmd_call(args) { var entry = this._get_entry_point(this._get_arg(args, 0)); var num_ins = entry[1].length;- var num_outs = entry[2].length;+ var num_outs = 1; var expected_len = 1 + num_outs + num_ins if (args.length != expected_len) { throw "Invalid argument count, expected " + expected_len } - var out_vnames = args.slice(1, num_outs+1)- for (var i = 0; i < out_vnames.length; i++) {- var out_vname = out_vnames[i];- if (out_vname in this._vars) {- throw "Variable already exists: " + out_vname;- }+ var out_vname = args[1];+ if (out_vname in this._vars) {+ throw "Variable already exists: " + out_vname; } var in_vnames = args.slice(1+num_outs); var ins = [];@@ -183,13 +162,7 @@ var bef = performance.now()*1000; var vals = this.ctx[entry[0]].apply(this.ctx, ins); var aft = performance.now()*1000;- if (num_outs == 1) {- this._set_var(out_vnames[0], vals, entry[2][0]);- } else {- for (var i = 0; i < out_vnames.length; i++) {- this._set_var(out_vnames[i], vals[i], entry[2][i]);- }- }+ this._set_var(out_vname, vals, entry[2]); console.log("runtime: " + Math.round(aft-bef)); } @@ -268,25 +241,22 @@ } else { var cmd = words[0]; var args = words.splice(1);- if (this._commands.includes(cmd)) {- switch (cmd) {- case 'inputs': this._cmd_inputs(args); break;- case 'outputs': this._cmd_outputs(args); break- case 'call': this._cmd_call(args); break- case 'restore': this._cmd_restore(args); break- case 'store': this._cmd_store(args); break- case 'free': this._cmd_free(args); break- case 'clear': this._cmd_dummy(args); break- case 'pause_profiling': this._cmd_dummy(args); break- case 'unpause_profiling': this._cmd_dummy(args); break- case 'report': this._cmd_dummy(args); break- case 'rename': this._cmd_rename(args); break- case 'types': this._cmd_types(args); break- case 'fields': this._cmd_fields(args); break- case 'project': this._cmd_project(args); break- }- } else {- throw "Unknown command: " + cmd;+ switch (cmd) {+ case 'inputs': this._cmd_inputs(args); break;+ case 'output': this._cmd_output(args); break+ case 'call': this._cmd_call(args); break+ case 'restore': this._cmd_restore(args); break+ case 'store': this._cmd_store(args); break+ case 'free': this._cmd_free(args); break+ case 'clear': this._cmd_dummy(args); break+ case 'pause_profiling': this._cmd_dummy(args); break+ case 'unpause_profiling': this._cmd_dummy(args); break+ case 'report': this._cmd_dummy(args); break+ case 'rename': this._cmd_rename(args); break+ case 'types': this._cmd_types(args); break+ case 'fields': this._cmd_fields(args); break+ case 'project': this._cmd_project(args); break+ default: throw "Unknown command: " + cmd; } } }
rts/python/memory.py view
@@ -29,10 +29,41 @@ # An opaque Futhark value.+#+# Behaves like a tuple, even for opaques that are not really tuple-like.+# Beware... class opaque(object):- def __init__(self, desc, *payload):+ def __init__(self, desc, opaques, *payload): self.data = payload+ self.opaques = opaques self.desc = desc++ def __len__(self):+ return len(self.opaques[self.desc][1])++ # Return number of Python values used to represent Futhark value of given+ # type.+ def __num_elems(self, t):+ if t in self.opaques:+ return sum(map(self.__num_elems, self.opaques[t][0]))+ else:+ return 1++ def __getitem__(self, i):+ layout = self.opaques[self.desc][1]+ if layout is not None:+ if i < 0 or i >= len(layout):+ raise IndexError+ ks = list(map(self.__num_elems, layout))+ t = layout[i]+ if t in self.opaques:+ return opaque(+ layout[i], self.opaques, *self.data[sum(ks[0:i]) : ks[i]]+ )+ else:+ return self.data[sum(ks[0:i])]+ else:+ raise TypeError def __repr__(self): return "<opaque Futhark value of type {}>".format(self.desc)
rts/python/server.py view
@@ -43,10 +43,9 @@ for t in self._get_entry_point(entry)[1]: print(t) - def _cmd_outputs(self, args):+ def _cmd_output(self, args): entry = self._get_arg(args, 0)- for t in self._get_entry_point(entry)[2]:- print(t)+ print(self._get_entry_point(entry)[2]) def _cmd_dummy(self, args): pass@@ -68,18 +67,16 @@ entry = self._get_entry_point(self._get_arg(args, 0)) entry_fname = entry[0] num_ins = len(entry[1])- num_outs = len(entry[2])- exp_len = 1 + num_outs + num_ins+ exp_len = 2 + num_ins if len(args) != exp_len: raise self.Failure("Invalid argument count, expected %d" % exp_len) - out_vnames = args[1 : num_outs + 1]+ out_vname = args[1] - for out_vname in out_vnames:- self._check_new_var(out_vname)+ self._check_new_var(out_vname) - in_vnames = args[1 + num_outs :]+ in_vnames = args[2:] ins = [self._get_var(in_vname) for in_vname in in_vnames] try:@@ -89,11 +86,7 @@ print("runtime: %d" % runtime) - if num_outs == 1:- self._vars[out_vnames[0]] = vals- else:- for out_vname, val in zip(out_vnames, vals):- self._vars[out_vname] = val+ self._vars[out_vname] = vals def _store_val(self, f, value): # In case we are using the PyOpenCL backend, we first@@ -163,13 +156,34 @@ for k in self._ctx.opaques.keys(): print(k) + def _cmd_fields(self, args):+ tname = self._get_arg(args, 0)+ if not tname in self._ctx.opaques:+ raise self.Failure(f"Unknown type {tname}")+ else:+ t = self._ctx.opaques[tname]+ if type(t[1]) is tuple:+ i = 0+ for x in t[1]:+ print(i, x)+ i += 1++ def _cmd_project(self, args):+ dst = self._get_arg(args, 0)+ src = self._get_arg(args, 1)+ field = self._get_arg(args, 2)+ self._check_new_var(dst)+ self._check_var(src)+ # FIXME: assuming a tuple.+ self._vars[dst] = self._vars[src].data[int(field)]+ def _cmd_entry_points(self, args): for k in self._ctx.entry_points.keys(): print(k) _commands = { "inputs": _cmd_inputs,- "outputs": _cmd_outputs,+ "output": _cmd_output, "call": _cmd_call, "restore": _cmd_restore, "store": _cmd_store,@@ -181,6 +195,8 @@ "report": _cmd_dummy, "types": _cmd_types, "entry_points": _cmd_entry_points,+ "fields": _cmd_fields,+ "project": _cmd_project, } def _process_line(self, line):@@ -193,7 +209,7 @@ raise self.Failure("Empty line") else: cmd = words[0]- args = words[1:]+ args = [w.strip('"') for w in words[1:]] if cmd in self._commands: self._commands[cmd](self, args) else:
src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs view
@@ -212,9 +212,7 @@ prog0 :: Prog GPU prog0 = "\- \entry(\"main\",\- \ {xss: [][]i64},\- \ {[]i64})\+ \fun\ \ entry_main (n_5142 : i64,\ \ m_5143 : i64,\ \ xss_5144 : [n_5142][m_5143]i64)\
src/Futhark/AD/Rev.hs view
@@ -197,14 +197,25 @@ updateAdj arr =<< letExp "update_src_adj" (BasicOp $ Update safety pat_adj slice zeroes) -- See Note [Adjoints of accumulators]- UpdateAcc _ _ is vs -> do+ UpdateAcc safety _ is vs -> do addStm $ Let pat aux $ BasicOp e m pat_adjs <- mapM lookupAdjVal (patNames pat) returnSweepCode $ do forM_ (zip pat_adjs vs) $ \(adj, v) -> do adj_t <- lookupType adj- adj_i <- letExp "updateacc_val_adj" $ BasicOp $ Index adj $ fullSlice adj_t $ map DimFix is+ let index_adj = pure $ BasicOp $ Index adj $ fullSlice adj_t $ map DimFix is+ adj_i <-+ letExp "updateacc_val_adj" =<< case safety of+ Unsafe ->+ index_adj+ Safe ->+ -- The primal UpdateAcc may be out-of-bounds, in which case+ -- indexing the adjoint is dangerous.+ eIf+ (eShapeInBounds (arrayShape adj_t) (map eSubExp is))+ (eBody [index_adj])+ (eBody [pure $ zeroExp $ stripArray (length is) adj_t]) updateSubExpAdj v adj_i -- UserParam {} ->
src/Futhark/Bench.hs view
@@ -302,16 +302,16 @@ FilePath -> IO (Either T.Text ([RunResult], T.Text, ProfilingReport)) benchmarkDataset server opts futhark program entry input_spec expected_spec ref_out = runExceptT $ do- output_types <- cmdEither $ cmdOutputs server entry input_types <- cmdEither $ cmdInputs server entry- let outs = ["out" <> showText i | i <- [0 .. length output_types - 1]]+ output_type <- cmdEither $ cmdOutput server entry+ let out = "out" ins = ["in" <> showText i | i <- [0 .. length input_types - 1]] cmdMaybe . liftIO $ cmdClear server cmdMaybe . liftIO $ cmdPauseProfiling server - let freeOuts = cmdMaybe (cmdFree server outs)+ let freeOut = cmdMaybe (cmdFree server [out]) freeIns = cmdMaybe (cmdFree server ins) loadInput = valuesAsVars server (zip ins $ map inputType input_types) futhark dir input_spec reloadInput = freeIns >> loadInput@@ -326,7 +326,7 @@ Nothing doRun = do- call_lines <- cmdEither (cmdCall server entry outs ins)+ call_lines <- cmdEither (cmdCall server entry out ins) when (any inputConsumed input_types) reloadInput case mapMaybe runtime call_lines of [call_runtime] -> pure (RunResult call_runtime, call_lines)@@ -335,11 +335,11 @@ maybe_call_logs <- liftIO . timeout (runTimeout opts * 1000000) . runExceptT $ do -- First one uncounted warmup run.- void $ cmdEither $ cmdCall server entry outs ins+ void $ cmdEither $ cmdCall server entry out ins - ys <- runMinimum (freeOuts *> doRun) opts 0 0 mempty+ ys <- runMinimum (freeOut *> doRun) opts 0 0 mempty - xs <- runConvergence (freeOuts *> doRun) opts ys+ xs <- runConvergence (freeOut *> doRun) opts ys -- Possibly a profiled run at the end. profile_log <-@@ -347,7 +347,7 @@ then pure Nothing else do cmdMaybe . liftIO $ cmdUnpauseProfiling server- profile_log <- freeOuts *> doRun+ profile_log <- freeOut *> doRun cmdMaybe . liftIO $ cmdPauseProfiling server pure $ Just profile_log @@ -372,10 +372,10 @@ case maybe_expected of Just expected -> do- vs <- readResults server outs <* freeOuts+ vs <- readResults server (out, outputType output_type) <* freeOut checkResult program expected vs Nothing ->- freeOuts+ freeOut pure ( map fst call_logs,
src/Futhark/CLI/Dev.hs view
@@ -48,6 +48,7 @@ import Futhark.Optimise.Unstream import Futhark.Pass import Futhark.Pass.AD+import Futhark.Pass.AddGlobalParams import Futhark.Pass.ExpandAllocations import Futhark.Pass.ExplicitAllocations.GPU qualified as GPU import Futhark.Pass.ExplicitAllocations.MC qualified as MC@@ -714,6 +715,7 @@ soacsPassOption applyADInnermost [], kernelsPassOption optimiseArrayLayoutGPU [], mcPassOption optimiseArrayLayoutMC [],+ kernelsPassOption addGlobalParams [], kernelsPassOption optimiseGenRed [], kernelsPassOption tileLoops [], kernelsPassOption histAccsGPU [],
src/Futhark/CLI/Literate.hs view
@@ -848,7 +848,8 @@ zipWithM_ (writeBMPFile dir) [0 ..] bmps onWebM videofile =<< bmpsToVideo dir ValueTuple [stepfun, initial, num_frames]- | ValueAtom (SFun stepfun' _ [_, _] closure) <- stepfun,+ | ValueAtom (SFun stepfun' _ stepret closure) <- stepfun,+ Just [_, _] <- isScriptTuple (envServer env) stepret, ValueAtom (SValue "i64" _) <- num_frames -> do Just (ValueAtom num_frames') <- mapM getValue <$> getExpValue (envServer env) num_frames@@ -900,16 +901,18 @@ "Cannot handle step function return type: " <> prettyText (fmap scriptValueType v) - case v of- ValueTuple [arr_v@(ValueAtom SValue {}), new_state] -> do- ValueAtom arr <- getExpValue (envServer env) arr_v- freeValue (envServer env) arr_v- case valueToBMP arr of- Nothing -> nope- Just bmp -> do- writeBMPFile dir j bmp- pure new_state- _ -> nope+ arr <- project (envServer env) v "0"+ new_state <- project (envServer env) v "1"++ ValueAtom arr' <- getExpValue (envServer env) arr+ freeValue (envServer env) arr+ freeValue (envServer env) v++ case valueToBMP arr' of+ Nothing -> nope+ Just bmp -> do+ writeBMPFile dir j bmp+ pure new_state writeBMPFile dir j bmp = liftIO $ LBS.writeFile (bmpfile dir j) bmp
src/Futhark/CLI/Test.hs view
@@ -337,20 +337,20 @@ runCompiledEntry :: FutharkExe -> Server -> FilePath -> InputOutputs -> IO [TestResult] runCompiledEntry futhark server program (InputOutputs entry run_cases) = do- output_types <- cmdOutputs server entry input_types <- cmdInputs server entry- case (,) <$> output_types <*> input_types of+ output_type <- fmap outputType <$> cmdOutput server entry+ case (,) <$> input_types <*> output_type of Left (CmdFailure _ err) -> pure [Failure err]- Right (output_types', input_types') -> do- let outs = ["out" <> showText i | i <- [0 .. length output_types' - 1]]+ Right (input_types', out_t) -> do+ let out = "out" ins = ["in" <> showText i | i <- [0 .. length input_types' - 1]] onRes = either (Failure . pure) (const Success)- mapM (fmap onRes . runCompiledCase input_types' outs ins) run_cases+ mapM (fmap onRes . runCompiledCase input_types' (out, out_t) ins) run_cases where dir = takeDirectory program - runCompiledCase input_types outs ins run = runExceptT $ do+ runCompiledCase input_types (out, out_t) ins run = runExceptT $ do let TestRun _ input_spec _ index _ = run case_ctx = "Entry point: "@@ -363,7 +363,7 @@ valuesAsVars server (zip ins (map inputType input_types)) futhark dir input_spec - call_r <- liftIO $ cmdCall server entry outs ins+ call_r <- liftIO $ cmdCall server entry out ins liftCommand $ cmdFree server ins let res = case call_r of@@ -371,8 +371,8 @@ ErrorResult $ T.unlines err Right _ -> SuccessResult- (readResults server outs <* liftCommand (cmdFree server outs))- (liftCommand (cmdFree server outs))+ (readResults server (out, out_t) <* liftCommand (cmdFree server [out]))+ (liftCommand (cmdFree server [out])) compareResult entry index program expected res
src/Futhark/CodeGen/Backends/GenericC/CLI.hs view
@@ -299,15 +299,15 @@ cliEntryPoint :: Manifest -> T.Text -> EntryPoint -> (C.Definition, C.Initializer)-cliEntryPoint manifest entry_point_name (EntryPoint cfun _tuning_params outputs inputs _attrs) =+cliEntryPoint manifest entry_point_name (EntryPoint cfun _tuning_params output inputs _attrs) = let (input_items, pack_input, free_input, free_parsed, input_args) = unzip5 $ readInputs manifest $ map inputType inputs (output_decls, output_vals, free_outputs) =- unzip3 $ prepareOutputs manifest $ map outputType outputs+ unzip3 $ prepareOutputs manifest [outputType output] printstms =- printResult manifest $ zip (map outputType outputs) output_vals+ printResult manifest $ zip [outputType output] output_vals cli_entry_point_function_name = "futrts_cli_entry_" <> T.unpack (escapeName entry_point_name)
src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs view
@@ -82,11 +82,11 @@ pure ([C.cty|$ty:ty*|], checks) -prepareEntryOutputs :: [ExternalValue] -> CompilerM op s ([C.Param], [C.BlockItem])-prepareEntryOutputs = collect' . zipWithM prepare [(0 :: Int) ..]+prepareEntryOutput :: ExternalValue -> CompilerM op s (C.Param, [C.BlockItem])+prepareEntryOutput = collect' . prepare where- prepare pno (TransparentValue vd) = do- let pname = "out" ++ show pno+ prepare (TransparentValue vd) = do+ let pname = "out" :: T.Text ty <- valueTypeToCType Public $ valueDescToType vd case vd of@@ -97,8 +97,8 @@ ScalarValue {} -> do prepareValue [C.cexp|*$id:pname|] vd pure [C.cparam|$ty:ty *$id:pname|]- prepare pno (OpaqueValue desc vds) = do- let pname = "out" ++ show pno+ prepare (OpaqueValue desc vds) = do+ let pname = "out" :: T.Text ty <- opaqueToCType desc vd_ts <- mapM (valueTypeToCType Private . valueDescToType) vds @@ -150,8 +150,8 @@ (inputs', unpack_entry_inputs) <- prepareEntryInputs $ map snd args let (entry_point_input_params, entry_point_input_checks) = unzip inputs' - (entry_point_output_params, pack_entry_outputs) <-- prepareEntryOutputs $ map snd results+ (entry_point_output_param, pack_entry_outputs) <-+ prepareEntryOutput $ snd results ctx_ty <- contextType @@ -159,7 +159,7 @@ EntryDecl [C.cedecl|int $id:entry_point_function_name ($ty:ctx_ty *ctx,- $params:entry_point_output_params,+ $params:([entry_point_output_param]), $params:entry_point_input_params);|] let checks = catMaybes entry_point_input_checks@@ -194,7 +194,7 @@ [C.cedecl| int $id:entry_point_function_name ($ty:ctx_ty *ctx,- $params:entry_point_output_params,+ $params:([entry_point_output_param]), $params:entry_point_input_params) { $items:inputdecls $items:outputdecls@@ -214,7 +214,7 @@ -- Note that our convention about what is "input/output" -- and what is "results/args" is different between the -- manifest and ImpCode.- Manifest.entryPointOutputs = map outputManifest results,+ Manifest.entryPointOutput = outputManifest results, Manifest.entryPointInputs = map inputManifest args, Manifest.entryPointAttrs = map prettyText (S.toList (unAttrs attrs)) }
src/Futhark/CodeGen/Backends/GenericC/Server.hs view
@@ -393,30 +393,18 @@ manifest oneEntryBoilerplate :: Manifest -> (T.Text, EntryPoint) -> ([C.Definition], C.Initializer)-oneEntryBoilerplate manifest (name, EntryPoint cfun tuning_params outputs inputs attrs) =+oneEntryBoilerplate manifest (name, EntryPoint cfun tuning_params output inputs attrs) = let call_f = "call_" <> nameFromText name- out_types = map outputType outputs+ out_type = outputType output in_types = map inputType inputs- out_types_name = nameFromText name <> "_out_types" in_types_name = nameFromText name <> "_in_types"- out_unique_name = nameFromText name <> "_out_unique" in_unique_name = nameFromText name <> "_in_unique" tuning_params_name = nameFromText name <> "_tuning_params" attrs_name = nameFromText name <> "_attrs"- (out_items, out_args)- | null out_types = ([C.citems|(void)outs;|], mempty)- | otherwise = unzip $ zipWith loadOut [0 ..] out_types (in_items, in_args) | null in_types = ([C.citems|(void)ins;|], mempty) | otherwise = unzip $ zipWith loadIn [0 ..] in_types in ( [C.cunit|- const struct type* $id:out_types_name[] = {- $inits:(map typeStructInit out_types),- NULL- };- bool $id:out_unique_name[] = {- $inits:(map outputUniqueInit outputs)- }; const struct type* $id:in_types_name[] = { $inits:(map typeStructInit in_types), NULL@@ -432,10 +420,9 @@ $inits:(map (textInit . prettyText) attrs), NULL };- int $id:call_f(struct futhark_context *ctx, void **outs, void **ins) {- $items:out_items+ int $id:call_f(struct futhark_context *ctx, void *out, void **ins) { $items:in_items- return $id:cfun(ctx, $args:out_args, $args:in_args);+ return $id:cfun(ctx, out, $args:in_args); } |], [C.cinit|{@@ -443,9 +430,9 @@ .f = $id:call_f, .tuning_params = $id:tuning_params_name, .in_types = $id:in_types_name,- .out_types = $id:out_types_name,+ .out_type = $init:(typeStructInit out_type), .in_unique = $id:in_unique_name,- .out_unique = $id:out_unique_name,+ .out_unique = $init:(outputUniqueInit output), .attrs = $id:attrs_name }|] )@@ -456,11 +443,6 @@ uniqueInit True = [C.cinit|true|] uniqueInit False = [C.cinit|false|] - loadOut i tname =- let v = "out" ++ show (i :: Int)- in ( [C.citem|$ty:(cType manifest tname) *$id:v = outs[$int:i];|],- [C.cexp|$id:v|]- ) loadIn i tname = let v = "in" ++ show (i :: Int) in ( [C.citem|$ty:(cType manifest tname) $id:v = *($ty:(cType manifest tname)*)ins[$int:i];|],
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -332,7 +332,7 @@ functionExternalValues :: Imp.EntryPoint -> [Imp.ExternalValue] functionExternalValues entry =- map snd (Imp.entryPointResults entry) ++ map snd (Imp.entryPointArgs entry)+ snd (Imp.entryPointResults entry) : map snd (Imp.entryPointArgs entry) -- | Is this name a valid Python identifier? If not, it should be escaped -- before being emitted.@@ -405,7 +405,7 @@ ] ++ prog' where- Imp.Definitions params _types consts (Imp.Functions funs) = prog+ Imp.Definitions params opaques consts (Imp.Functions funs) = prog compileProg' = withConstantSubsts consts $ do compileConstants consts @@ -421,6 +421,21 @@ ] ) + pair x y = Tuple [x, y]++ opaques_def =+ Assign+ (Var "opaques")+ ( Dict $+ zip+ (map String opaque_names)+ ( zipWith+ pair+ (map Tuple opaque_payloads)+ (map opaqueTupleElems opaque_names)+ )+ )+ case mode of ToLibrary -> do (entry_points, entry_point_types) <-@@ -431,9 +446,7 @@ [ Assign (Var "entry_points") (Dict entry_point_types),- Assign- (Var "opaques")- (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads)),+ opaques_def, Assign (Var "sizes") (Dict $ map paramAssign $ M.toList params)@@ -450,9 +463,7 @@ [ Assign (Var "entry_points") (Dict entry_point_types),- Assign- (Var "opaques")- (Dict $ zip (map String opaque_names) (map Tuple opaque_payloads)),+ opaques_def, Assign (Var "sizes") (Dict $ map paramAssign $ M.toList params)@@ -495,6 +506,17 @@ (opaque_names, opaque_payloads) = unzip $ M.toList $ opaqueDefs $ Imp.defFuns prog + opaqueTupleElems opaque_name =+ case opaques of+ Imp.OpaqueTypes m+ | Just (Imp.OpaqueRecord ts) <- lookup (nameFromText opaque_name) m ->+ -- XXX: might not be tuple.+ Tuple $ map (String . p . snd) ts+ where+ p (Imp.TypeOpaque tname) = nameToText tname+ p (Imp.TypeTransparent vt) = prettyText vt+ _ -> None+ selectEntryPoint entry_point_names entry_points = [ Assign (Var "entry_points") $ Dict $@@ -583,7 +605,12 @@ entryPointOutput :: Imp.ExternalValue -> CompilerM op s PyExp entryPointOutput (Imp.OpaqueValue desc vs) =- simpleCall "opaque" . (String (prettyText desc) :)+ simpleCall "opaque"+ . ( [ String (prettyText desc),+ Field (Var "self") "opaques"+ ]+ <>+ ) <$> mapM (entryPointOutput . Imp.TransparentValue) vs entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) = do name' <- compileVar name@@ -799,34 +826,32 @@ "read_value" [String $ mconcat (replicate (length dims) "[]") <> type_name] -printValue :: [(Imp.ExternalValue, PyExp)] -> CompilerM op s [PyStmt]-printValue = fmap concat . mapM (uncurry printValue')- where- -- We copy non-host arrays to the host before printing. This is- -- done in a hacky way - we assume the value has a .get()-method- -- that returns an equivalent Numpy array. This works for PyOpenCL,- -- but we will probably need yet another plugin mechanism here in- -- the future.- printValue' (Imp.OpaqueValue desc _) _ =- pure- [ Exp $- simpleCall- "sys.stdout.write"- [String $ "#<opaque " <> nameToText desc <> ">"]- ]- printValue' (Imp.TransparentValue (Imp.ArrayValue mem (Space _) bt ept shape)) e =- printValue' (Imp.TransparentValue (Imp.ArrayValue mem DefaultSpace bt ept shape)) $- simpleCall (prettyString e ++ ".get") []- printValue' (Imp.TransparentValue _) e =- pure- [ Exp $- Call- (Var "write_value")- [ Arg e,- ArgKeyword "binary" (Var "binary_output")- ],- Exp $ simpleCall "sys.stdout.write" [String "\n"]- ]+printValue :: Imp.ExternalValue -> PyExp -> CompilerM op s [PyStmt]+-- We copy non-host arrays to the host before printing. This is+-- done in a hacky way - we assume the value has a .get()-method+-- that returns an equivalent Numpy array. This works for PyOpenCL,+-- but we will probably need yet another plugin mechanism here in+-- the future.+printValue (Imp.OpaqueValue desc _) _ =+ pure+ [ Exp $+ simpleCall+ "sys.stdout.write"+ [String $ "#<opaque " <> nameToText desc <> ">"]+ ]+printValue (Imp.TransparentValue (Imp.ArrayValue mem (Space _) bt ept shape)) e =+ printValue (Imp.TransparentValue (Imp.ArrayValue mem DefaultSpace bt ept shape)) $+ simpleCall (prettyString e ++ ".get") []+printValue (Imp.TransparentValue _) e =+ pure+ [ Exp $+ Call+ (Var "write_value")+ [ Arg e,+ ArgKeyword "binary" (Var "binary_output")+ ],+ Exp $ simpleCall "sys.stdout.write" [String "\n"]+ ] prepareEntry :: Imp.EntryPoint ->@@ -838,9 +863,9 @@ [PyStmt], [PyStmt], [PyStmt],- [(Imp.ExternalValue, PyExp)]+ (Imp.ExternalValue, PyExp) )-prepareEntry (Imp.EntryPoint _ results args) (fname, Imp.Function _ outputs inputs _ _) = do+prepareEntry (Imp.EntryPoint _ result args) (fname, Imp.Function _ outputs inputs _ _) = do let output_paramNames = map (compileName . Imp.paramName) outputs funTuple = tupleOrSingle $ fmap Var output_paramNames @@ -848,7 +873,7 @@ declEntryPointInputSizes $ map snd args mapM_ entryPointInput . zip3 [0 ..] (map snd args) $ map (Var . T.unpack . extValueDescName . snd) args- (res, prepareOut) <- collect' $ mapM (entryPointOutput . snd) results+ (res, prepareOut) <- collect' $ entryPointOutput $ snd result let argexps_lib = map (compileName . Imp.paramName) inputs fname' = "self." <> futharkFun (nameToText fname)@@ -869,7 +894,7 @@ prepareIn, call argexps_lib, prepareOut,- zip (map snd results) res+ (snd result, res) ) data ReturnTiming = ReturnTiming | DoNotReturnTiming@@ -887,14 +912,14 @@ case timing of DoNotReturnTiming -> ( [],- Return $ tupleOrSingle $ map snd res+ Return $ snd res ) ReturnTiming -> ( sync, Return $ Tuple [ Var "runtime",- tupleOrSingle $ map snd res+ snd res ] ) (pts, rts) = entryTypes entry@@ -918,15 +943,15 @@ Tuple [ String (escapeName ename), List (map String pts),- List (map String rts)+ String rts ] ) ) | otherwise = pure Nothing -entryTypes :: Imp.EntryPoint -> ([T.Text], [T.Text])+entryTypes :: Imp.EntryPoint -> ([T.Text], T.Text) entryTypes (Imp.EntryPoint _ res args) =- (map descArg args, map desc res)+ (map descArg args, desc res) where descArg ((_, u), d) = desc (u, d) desc (u, Imp.OpaqueValue d _) = prettyText u <> nameToText d@@ -960,7 +985,7 @@ (simpleCall "range" [simpleCall "int" [Var "num_runs"]]) do_run_with_timing - str_output <- printValue res+ str_output <- uncurry printValue res let fname' = "entry_" ++ T.unpack (escapeName fname)
src/Futhark/CodeGen/Backends/GenericWASM.hs view
@@ -52,7 +52,7 @@ data JSEntryPoint = JSEntryPoint { name :: String, parameters :: [EntryPointType],- ret :: [EntryPointType]+ ret :: EntryPointType } -- | A field in a JavaScript record opaque type.@@ -139,7 +139,7 @@ arrays = nubOrd $ filter isArray (entryPointTypes ++ recordFieldTypes) -- Include opaque types from both entry points and record fields. opaques = nubOrd $ filter isOpaque (entryPointTypes ++ recordFieldTypes)- entryPointTypes = concatMap (\jse -> parameters jse ++ ret jse) jses+ entryPointTypes = concatMap (\jse -> parameters jse ++ [ret jse]) jses recordFieldTypes = [jsrfType rf | (_, JSOpaqueRecord fields) <- opaqueTypes, rf <- fields] gfn typ str = "_futhark_" ++ typ ++ "_" ++ baseType str ++ "_" ++ show (dim str) ++ "d" allRecordFields = [rf | (_, JSOpaqueRecord fields) <- opaqueTypes, rf <- fields]@@ -177,7 +177,7 @@ -- Collect array types from entry points AND from record fields so the -- array constructors are always available when returning projected values. arrays = nubOrd $ filter isArray (entryPointTypes ++ recordFieldTypes)- entryPointTypes = concatMap (\jse -> parameters jse ++ ret jse) entryPoints+ entryPointTypes = concatMap (\jse -> parameters jse ++ [ret jse]) entryPoints recordFieldTypes = [jsrfType rf | (_, JSOpaqueRecord fields) <- opaqueTypes, rf <- fields] constructor :: [JSEntryPoint] -> [(String, JSOpaqueType)] -> T.Text@@ -321,11 +321,9 @@ ins = T.pack $ intercalate ", " [maybeDerefence ("in" ++ show i) $ parameters jse !! i | i <- alp] paramsToPtr = T.pack $ unlines $ filter ("" /=) [arrayPointer ("in" ++ show i) $ parameters jse !! i | i <- alp] - alr = [0 .. length (ret jse) - 1]- outparams = T.pack $ intercalate ", " [show $ typeSize $ ret jse !! i | i <- alr]- results = T.pack $ unlines [makeResult i $ ret jse !! i | i <- alr]- res_array = intercalate ", " ["result" ++ show i | i <- alr]- res = T.pack $ if length (ret jse) == 1 then "result0" else "[" ++ res_array ++ "]"+ outparams = showText $ typeSize $ ret jse+ results = T.pack $ makeResult 0 $ ret jse+ res = "result0" maybeDerefence :: String -> String -> String maybeDerefence arg typ =
src/Futhark/CodeGen/Backends/MulticoreWASM.hs view
@@ -72,6 +72,6 @@ JSEntryPoint { name = nameToString n, parameters = map (extToString . snd) args,- ret = map (extToString . snd) res+ ret = extToString $ snd res } in mapMaybe (function . snd) fs
src/Futhark/CodeGen/Backends/SequentialWASM.hs view
@@ -66,6 +66,6 @@ JSEntryPoint { name = nameToString n, parameters = map (extToString . snd) args,- ret = map (extToString . snd) res+ ret = extToString $ snd res } in mapMaybe (function . snd) fs
src/Futhark/CodeGen/Backends/SimpleRep.hs view
@@ -248,7 +248,13 @@ toExp (Int8Value k) _ = [C.cexp|(typename int8_t)$int:k|] toExp (Int16Value k) _ = [C.cexp|(typename int16_t)$int:k|] toExp (Int32Value k) _ = [C.cexp|$int:k|]- toExp (Int64Value k) _ = [C.cexp|(typename int64_t)$int:k|]+ toExp (Int64Value k) _+ -- C compilers warn on encountering -9223372036854775808, because this is+ -- read as the negation operator applied to 9223372036854775808, and this+ -- number is larger than the largest signed number. As a dumb workaround, we+ -- construct an equivalent expression.+ | k == minBound = [C.cexp|(typename int64_t)$int:(minBound+1::Int64)-1|]+ | otherwise = [C.cexp|(typename int64_t)$int:k|] instance C.ToExp FloatValue where toExp (Float16Value x) _
src/Futhark/CodeGen/ImpCode.hs view
@@ -216,7 +216,7 @@ -- | Information about how this function can be called from the outside world. data EntryPoint = EntryPoint { entryPointName :: Name,- entryPointResults :: [(Uniqueness, ExternalValue)],+ entryPointResults :: (Uniqueness, ExternalValue), entryPointArgs :: [((Name, Uniqueness), ExternalValue)] } deriving (Show)@@ -515,11 +515,11 @@ <+> nestedBlock (pretty code) instance Pretty EntryPoint where- pretty (EntryPoint name results args) =+ pretty (EntryPoint name result args) = stack [ "name" <+> nestedBlock (dquotes (pretty name)), "arguments" <+> nestedBlock (stack $ map ppArg args),- "results" <+> nestedBlock (stack $ map ppRes results)+ "results" <+> nestedBlock (ppRes result) ] where ppArg ((p, u), t) = pretty p <+> ":" <+> ppRes (u, t)@@ -778,7 +778,7 @@ instance FreeIn EntryPoint where freeIn' (EntryPoint _ res args) =- freeIn' (map snd res) <> freeIn' (map snd args)+ freeIn' (snd res) <> freeIn' (map snd args) instance (FreeIn a) => FreeIn (Functions a) where freeIn' (Functions fs) = foldMap (onFun . snd) fs
src/Futhark/CodeGen/ImpGen.hs view
@@ -624,13 +624,13 @@ (Mem rep inner) => OpaqueTypes -> [RetType rep] ->- [EntryResult] ->+ EntryResult -> [Maybe Imp.Param] ->- ImpM rep r op [(Uniqueness, Imp.ExternalValue)]+ ImpM rep r op (Uniqueness, Imp.ExternalValue) compileExternalValues types orig_rts orig_epts maybe_params = do let (ctx_rts, val_rts) = splitAt- (length orig_rts - sum (map (entryPointSize types . entryResultType) orig_epts))+ (length orig_rts - entryPointSize types (entryResultType orig_epts)) orig_rts let nthOut i = case maybeNth i maybe_params of@@ -657,25 +657,24 @@ mkValueDesc _ _ MemMem {} = error "mkValueDesc: unexpected MemMem output." - mkExts i (EntryResult u et@(TypeOpaque desc) : epts) rets = do- let signs = entryPointSignedness types et- n = entryPointSize types et- (rets', rest) = splitAt n rets- vds <- forM (zip3 [i ..] signs rets') $ \(j, s, r) -> mkValueDesc j s r- ((u, Imp.OpaqueValue desc vds) :) <$> mkExts (i + n) epts rest- mkExts i (EntryResult u (TypeTransparent (ValueType s _ _)) : epts) (ret : rets) = do- vd <- mkValueDesc i s ret- ((u, Imp.TransparentValue vd) :) <$> mkExts (i + 1) epts rets- mkExts _ _ _ = pure []+ num_ctx = length ctx_rts - mkExts (length ctx_rts) orig_epts val_rts+ case (orig_epts, val_rts) of+ (EntryResult u et@(TypeOpaque desc), rets) -> do+ let signs = entryPointSignedness types et+ vds <- forM (zip3 [num_ctx ..] signs rets) $ \(j, s, r) -> mkValueDesc j s r+ pure (u, Imp.OpaqueValue desc vds)+ (EntryResult u (TypeTransparent (ValueType s _ _)), [ret]) -> do+ vd <- mkValueDesc num_ctx s ret+ pure (u, Imp.TransparentValue vd)+ _ -> error "compileExternalValues: invalid inputs." compileOutParams :: (Mem rep inner) => OpaqueTypes -> [RetType rep] ->- Maybe [EntryResult] ->- ImpM rep r op (Maybe [(Uniqueness, Imp.ExternalValue)], [Imp.Param], [ValueDestination])+ Maybe EntryResult ->+ ImpM rep r op (Maybe (Uniqueness, Imp.ExternalValue), [Imp.Param], [ValueDestination]) compileOutParams types orig_rts maybe_orig_epts = do (maybe_params, dests) <- mapAndUnzipM compileOutParam orig_rts evs <- case maybe_orig_epts of
src/Futhark/CodeGen/ImpGen/GPU/Block.hs view
@@ -575,7 +575,8 @@ -- We don't need the red_pes, because it is guaranteed by our type -- rules that they occupy the same memory as the destinations for -- the ops.- let num_red_res = length ops + sum (map (length . histNeutral) ops)+ let num_is_res = sum $ map (shapeRank . histShape) ops+ num_red_res = num_is_res + sum (map (length . histNeutral) ops) (_red_pes, map_pes) = splitAt num_red_res $ patElems pat @@ -588,17 +589,18 @@ blockCoverSegSpace (segVirt lvl) space $ compileStms mempty (bodyStms kbody) $ do let (red_res, map_res) = splitAt num_red_res $ bodyResult kbody- (red_is, red_vs) = splitAt (length ops) $ map kernelResultSubExp red_res+ (red_is, red_vs) = splitAt num_is_res $ map kernelResultSubExp red_res zipWithM_ (compileThreadResult space) map_pes map_res - let vs_per_op = chunks (map (length . histDest) ops) red_vs+ let is_per_op = chunks (map (shapeRank . histShape) ops) red_is+ vs_per_op = chunks (map (length . histDest) ops) red_vs - forM_ (zip4 red_is vs_per_op ops' ops) $+ forM_ (zip4 is_per_op vs_per_op ops' ops) $ \(bin, op_vs, do_op, HistOp dest_shape _ _ _ shape lam) -> do- let bin' = pe64 bin+ let bin' = map pe64 bin dest_shape' = map pe64 $ shapeDims dest_shape- bin_in_bounds = inBounds (Slice [DimFix bin']) dest_shape'- bin_is = map Imp.le64 (init ltids) ++ [bin']+ bin_in_bounds = inBounds (Slice $ map DimFix bin') dest_shape'+ bin_is = map Imp.le64 (init ltids) ++ bin' vs_params = takeLast (length op_vs) $ lambdaParams lam sComment "perform atomic updates" $
src/Futhark/Construct.hs view
@@ -85,6 +85,7 @@ eAll, eAny, eDimInBounds,+ eShapeInBounds, eOutOfBounds, eIndex, eLast,@@ -392,6 +393,13 @@ LogAnd (eCmpOp (CmpSle Int64) (eSubExp (intConst Int64 0)) i) (eCmpOp (CmpSlt Int64) i w)++-- | Check if the given indexes are in-bounds for the given shape. The shape may have extra dimensions.+eShapeInBounds :: (MonadBuilder m) => Shape -> [m (Exp (Rep m))] -> m (Exp (Rep m))+eShapeInBounds (Shape ds) is =+ eAll+ =<< mapM (letSubExp "dim_in_bounds")+ =<< zipWithM eDimInBounds (map eSubExp (take (length is) ds)) is -- | Are these indexes out-of-bounds for the array? eOutOfBounds ::
src/Futhark/IR/Parse.hs view
@@ -664,10 +664,9 @@ <* pComma <*> pEntryPointInputs <* pComma- <*> pEntryPointResults+ <*> pEntryPointResult where pEntryPointInputs = braces (pEntryPointInput `sepBy` pComma)- pEntryPointResults = braces (pEntryPointResult `sepBy` pComma) pEntryPointInput = EntryParam <$> pName <* pColon <*> pUniqueness <*> pEntryPointType pEntryPointResult =
src/Futhark/IR/Pretty.hs view
@@ -422,7 +422,7 @@ <> comma </> ppTupleLines' (map pretty p_entry) <> comma- </> ppTupleLines' (map pretty ret_entry)+ </> pretty ret_entry ) instance Pretty OpaqueType where
src/Futhark/IR/Prop.hs view
@@ -32,6 +32,8 @@ expExtTypesFromPat, attrsForAssert, lamIsBinOp,+ isIdentityLambda,+ isNilLambda, ASTConstraints, IsOp (..), ASTRep (..),@@ -281,3 +283,15 @@ Prim t <- Just $ patElemType pe pure (op, t, paramName xp, paramName yp) splitStm _ = Nothing++-- | Is the given lambda an identity lambda?+isIdentityLambda :: Lambda rep -> Bool+isIdentityLambda lam =+ map resSubExp (bodyResult (lambdaBody lam))+ == map (Var . paramName) (lambdaParams lam)++-- | Is the given lambda a nil lambda?+isNilLambda :: Lambda rep -> Bool+isNilLambda lam =+ null (lambdaParams lam)+ && isIdentityLambda lam
src/Futhark/IR/SOACS/SOAC.hs view
@@ -20,8 +20,6 @@ soacType, typeCheckSOAC, mkIdentityLambda,- isIdentityLambda,- isNilLambda, nilFn, maposcanomapSOAC, scanomapSOAC,@@ -247,18 +245,6 @@ lambdaBody = mkBody mempty $ varsRes $ map paramName params, lambdaReturnType = ts }---- | Is the given lambda an identity lambda?-isIdentityLambda :: Lambda rep -> Bool-isIdentityLambda lam =- map resSubExp (bodyResult (lambdaBody lam))- == map (Var . paramName) (lambdaParams lam)---- | Is the given lambda a nil lambda?-isNilLambda :: Lambda rep -> Bool-isNilLambda lam =- null (lambdaParams lam)- && isIdentityLambda lam -- | A lambda with no parameters that returns no values. nilFn :: (Buildable rep) => Lambda rep
src/Futhark/IR/Syntax.hs view
@@ -610,7 +610,7 @@ -- | Information about the inputs and outputs (return value) of an entry -- point.-type EntryPoint = (Name, [EntryParam], [EntryResult])+type EntryPoint = (Name, [EntryParam], EntryResult) -- | An entire Futhark program. data Prog rep = Prog
src/Futhark/Internalise/Entry.hs view
@@ -271,22 +271,8 @@ runGenOpaque $ (name,,) <$> mapM onParam params- <*> ( map (uncurry I.EntryResult)- <$> case ( E.isTupleRecord $ E.entryType eret,- E.entryAscribed eret- ) of- (Just ts, Just (E.TETuple e_ts _)) ->- zipWithM- (entryPointType types)- (zipWith E.EntryType ts (map Just e_ts))- crets- (Just ts, Nothing) ->- zipWithM- (entryPointType types)- (map (`E.EntryType` Nothing) ts)- crets- _ ->- pure <$> entryPointType types eret (concat crets)+ <*> ( uncurry I.EntryResult+ <$> entryPointType types eret (concat crets) ) where onParam (E.EntryParam e_p e_t, ps) =
src/Futhark/Internalise/FullNormalise.hs view
@@ -25,7 +25,6 @@ import Data.Bifunctor import Data.List.NonEmpty qualified as NE import Data.Map qualified as M-import Data.Text qualified as T import Futhark.MonadFreshNames import Futhark.Util (showText) import Futhark.Util.Loc (srcspan)@@ -33,18 +32,15 @@ import Language.Futhark.Traversals import Language.Futhark.TypeChecker.Types --- Modifier to apply on binding, this is used to propagate attributes and move assertions-data BindModifier- = Ass Exp (Info T.Text) SrcLoc- | Att (AttrInfo VName)+-- Modifier to apply on bindings, this is used to propagate attributes.+newtype BindModifier+ = Att (AttrInfo VName) -- Apply a list of modifiers, removing the assertions as it is not needed to check them multiple times applyModifiers :: Exp -> [BindModifier] -> (Exp, [BindModifier]) applyModifiers = foldr f . (,[]) where- f (Ass ass txt loc) (body, modifs) =- (Assert ass body txt loc, modifs) f (Att attr) (body, modifs) = (Attr attr body mempty, Att attr : modifs) @@ -136,18 +132,8 @@ getOrdering :: Bool -> Exp -> OrderingM Exp getOrdering final (Assert ass e txt loc) = do ass' <- getOrdering False ass- l_prev <- OrderingM $ gets $ length . snd . fst- addModifier $ Ass ass' txt loc e' <- getOrdering final e- l_after <- OrderingM $ gets $ length . snd . fst- -- if the list of modifier has reduced in size, that means that- -- all assertions as been inserted,- -- else, we have to introduce the assertion ourself- if l_after <= l_prev- then pure e'- else do- rmModifier- pure $ Assert ass' e' txt loc+ pure $ Assert ass' e' txt loc getOrdering final (Attr attr e loc) = do -- propagate attribute addModifier $ Att attr
src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs view
@@ -218,14 +218,22 @@ op <- binops let shp = Shape segment_dims <> segBinOpShape op map (`arrayOfShape` shp) (lambdaReturnType $ segBinOpLambda op)-shortCircuitSegOp lvlOK lutab pat pat_certs (SegScan lvl space _ kernel_body binops post_op) td_env bu_env =- -- Like in the handling of 'SegRed', we do not want to coalesce anything that- -- is used in the 'SegBinOp'. We do not coalesce anything that is using in SegPostOp either.- let free_in_lams = freeIn (segPostOpLambda post_op) <> foldMap (freeIn . segBinOpLambda) binops- to_fail = M.filter (\entry -> namesFromList (M.keys $ vartab entry) `namesIntersect` free_in_lams) $ activeCoals bu_env- (active, inh) = foldl markFailedCoal (activeCoals bu_env, inhibit bu_env) $ M.keys to_fail- bu_env' = bu_env {activeCoals = active, inhibit = inh}- in shortCircuitSegOpHelper 0 lvlOK lvl lutab pat pat_certs space kernel_body td_env bu_env'+shortCircuitSegOp lvlOK lutab pat pat_certs (SegScan lvl space _ kernel_body binops post_op) td_env bu_env+ -- FIXME: shortCircuitSegOpHelper assumes that the kernel_body results go+ -- directly to the pattern, which is not the case when there is a non-identity+ -- postop. We might lose some optimisation possibilities due to this+ -- conservative check.+ | not $ isIdentityLambda $ segPostOpLambda post_op =+ let (active, inh) = foldl markFailedCoal (activeCoals bu_env, inhibit bu_env) $ M.keys (activeCoals bu_env)+ in pure $ bu_env {activeCoals = active, inhibit = inh}+ | otherwise =+ -- Like in the handling of 'SegRed', we do not want to coalesce anything that+ -- is used in the 'SegBinOp'. We do not coalesce anything that is using in SegPostOp either.+ let free_in_lams = freeIn (segPostOpLambda post_op) <> foldMap (freeIn . segBinOpLambda) binops+ to_fail = M.filter (\entry -> namesFromList (M.keys $ vartab entry) `namesIntersect` free_in_lams) $ activeCoals bu_env+ (active, inh) = foldl markFailedCoal (activeCoals bu_env, inhibit bu_env) $ M.keys to_fail+ bu_env' = bu_env {activeCoals = active, inhibit = inh}+ in shortCircuitSegOpHelper 0 lvlOK lvl lutab pat pat_certs space kernel_body td_env bu_env' shortCircuitSegOp lvlOK lutab pat pat_certs (SegHist lvl space _ kernel_body histops) td_env bu_env = do -- Need to take zipped patterns and histDest (flattened) and insert transitive coalesces let to_fail = M.filter (\entry -> namesFromList (M.keys $ vartab entry) `namesIntersect` foldMap (freeIn . histOp) histops) $ activeCoals bu_env
src/Futhark/Optimise/Fusion/RulesWithAccs.hs view
@@ -31,6 +31,7 @@ where import Control.Monad+import Data.List qualified as L import Data.Map.Strict qualified as M import Futhark.Construct import Futhark.IR.SOACS hiding (SOAC (..))@@ -46,28 +47,75 @@ -- 2. the withacc input -- 3-5 withacc's lambda corresponding acc-certificate param, -- argument param and result name-type AccTup =- ( [PatElem (LetDec SOACS)],- WithAccInput SOACS,- LParam SOACS,- LParam SOACS,- (VName, Certs)- )--accTup1 :: AccTup -> [PatElem (LetDec SOACS)]-accTup1 (a, _, _, _, _) = a+data AccTup = AccTup+ { accTup1 :: [PatElem (LetDec SOACS)],+ accTup2 :: WithAccInput SOACS,+ accTup3 :: LParam SOACS,+ accTup4 :: LParam SOACS,+ accTup5 :: (VName, Certs)+ }+ deriving (Show) -accTup2 :: AccTup -> WithAccInput SOACS-accTup2 (_, a, _, _, _) = a+groupAccs ::+ [PatElem (LetDec SOACS)] ->+ [WithAccInput SOACS] ->+ Lambda SOACS ->+ ([AccTup], [(PatElem (LetDec SOACS), SubExpRes)])+groupAccs pat_els wacc_inps wlam =+ let lam_params = lambdaParams wlam+ n = length lam_params+ (lam_par_crts, lam_par_accs) = splitAt (n `div` 2) lam_params+ lab_res_ses = bodyResult $ lambdaBody wlam+ in groupAccsHlp pat_els wacc_inps lam_par_crts lam_par_accs lab_res_ses -accTup3 :: AccTup -> LParam SOACS-accTup3 (_, _, a, _, _) = a+groupAccsHlp ::+ [PatElem (LetDec SOACS)] ->+ [WithAccInput SOACS] ->+ [LParam SOACS] ->+ [LParam SOACS] ->+ [SubExpRes] ->+ ([AccTup], [(PatElem (LetDec SOACS), SubExpRes)])+groupAccsHlp pat_els [] [] [] lam_res_ses+ | length pat_els == length lam_res_ses =+ ([], zip pat_els lam_res_ses)+groupAccsHlp+ pat_els+ (winp@(_, inp, _) : wacc_inps)+ (par_crt : lam_par_crts)+ (par_acc : lam_par_accs)+ (res_se : lam_res_ses)+ | n <- length inp,+ Var res_nm <- resSubExp res_se =+ let (pat_els_cur, pat_els') = splitAt n pat_els+ (rec1, rec2) = groupAccsHlp pat_els' wacc_inps lam_par_crts lam_par_accs lam_res_ses+ in (AccTup pat_els_cur winp par_crt par_acc (res_nm, resCerts res_se) : rec1, rec2)+groupAccsHlp _ _ _ _ _ =+ error "Unreachable case reached in groupAccsHlp!" -accTup4 :: AccTup -> LParam SOACS-accTup4 (_, _, _, a, _) = a+matchingAccTup :: AccTup -> AccTup -> Bool+matchingAccTup+ (AccTup pat_els1 (shp1, _winp_arrs1, mlam1) _ _ _)+ (AccTup _ (shp2, winp_arrs2, mlam2) _ _ _) =+ shapeDims shp1 == shapeDims shp2+ && map patElemName pat_els1 == winp_arrs2+ && case (mlam1, mlam2) of+ (Nothing, Nothing) -> True+ (Just (lam1, see1), Just (lam2, see2)) ->+ see1 == see2 && equivLambda M.empty lam1 lam2+ _ -> False -accTup5 :: AccTup -> (VName, Certs)-accTup5 (_, _, _, _, a) = a+groupCommonAccs :: [AccTup] -> [AccTup] -> ([(AccTup, AccTup)], [AccTup], [AccTup])+groupCommonAccs [] tup_accs2 =+ ([], [], tup_accs2)+groupCommonAccs (tup_acc1 : tup_accs1) tup_accs2+ | (commons2, uncommons2) <- L.partition (matchingAccTup tup_acc1) tup_accs2,+ length commons2 <= 1 =+ let (rec1, rec2, rec3) = groupCommonAccs tup_accs1 uncommons2+ in if null commons2+ then (rec1, tup_acc1 : rec2, rec3)+ else ((tup_acc1, head commons2) : rec1, rec2, rec3)+groupCommonAccs _ _ =+ error "Unreachable case reached in groupCommonAccs!" -- | Simple case for fusing two withAccs (can be extended): -- let (b1, ..., bm, x1, ..., xq) = withAcc a1 ... am lam1@@ -104,14 +152,13 @@ groupCommonAccs acc_tup1 acc_tup2, -- safety 0: make sure that the accs from acc_tup1' and -- acc_tup2' do not overlap- pnms_1' <- map patElemName $ concatMap (\(nms, _, _, _, _) -> nms) acc_tup1',- winp_2' <- concatMap (\(_, (_, nms, _), _, _, _) -> nms) acc_tup2',+ pnms_1' <- map patElemName $ concatMap accTup1 acc_tup1',+ winp_2' <- concatMap ((\(_, xs, _) -> xs) . accTup2) acc_tup2', not $ namesIntersect (namesFromList pnms_1') (namesFromList winp_2'), -- safety 1: we have already determined the commons; -- now we also need to check NOT-IN FV(lam2) not $ namesIntersect (namesFromList pnms_1') (freeIn lam2), -- safety 2:- -- bs <- map patElemName $ concatMap accTup1 acc_tup1, bs <- map patElemName $ concatMap (accTup1 . fst) tup_common, all (`notElem` infusible) bs, -- safety 3:@@ -129,34 +176,25 @@ bdyres_accse = map Var comm_res_nms ++ map (Var . fst . accTup5) (acc_tup1' ++ acc_tup2') bdy_res_accs = zipWith SubExpRes bdyres_certs bdyres_accse bdy_res_others = map snd $ other_pr1 ++ other_pr2- scope <- askScope- lam_bdy <-- runBodyBuilder $ do- localScope (scope <> scopeOfLParams (rcrt_params ++ racc_params)) $ do- -- add the stms of lam1- mapM_ addStm $ stmsToList $ bodyStms $ lambdaBody lam1- -- add the copy stms for the common accumulator- forM_ tup_common $ \(tup1, tup2) -> do- let (lpar1, lpar2) = (accTup4 tup1, accTup4 tup2)- ((nm1, _), nm2, tp_acc) = (accTup5 tup1, paramName lpar2, paramDec lpar1)- letBind (Pat [PatElem nm2 tp_acc]) $ BasicOp $ SubExp $ Var nm1- -- add copy stms to bring in scope x1 ... xq- forM_ other_pr1 $ \(pat_elm, bdy_res) -> do- let (nm, se, tp) = (patElemName pat_elm, resSubExp bdy_res, patElemType pat_elm)- certifying (resCerts bdy_res) $- letBind (Pat [PatElem nm tp]) $- BasicOp (SubExp se)- -- add the statements of lam2 (in which the acc-certificates have been substituted)- mapM_ addStm $ stmsToList $ bodyStms lam2_bdy'- -- build the result of body- pure $ bdy_res_accs ++ bdy_res_others- let tp_res_other = map (patElemType . fst) (other_pr1 ++ other_pr2)- res_lam =- Lambda- { lambdaParams = rcrt_params ++ racc_params,- lambdaBody = lam_bdy,- lambdaReturnType = map paramDec racc_params ++ tp_res_other- }+ res_lam <-+ runLambdaBuilder (rcrt_params ++ racc_params) $ do+ -- add the stms of lam1+ mapM_ addStm $ stmsToList $ bodyStms $ lambdaBody lam1+ -- add the copy stms for the common accumulator+ forM_ tup_common $ \(tup1, tup2) -> do+ let (lpar1, lpar2) = (accTup4 tup1, accTup4 tup2)+ ((nm1, _), nm2, tp_acc) = (accTup5 tup1, paramName lpar2, paramDec lpar1)+ letBind (Pat [PatElem nm2 tp_acc]) $ BasicOp $ SubExp $ Var nm1+ -- add copy stms to bring in scope x1 ... xq+ forM_ other_pr1 $ \(pat_elm, bdy_res) -> do+ let (nm, se, tp) = (patElemName pat_elm, resSubExp bdy_res, patElemType pat_elm)+ certifying (resCerts bdy_res) $+ letBind (Pat [PatElem nm tp]) $+ BasicOp (SubExp se)+ -- add the statements of lam2 (in which the acc-certificates have been substituted)+ mapM_ addStm $ stmsToList $ bodyStms lam2_bdy'+ -- build the result of body+ pure $ bdy_res_accs ++ bdy_res_others res_lam' <- renameLambda res_lam let res_pat = concatMap (accTup1 . snd) tup_common@@ -166,60 +204,6 @@ res_w_inps' <- mapM renameLamInWAccInp res_w_inps pure $ Let (Pat res_pat) (aux1 <> aux2) $ WithAcc res_w_inps' res_lam' where- -- local helpers:-- groupAccs ::- [PatElem (LetDec SOACS)] ->- [WithAccInput SOACS] ->- Lambda SOACS ->- ([AccTup], [(PatElem (LetDec SOACS), SubExpRes)])- groupAccs pat_els wacc_inps wlam =- let lam_params = lambdaParams wlam- n = length lam_params- (lam_par_crts, lam_par_accs) = splitAt (n `div` 2) lam_params- lab_res_ses = bodyResult $ lambdaBody wlam- in groupAccsHlp pat_els wacc_inps lam_par_crts lam_par_accs lab_res_ses- groupAccsHlp ::- [PatElem (LetDec SOACS)] ->- [WithAccInput SOACS] ->- [LParam SOACS] ->- [LParam SOACS] ->- [SubExpRes] ->- ([AccTup], [(PatElem (LetDec SOACS), SubExpRes)])- groupAccsHlp pat_els [] [] [] lam_res_ses- | length pat_els == length lam_res_ses =- ([], zip pat_els lam_res_ses)- groupAccsHlp- pat_els- (winp@(_, inp, _) : wacc_inps)- (par_crt : lam_par_crts)- (par_acc : lam_par_accs)- (res_se : lam_res_ses)- | n <- length inp,- (n <= length pat_els) && (n <= (1 + length lam_res_ses)),- Var res_nm <- resSubExp res_se =- let (pat_els_cur, pat_els') = splitAt n pat_els- (rec1, rec2) = groupAccsHlp pat_els' wacc_inps lam_par_crts lam_par_accs lam_res_ses- in ((pat_els_cur, winp, par_crt, par_acc, (res_nm, resCerts res_se)) : rec1, rec2)- groupAccsHlp _ _ _ _ _ =- error "Unreachable case reached in groupAccsHlp!"- --- groupCommonAccs :: [AccTup] -> [AccTup] -> ([(AccTup, AccTup)], [AccTup], [AccTup])- groupCommonAccs [] tup_accs2 =- ([], [], tup_accs2)- groupCommonAccs (tup_acc1 : tup_accs1) tup_accs2- | commons2 <- filter (matchingAccTup tup_acc1) tup_accs2,- length commons2 <= 1 =- let (rec1, rec2, rec3) =- groupCommonAccs tup_accs1 $- if null commons2- then tup_accs2- else filter (not . matchingAccTup tup_acc1) tup_accs2- in if null commons2- then (rec1, tup_acc1 : rec2, rec3)- else ((tup_acc1, head commons2) : rec1, tup_accs1, rec3)- groupCommonAccs _ _ =- error "Unreachable case reached in groupCommonAccs!" renameLamInWAccInp (shp, inps, Just (lam, se)) = do lam' <- renameLambda lam pure (shp, inps, Just (lam', se))@@ -232,6 +216,13 @@ --- simple helper functions --- ------------------------------- +substInSEs :: M.Map VName VName -> [SubExp] -> [SubExp]+substInSEs vtab = map substInSE+ where+ substInSE (Var x)+ | Just y <- M.lookup x vtab = Var y+ substInSE z = z+ equivLambda :: M.Map VName VName -> Lambda SOACS ->@@ -277,22 +268,3 @@ in (M.union stab_new stab, True) -- To Be Continued ... equivStm vtab _ _ = (vtab, False)--matchingAccTup :: AccTup -> AccTup -> Bool-matchingAccTup- (pat_els1, (shp1, _winp_arrs1, mlam1), _, _, _)- (_, (shp2, winp_arrs2, mlam2), _, _, _) =- shapeDims shp1 == shapeDims shp2- && map patElemName pat_els1 == winp_arrs2- && case (mlam1, mlam2) of- (Nothing, Nothing) -> True- (Just (lam1, see1), Just (lam2, see2)) ->- (see1 == see2) && equivLambda M.empty lam1 lam2- _ -> False--substInSEs :: M.Map VName VName -> [SubExp] -> [SubExp]-substInSEs vtab = map substInSE- where- substInSE (Var x)- | Just y <- M.lookup x vtab = Var y- substInSE z = z
+ src/Futhark/Pass/AddGlobalParams.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE LambdaCase #-}++-- | Add explicit parameters for global names used in device functions.+--+-- The purpose of this pass is to ensure that no functions called from within a+-- parallel section (identified by `SegMap`, `SegRed`, `SegScan, `SegHist`, or+-- `GPUBody`) reference a global name directly. We call these functions "device+-- functions". A global name is a name bound by a statement outside of any+-- defunction definition. This is done by:+--+-- 1. Identifying which global names are referenced by each device function.+-- Since device functions can call each other, this must be determined+-- transitively, using a call graph.+--+-- 2. Adding new parameters to each device function corresponding to each of the+-- global names used by that function.+--+-- 3. Updating each application of a device function to include these new names.+--+-- The main complication is that it is not allowed for a device function to have+-- parameter names that are the same as global names - shadowing is not allowed.+-- However, it is legal for different device functions to have the same+-- parameter names. Hence, once it has been determined which global names are+-- used in device functions, we compute a map that associates the global names+-- to parameter names, and use these. This implies that these names must also be+-- substituted into the device function bodies. Note that when modifying the+-- application of the outermost device function call with additional function+-- arguments, we must use the original global names.+module Futhark.Pass.AddGlobalParams (addGlobalParams) where++import Control.Monad+import Control.Monad.Identity+import Control.Monad.State.Strict+import Data.Map.Strict qualified as M+import Data.Maybe (mapMaybe)+import Data.Set qualified as S+import Futhark.IR.GPU+import Futhark.MonadFreshNames+import Futhark.Pass+import Futhark.Transform.Substitute++data CallMode = AllCalls | ParallelCalls+ deriving (Eq)++callsInProg :: CallMode -> Prog GPU -> S.Set Name+callsInProg mode prog =+ callsInStms mode False (progConsts prog)+ <> foldMap (callsInBody mode False . funDefBody) (progFuns prog)++calledInParallel :: Prog GPU -> S.Set Name+calledInParallel = callsInProg ParallelCalls++callsInGBody :: CallMode -> Bool -> GBody GPU res -> S.Set Name+callsInGBody mode in_parallel = callsInStms mode in_parallel . bodyStms++callsInBody :: CallMode -> Bool -> Body GPU -> S.Set Name+callsInBody = callsInGBody++callsInKernelBody :: CallMode -> KernelBody GPU -> S.Set Name+callsInKernelBody mode = callsInGBody mode True++callsInStms :: CallMode -> Bool -> Stms GPU -> S.Set Name+callsInStms mode in_parallel =+ foldMap (callsInExp mode in_parallel . stmExp) . stmsToList++callsInExp :: CallMode -> Bool -> Exp GPU -> S.Set Name+callsInExp mode in_parallel = \case+ Apply fname _ _ _+ | mode == AllCalls || in_parallel -> S.singleton fname+ | otherwise -> mempty+ Match _ cases defbody _ ->+ foldMap (callsInBody mode in_parallel . caseBody) cases+ <> callsInBody mode in_parallel defbody+ Loop _ _ body ->+ callsInBody mode in_parallel body+ WithAcc inputs lam ->+ foldMap+ ( \(_, _, op) ->+ maybe mempty (\(f, _) -> callsInLambda mode in_parallel f) op+ )+ inputs+ <> callsInLambda mode in_parallel lam+ Op op ->+ callsInOp mode in_parallel op+ _ ->+ mempty++callsInLambda :: CallMode -> Bool -> Lambda GPU -> S.Set Name+callsInLambda mode in_parallel (Lambda _ _ body) = callsInBody mode in_parallel body++tell :: (MonadState s m, Semigroup s) => s -> m ()+tell x = modify (<> x)++callsInSOAC :: CallMode -> Bool -> SOAC GPU -> S.Set Name+callsInSOAC mode in_parallel soac =+ execState (void $ mapSOACM mapper soac) mempty+ where+ mapper =+ identitySOACMapper+ { mapOnSOACLambda = \lam -> do+ tell $ callsInLambda mode in_parallel lam+ pure lam+ }++callsInSegOp :: CallMode -> SegOp SegLevel GPU -> S.Set Name+callsInSegOp mode segop =+ execState (void $ mapSegOpM mapper segop) mempty+ where+ mapper =+ identitySegOpMapper+ { mapOnSegBinOpLambda = \lam -> do+ tell $ callsInLambda mode True lam+ pure lam,+ mapOnSegPostOpLambda = \lam -> do+ tell $ callsInLambda mode True lam+ pure lam,+ mapOnSegOpBody = \body -> do+ tell $ callsInKernelBody mode body+ pure body+ }++callsInOp :: CallMode -> Bool -> Op GPU -> S.Set Name+callsInOp mode in_parallel = \case+ SegOp segop ->+ callsInSegOp mode segop+ OtherOp soac ->+ callsInSOAC mode in_parallel soac+ GPUBody _ body ->+ callsInBody mode True body+ _ ->+ mempty++buildCallGraphGPU :: Prog GPU -> M.Map Name (S.Set Name)+buildCallGraphGPU =+ M.fromList+ . map (\fd -> (funDefName fd, callsInBody AllCalls False $ funDefBody fd))+ . progFuns++transitiveClosure :: (Ord k) => M.Map k (S.Set k) -> S.Set k -> S.Set k+transitiveClosure graph = go+ where+ go seen =+ let seen' =+ seen+ <> S.unions+ [M.findWithDefault mempty f graph | f <- S.toList seen]+ in if seen' == seen then seen else go seen'++globalsPerFun ::+ M.Map Name (S.Set Name) ->+ M.Map Name (S.Set VName) ->+ M.Map Name (S.Set VName)+globalsPerFun call_graph = fixpoint+ where+ fixpoint m =+ let step f gs =+ gs+ <> S.unions+ [ M.findWithDefault mempty g m+ | g <- S.toList $ M.findWithDefault mempty f call_graph+ ]+ m' = M.mapWithKey step m+ in if m' == m then m else fixpoint m'++globalTypes :: Stms GPU -> M.Map VName DeclType+globalTypes =+ M.fromList+ . concatMap+ ( map+ (\pe -> (patElemName pe, toDecl (patElemType pe) Nonunique))+ . patElems+ . stmPat+ )+ . stmsToList++transformProg :: Prog GPU -> PassM (Prog GPU)+transformProg prog = do+ let global_tps = globalTypes $ progConsts prog+ globals = M.keysSet global_tps+ call_graph = buildCallGraphGPU prog+ roots = calledInParallel prog+ device_funs = transitiveClosure call_graph roots+ direct_globals =+ M.fromList+ [ (funDefName fd, S.fromList (namesToList $ freeIn fd) `S.intersection` globals)+ | fd <- progFuns prog,+ funDefName fd `S.member` device_funs+ ]+ transitive_globals = globalsPerFun call_graph direct_globals+ all_used_globals = S.unions $ M.elems transitive_globals++ global_to_param <-+ M.fromList <$> mapM (\g -> (g,) <$> newName g) (S.toAscList all_used_globals)++ let globals_ordered =+ M.map S.toAscList transitive_globals+ globals_for_fun f =+ M.findWithDefault mempty f globals_ordered+ params_for =+ mapMaybe $ \g -> do+ p <- M.lookup g global_to_param+ t <- M.lookup g global_tps+ pure $ Param mempty p t+ use_name env g = M.findWithDefault g g env+ call_args env f =+ [ (Var $ use_name env g, Observe)+ | g <- globals_for_fun f+ ]+ call_rewriter :: M.Map VName VName -> Exp GPU -> Exp GPU+ call_rewriter env (Apply fname args rettype safety) =+ Apply fname (args <> call_args env fname) rettype safety+ call_rewriter env e = mapExp mapper e+ where+ mapper :: Mapper GPU GPU Identity+ mapper =+ Mapper+ { mapOnSubExp = pure,+ mapOnBody = const $ pure . rewriteBody env,+ mapOnVName = pure,+ mapOnRetType = pure,+ mapOnBranchType = pure,+ mapOnFParam = pure,+ mapOnLParam = pure,+ mapOnOp = pure . rewriteOp env+ }+ rewriteStm :: M.Map VName VName -> Stm GPU -> Stm GPU+ rewriteStm env (Let pat aux e) = Let pat aux $ call_rewriter env e+ rewriteStms :: M.Map VName VName -> Stms GPU -> Stms GPU+ rewriteStms env = stmsFromList . map (rewriteStm env) . stmsToList+ rewriteGBody :: M.Map VName VName -> GBody GPU res -> GBody GPU res+ rewriteGBody env (Body dec stms res) =+ Body dec (rewriteStms env stms) res+ rewriteBody :: M.Map VName VName -> Body GPU -> Body GPU+ rewriteBody = rewriteGBody+ rewriteKernelBody :: M.Map VName VName -> KernelBody GPU -> KernelBody GPU+ rewriteKernelBody = rewriteGBody+ rewriteLambda :: M.Map VName VName -> Lambda GPU -> Lambda GPU+ rewriteLambda env (Lambda ps ret body) =+ Lambda ps ret $ rewriteBody env body+ rewriteOp :: M.Map VName VName -> Op GPU -> Op GPU+ rewriteOp env (SegOp segop) =+ let segmapper =+ identitySegOpMapper+ { mapOnSegBinOpLambda = pure . rewriteLambda env,+ mapOnSegPostOpLambda = pure . rewriteLambda env,+ mapOnSegOpBody = pure . rewriteKernelBody env+ }+ in SegOp $ runIdentity $ mapSegOpM segmapper segop+ rewriteOp env (OtherOp soac) =+ let soacmapper =+ identitySOACMapper+ { mapOnSOACLambda = pure . rewriteLambda env+ }+ in OtherOp $ runIdentity $ mapSOACM soacmapper soac+ rewriteOp env (GPUBody ts body) =+ GPUBody ts $ rewriteBody env body+ rewriteOp _ op = op++ rewriteFun :: FunDef GPU -> FunDef GPU+ rewriteFun fd+ | funDefName fd `S.member` device_funs =+ let gs = globals_for_fun (funDefName fd)+ env =+ M.fromList+ [ (g, p)+ | g <- gs,+ Just p <- [M.lookup g global_to_param]+ ]+ substs = env+ extra_params = params_for gs+ body' = substituteNames substs $ funDefBody fd+ in fd+ { funDefParams = funDefParams fd <> extra_params,+ funDefBody = rewriteBody env body'+ }+ | otherwise =+ fd {funDefBody = rewriteBody mempty (funDefBody fd)}++ pure+ prog+ { progConsts = rewriteStms mempty $ progConsts prog,+ progFuns = map rewriteFun $ progFuns prog+ }++-- | Ensure that device functions do not reference global names directly.+addGlobalParams :: Pass GPU GPU+addGlobalParams =+ Pass+ { passName = "add global params",+ passDescription = "Thread global names explicitly into device functions.",+ passFunction = transformProg+ }
src/Futhark/Pass/ExplicitAllocations/GPU.hs view
@@ -76,7 +76,8 @@ local inThread . allocInBinOpLambda num_threads (segSpace op), mapOnSegPostOpLambda =- local inThread+ localScope scope+ . local inThread . allocInPostOpLambda num_threads (segSpace op) } f = case segLevel op of
src/Futhark/Pass/LiftAllocations.hs view
@@ -108,8 +108,8 @@ Op Alloc {} -> liftStm stm' _ -> do let pat_names = namesFromList $ patNames $ stmPat stm'- free_in_stm = freeIn stm- expand v = maybe [v] namesToList $ M.lookup v $ fst aliases+ free_in_stm = freeIn stm'+ expand v = v : maybe [] namesToList (M.lookup v $ fst aliases) if (pat_names `namesIntersect` to_lift) || any (`nameIn` free_in_stm) (foldMap expand $ namesToList consumed) then liftStm stm'
src/Futhark/Passes.hs view
@@ -34,6 +34,7 @@ import Futhark.Optimise.TileLoops import Futhark.Optimise.Unstream import Futhark.Pass.AD+import Futhark.Pass.AddGlobalParams import Futhark.Pass.ExpandAllocations import Futhark.Pass.ExplicitAllocations.GPU qualified as GPU import Futhark.Pass.ExplicitAllocations.MC qualified as MC@@ -87,6 +88,7 @@ >>> onePass extractKernels >>> passes [ simplifyGPU,+ addGlobalParams, optimiseGenRed, simplifyGPU, tileLoops,
src/Futhark/Script.hs view
@@ -3,7 +3,7 @@ -- literate@ command is the main user. module Futhark.Script ( -- * Server- ScriptServer,+ ScriptServer (scriptServer), withScriptServer, withScriptServer', @@ -21,6 +21,8 @@ ExpValue, valToExpValue, storeExpValue,+ isScriptTuple,+ project, -- * Evaluation EvalBuiltin,@@ -267,9 +269,9 @@ -- FutharkScript, but we sort of have closures. data ScriptValue v = SValue TypeName v- | -- | Ins, then outs. Yes, this is the opposite of more or less+ | -- | Ins, then out. Yes, this is the opposite of more or less -- everywhere else.- SFun EntryName [TypeName] [TypeName] [ScriptValue v]+ SFun EntryName [TypeName] TypeName [ScriptValue v] deriving (Show) instance Functor ScriptValue where@@ -286,18 +288,14 @@ -- | The type of a 'ScriptValue' - either a value type or a function type. data ScriptValueType = STValue TypeName- | -- | Ins, then outs.- STFun [TypeName] [TypeName]+ | -- | Ins, then out.+ STFun [TypeName] TypeName deriving (Eq, Show) instance Pretty ScriptValueType where pretty (STValue t) = pretty t- pretty (STFun ins outs) =- hsep $ intersperse "->" (map pretty ins ++ [outs'])- where- outs' = case outs of- [out] -> pretty out- _ -> parens $ commasep $ map pretty outs+ pretty (STFun ins out) =+ hsep $ intersperse "->" (map pretty ins ++ [pretty out]) -- | A Haskell-level value or a variable on the server. data ValOrVar = VVal V.Value | VVar VarName@@ -315,7 +313,7 @@ -- | The type of a 'ScriptValue'. scriptValueType :: ScriptValue v -> ScriptValueType scriptValueType (SValue t _) = STValue t-scriptValueType (SFun _ ins outs _) = STFun ins outs+scriptValueType (SFun _ ins out _) = STFun ins out -- | The set of server-side variables in the value. serverVarsInValue :: ExpValue -> S.Set VarName@@ -508,7 +506,7 @@ getField :: (MonadIO m, MonadError T.Text m) => ScriptServer ->- T.Text ->+ VarName -> Field -> m VarName getField server from (Field f _) = do@@ -516,18 +514,33 @@ cmdMaybe $ cmdProject (scriptServer server) to from f pure to +-- | Is this a server-side tuple? If so, return the element types.+isScriptTuple :: ScriptServer -> TypeName -> Maybe [TypeName]+isScriptTuple server t =+ isTuple t $ scriptTypes server++-- | If a tuple, produce a monadic action that can retrieve its elements.+tupleElements ::+ (MonadIO m, MonadError T.Text m) =>+ ScriptServer -> ExpValue -> Maybe (m [ExpValue])+tupleElements _ (V.ValueTuple vs) = pure $ pure vs+tupleElements server (V.ValueAtom (SValue t (VVar v)))+ | Just ts <- isTuple t $ scriptTypes server =+ Just $ forM (zip tupleFieldNames ts) $ \(k, kt) ->+ V.ValueAtom . SValue kt . VVar <$> getField server v (Field (nameToText k) kt)+tupleElements _ _ = Nothing++-- | If a tuple value, convert it to its components. unTuple :: (MonadIO m, MonadError T.Text m) => ScriptServer -> ExpValue -> m [ExpValue]-unTuple _ (V.ValueTuple vs) = pure vs-unTuple server (V.ValueAtom (SValue t (VVar v)))- | Just ts <- isTuple t $ scriptTypes server =- forM (zip tupleFieldNames ts) $ \(k, kt) ->- V.ValueAtom . SValue kt . VVar <$> getField server v (Field (nameToText k) kt)+unTuple server v+ | Just m <- tupleElements server v = m unTuple _ v = pure [v] +-- | Extract field from record. project :: (MonadIO m, MonadError T.Text m) => ScriptServer ->@@ -675,7 +688,7 @@ pure e | otherwise = do in_types <- fmap (map inputType) $ cmdEither $ cmdInputs server name- out_types <- fmap (map outputType) $ cmdEither $ cmdOutputs server name+ out_type <- fmap outputType $ cmdEither $ cmdOutput server name es' <- mapM (evalExp' vtable) es @@ -685,12 +698,11 @@ if length in_types == length arg_types then do- outs <- replicateM (length out_types) $ newVar' "out"- void $ cmdEither $ cmdCall server name outs arg_types- pure . V.mkCompound . map V.ValueAtom $- zipWith SValue out_types (map VVar outs)+ out <- newVar' "out"+ void $ cmdEither $ cmdCall server name out arg_types+ pure . V.ValueAtom $ SValue out_type $ VVar out else- pure . V.ValueAtom . SFun name in_types out_types $+ pure . V.ValueAtom . SFun name in_types out_type $ zipWith SValue in_types (map VVar arg_types) -- Careful to not require saturated application, but do still
src/Futhark/Test.hs view
@@ -36,6 +36,7 @@ import Data.ByteString qualified as SBS import Data.ByteString.Lazy qualified as BS import Data.Char+import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S import Data.Text qualified as T@@ -48,6 +49,8 @@ import Futhark.Test.Values qualified as V import Futhark.Util (ensureCacheDirectory, isEnvVarAtLeast, pmapIO, showText) import Futhark.Util.Pretty (prettyText, prettyTextOneLine)+import Language.Futhark.Core (nameFromText, nameToText)+import Language.Futhark.Tuple (areTupleFields, tupleFieldNames) import System.Directory import System.Exit import System.FilePath@@ -129,7 +132,7 @@ -- Frees the expression on error. scriptValueAsVars :: (MonadError T.Text m, MonadIO m) =>- Server ->+ Script.ScriptServer -> [(VarName, TypeName)] -> Script.ExpValue -> m ()@@ -143,17 +146,24 @@ | t0 == t1 = Just $ case sval of Script.VVar oldname ->- cmdMaybe $ cmdRename server oldname v+ cmdMaybe $ cmdRename (Script.scriptServer server) oldname v Script.VVal sval' ->- valueAsVar server v sval'+ valueAsVar (Script.scriptServer server) v sval' f _ _ = Nothing+scriptValueAsVars server names_and_types val+ | V.ValueAtom (Script.SValue t (Script.VVar vv)) <- val,+ Just ts <- Script.isScriptTuple server t,+ ts == map snd names_and_types = do+ forM_ (zip (map fst names_and_types) tupleFieldNames) $ \(v, k) ->+ cmdMaybe $ cmdProject (Script.scriptServer server) v vv (nameToText k)+ cmdMaybe $ cmdFree (Script.scriptServer server) $ S.toList $ Script.serverVarsInValue val scriptValueAsVars server names_and_types val = do- cmdMaybe $ cmdFree server $ S.toList $ Script.serverVarsInValue val+ cmdMaybe $ cmdFree (Script.scriptServer server) $ S.toList $ Script.serverVarsInValue val throwError $ "Expected value of type: "- <> prettyTextOneLine (V.mkCompound (map (V.ValueAtom . snd) names_and_types))+ <> showText names_and_types -- prettyTextOneLine (V.mkCompound (map (V.ValueAtom . snd) names_and_types)) <> "\nBut got value of type: "- <> prettyTextOneLine (fmap Script.scriptValueType val)+ <> showText val -- prettyTextOneLine (fmap Script.scriptValueType val) <> notes where notes = mconcat $ mapMaybe note names_and_types@@ -225,7 +235,7 @@ valuesAsVars server names_and_types _ dir (ScriptValues e) = Script.withScriptServer' server $ \server' -> do e_v <- Script.evalExp (Script.scriptBuiltin dir) server' e- scriptValueAsVars server names_and_types e_v+ scriptValueAsVars server' names_and_types e_v valuesAsVars server names_and_types futhark dir (ScriptFile f) = do e <- either throwError pure . Script.parseExpFromText f@@ -369,16 +379,58 @@ options = [program, "-o", binOutputf] ++ extra_options progNotFound s = s <> ": command not found" --- | Read the given variables from a running server.+getValueM :: (MonadIO m, MonadError T.Text m) => Server -> VarName -> m V.Value+getValueM server = either throwError pure <=< liftIO . getValue server++-- Retrieve components of tuple.+getTupleElems ::+ (MonadIO m, MonadError T.Text m) =>+ Server ->+ VarName ->+ Int ->+ m [V.Value]+getTupleElems server v k = do+ -- We construct intermediate variables for the elements that we free at the+ -- end. However, they are leaked if we have a failure along the way, and+ -- getValueM may fail. This is not a big problem in practice we hope, as a+ -- failing test results in the server being shut down soon after.+ let is = [0 .. k - 1]+ elem_vs = [v <> "_elem" <> showText i | i <- is]+ forM_ (zip is elem_vs) $ \(i, elem_v) ->+ cmdMaybe $ cmdProject server elem_v v (showText i)+ mapM (getValueM server) elem_vs <* cmdMaybe (cmdFree server elem_vs)++isServerTuple ::+ (MonadIO m) =>+ Server ->+ TypeName ->+ m (Maybe [TypeName])+isServerTuple server v_t = do+ x <- liftIO $ cmdFields server v_t+ case x of+ Right fields -> do+ let onField f = (nameFromText $ fieldName f, fieldType f)+ case areTupleFields $ M.fromList $ map onField fields of+ Just ts -> pure $ Just ts+ Nothing -> pure Nothing+ Left _ -> pure Nothing++-- | Read the given variable from a running server. As a special case, if the+-- result is a tuple, we unpack it and return the elements individually. readResults :: (MonadIO m, MonadError T.Text m) => Server ->- [VarName] ->+ (VarName, TypeName) -> m [V.Value]-readResults server =- mapM (either throwError pure <=< liftIO . getValue server)+readResults server (v, v_t) = do+ maybe_elems <- isServerTuple server v_t+ case maybe_elems of+ Just ts ->+ getTupleElems server v $ length ts+ Nothing ->+ pure <$> getValueM server v --- | Call an entry point. Returns server variables storing the result.+-- | Call an entry point. Returns server variable storing the result. callEntry :: (MonadIO m, MonadError T.Text m) => FutharkExe ->@@ -386,17 +438,16 @@ FilePath -> EntryName -> Values ->- m [VarName]+ m VarName callEntry futhark server prog entry input = do- output_types <- cmdEither $ cmdOutputs server entry input_types <- cmdEither $ cmdInputs server entry- let outs = ["out" <> showText i | i <- [0 .. length output_types - 1]]+ let out = "out" ins = ["in" <> showText i | i <- [0 .. length input_types - 1]] ins_and_types = zip ins (map inputType input_types) valuesAsVars server ins_and_types futhark dir input- _ <- cmdEither $ cmdCall server entry outs ins+ _ <- cmdEither $ cmdCall server entry out ins cmdMaybe $ cmdFree server ins- pure outs+ pure out where dir = takeDirectory prog @@ -419,11 +470,11 @@ res <- liftIO . flip (pmapIO concurrency) missing $ \(entry, tr) -> withServer server_cfg $ \server -> runExceptT $ do- outs <- callEntry futhark server prog entry $ runInput tr+ out <- callEntry futhark server prog entry $ runInput tr let f = file entry tr liftIO $ ensureCacheDirectory $ takeDirectory f- cmdMaybe $ cmdStore server f outs- cmdMaybe $ cmdFree server outs+ cmdMaybe $ cmdStore server f [out]+ cmdMaybe $ cmdFree server [out] either throwError (const (pure ())) (sequence_ res) where server_cfg = futharkServerCfg ("." </> dropExtension prog) []
src/Language/Futhark/Interpreter/AD.hs view
@@ -350,11 +350,11 @@ deriveTape' :: Tape -> ADValue -> ADMonad (M.Map Counter ADValue) deriveTape' (TapeID i _) s = pure $ M.singleton i s deriveTape' (TapeConst _) _ = pure M.empty-deriveTape' tp@(TapeOp op p uid _) s =+deriveTape' tp@(TapeOp _ p uid _) s = fst <$> derive tp s M.empty (countReferences p $ M.singleton (-uid - 1) 1) where- add x y = doOp' (OpBin $ addFor $ opReturnType op) [x, y]- mul x y = doOp' (OpBin $ mulFor $ opReturnType op) [x, y]+ add x y = doOp' (OpBin $ addFor $ primValueType $ primitive x) [x, y]+ mul x y = doOp' (OpBin $ mulFor $ primValueType $ primitive x) [x, y] madd :: Counter -> ADValue -> M.Map Counter ADValue -> ADMonad (M.Map Counter ADValue) madd i a m = case M.lookup i m of Just b -> add a b <&> (\x -> M.insert i x m)@@ -389,7 +389,10 @@ _ -> calculatePDs op' (map tapePrimal p') >>= mapM (mul s'') -- Propagate the new sensitivities- foldlM (\(ss'', rs'') (p'', s'''') -> derive p'' s'''' ss'' rs'') (ss', rs') $ zip p' s'''+ foldlM+ (\(ss'', rs'') (p'', s'''') -> derive p'' s'''' ss'' rs'')+ (ss', rs')+ $ zip p' s''' else error "TODO: This branch is unreachable unless `countReferences` undercounts" countReferences :: [Tape] -> M.Map Counter Int -> M.Map Counter Int countReferences p' d' = foldl f d' p'
src/Language/Futhark/Pretty.hs view
@@ -399,8 +399,8 @@ prettyExp p (Constr n cs t _) = parensIf (p >= 10) $ "#" <> pretty n <+> sep (map (prettyExp 10) cs) <> prettyInst t-prettyExp _ (Attr attr e _) =- prettyAttr attr </> prettyExp (-1) e+prettyExp p (Attr attr e _) =+ parensIf (p >= 10) $ align $ prettyAttr attr </> prettyExp (-1) e prettyExp i (AppExp e res) | isEnvVarAtLeast "FUTHARK_COMPILER_DEBUGGING" 2, Just (AppRes t ext) <- unAnnot res,