diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -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 diff --git a/docs/js-api.rst b/docs/js-api.rst --- a/docs/js-api.rst +++ b/docs/js-api.rst @@ -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.(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. diff --git a/docs/server-protocol.rst b/docs/server-protocol.rst --- a/docs/server-protocol.rst +++ b/docs/server-protocol.rst @@ -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`` diff --git a/docs/usage.rst b/docs/usage.rst --- a/docs/usage.rst +++ b/docs/usage.rst @@ -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). diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -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 diff --git a/rts/c/scheduler.h b/rts/c/scheduler.h --- a/rts/c/scheduler.h +++ b/rts/c/scheduler.h @@ -90,6 +90,7 @@ #include #if defined(_WIN32) +#define NOGDI #include #elif defined(__APPLE__) #include diff --git a/rts/c/server.h b/rts/c/server.h --- a/rts/c/server.h +++ b/rts/c/server.h @@ -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) { diff --git a/rts/c/timing.h b/rts/c/timing.h --- a/rts/c/timing.h +++ b/rts/c/timing.h @@ -5,6 +5,7 @@ #ifdef _WIN32 +#define NOGDI #include static int64_t get_wall_time(void) { diff --git a/rts/javascript/server.js b/rts/javascript/server.js --- a/rts/javascript/server.js +++ b/rts/javascript/server.js @@ -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; } } } diff --git a/rts/python/memory.py b/rts/python/memory.py --- a/rts/python/memory.py +++ b/rts/python/memory.py @@ -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 "".format(self.desc) diff --git a/rts/python/server.py b/rts/python/server.py --- a/rts/python/server.py +++ b/rts/python/server.py @@ -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: diff --git a/src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs b/src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs --- a/src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs +++ b/src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs @@ -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)\ diff --git a/src/Futhark/AD/Rev.hs b/src/Futhark/AD/Rev.hs --- a/src/Futhark/AD/Rev.hs +++ b/src/Futhark/AD/Rev.hs @@ -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 {} -> diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -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, diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs --- a/src/Futhark/CLI/Dev.hs +++ b/src/Futhark/CLI/Dev.hs @@ -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 [], diff --git a/src/Futhark/CLI/Literate.hs b/src/Futhark/CLI/Literate.hs --- a/src/Futhark/CLI/Literate.hs +++ b/src/Futhark/CLI/Literate.hs @@ -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 diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs --- a/src/Futhark/CLI/Test.hs +++ b/src/Futhark/CLI/Test.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs --- a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs @@ -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) diff --git a/src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs b/src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs --- a/src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs @@ -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)) } diff --git a/src/Futhark/CodeGen/Backends/GenericC/Server.hs b/src/Futhark/CodeGen/Backends/GenericC/Server.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Server.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Server.hs @@ -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];|], diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs --- a/src/Futhark/CodeGen/Backends/GenericPython.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython.hs @@ -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 $ "# 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 $ "# 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) diff --git a/src/Futhark/CodeGen/Backends/GenericWASM.hs b/src/Futhark/CodeGen/Backends/GenericWASM.hs --- a/src/Futhark/CodeGen/Backends/GenericWASM.hs +++ b/src/Futhark/CodeGen/Backends/GenericWASM.hs @@ -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 = diff --git a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs --- a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/SequentialWASM.hs b/src/Futhark/CodeGen/Backends/SequentialWASM.hs --- a/src/Futhark/CodeGen/Backends/SequentialWASM.hs +++ b/src/Futhark/CodeGen/Backends/SequentialWASM.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/SimpleRep.hs b/src/Futhark/CodeGen/Backends/SimpleRep.hs --- a/src/Futhark/CodeGen/Backends/SimpleRep.hs +++ b/src/Futhark/CodeGen/Backends/SimpleRep.hs @@ -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) _ diff --git a/src/Futhark/CodeGen/ImpCode.hs b/src/Futhark/CodeGen/ImpCode.hs --- a/src/Futhark/CodeGen/ImpCode.hs +++ b/src/Futhark/CodeGen/ImpCode.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Block.hs b/src/Futhark/CodeGen/ImpGen/GPU/Block.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/Block.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/Block.hs @@ -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" $ diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -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 :: diff --git a/src/Futhark/IR/Parse.hs b/src/Futhark/IR/Parse.hs --- a/src/Futhark/IR/Parse.hs +++ b/src/Futhark/IR/Parse.hs @@ -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 = diff --git a/src/Futhark/IR/Pretty.hs b/src/Futhark/IR/Pretty.hs --- a/src/Futhark/IR/Pretty.hs +++ b/src/Futhark/IR/Pretty.hs @@ -422,7 +422,7 @@ <> comma ppTupleLines' (map pretty p_entry) <> comma - ppTupleLines' (map pretty ret_entry) + pretty ret_entry ) instance Pretty OpaqueType where diff --git a/src/Futhark/IR/Prop.hs b/src/Futhark/IR/Prop.hs --- a/src/Futhark/IR/Prop.hs +++ b/src/Futhark/IR/Prop.hs @@ -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 diff --git a/src/Futhark/IR/SOACS/SOAC.hs b/src/Futhark/IR/SOACS/SOAC.hs --- a/src/Futhark/IR/SOACS/SOAC.hs +++ b/src/Futhark/IR/SOACS/SOAC.hs @@ -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 diff --git a/src/Futhark/IR/Syntax.hs b/src/Futhark/IR/Syntax.hs --- a/src/Futhark/IR/Syntax.hs +++ b/src/Futhark/IR/Syntax.hs @@ -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 diff --git a/src/Futhark/Internalise/Entry.hs b/src/Futhark/Internalise/Entry.hs --- a/src/Futhark/Internalise/Entry.hs +++ b/src/Futhark/Internalise/Entry.hs @@ -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) = diff --git a/src/Futhark/Internalise/FullNormalise.hs b/src/Futhark/Internalise/FullNormalise.hs --- a/src/Futhark/Internalise/FullNormalise.hs +++ b/src/Futhark/Internalise/FullNormalise.hs @@ -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 diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs b/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs @@ -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 diff --git a/src/Futhark/Optimise/Fusion/RulesWithAccs.hs b/src/Futhark/Optimise/Fusion/RulesWithAccs.hs --- a/src/Futhark/Optimise/Fusion/RulesWithAccs.hs +++ b/src/Futhark/Optimise/Fusion/RulesWithAccs.hs @@ -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 diff --git a/src/Futhark/Pass/AddGlobalParams.hs b/src/Futhark/Pass/AddGlobalParams.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Pass/AddGlobalParams.hs @@ -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 + } diff --git a/src/Futhark/Pass/ExplicitAllocations/GPU.hs b/src/Futhark/Pass/ExplicitAllocations/GPU.hs --- a/src/Futhark/Pass/ExplicitAllocations/GPU.hs +++ b/src/Futhark/Pass/ExplicitAllocations/GPU.hs @@ -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 diff --git a/src/Futhark/Pass/LiftAllocations.hs b/src/Futhark/Pass/LiftAllocations.hs --- a/src/Futhark/Pass/LiftAllocations.hs +++ b/src/Futhark/Pass/LiftAllocations.hs @@ -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' diff --git a/src/Futhark/Passes.hs b/src/Futhark/Passes.hs --- a/src/Futhark/Passes.hs +++ b/src/Futhark/Passes.hs @@ -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, diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs --- a/src/Futhark/Script.hs +++ b/src/Futhark/Script.hs @@ -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 diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -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) [] diff --git a/src/Language/Futhark/Interpreter/AD.hs b/src/Language/Futhark/Interpreter/AD.hs --- a/src/Language/Futhark/Interpreter/AD.hs +++ b/src/Language/Futhark/Interpreter/AD.hs @@ -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' diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -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,