packages feed

futhark 0.25.35 → 0.25.36

raw patch · 78 files changed

+2878/−918 lines, 78 filesdep ~futhark-datadep ~futhark-manifestdep ~futhark-server

Dependency ranges changed: futhark-data, futhark-manifest, futhark-server, lsp, lsp-types

Files

CHANGELOG.md view
@@ -5,6 +5,48 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [0.25.36]++### Added++* `futhark lsp` supports running evaluation comments in the interpreter,+    implemented by VegOwOtenks.++* New notation: `let x.f = y in z` as a shortcut for `let x = x with f = y in+  z`, by Aziz Rmadi. (#1160)++* Array and field updates can now be chained, e.g., `x with [i].f = y`,+  including in operator sections. Work by Aziz Rmadi.++* New server protocol commands: `index`, `shape`, and `attributes`.++* FutharkScript now supports (barely) array indexing.++* `futhark autotune` now shows a progress bar when running in a terminal. Work+  by Nader Rahhal.++* The C API now has functions for creating and updating arrays of opaque+  objects. (#2383, #2384)++### Fixed++* GPU code generation for atomics on 8-bit scalars.++* `f64.nextafter`, `f64.copysign`, and `f64.isinf` reduced precision. (#2363)++* Equality for `f16` in interpreter did not handle NaN correctly.++* `f16` handling in `multicore` and `ispc` backends.++* Opaque types in C API generated from record patterns in entry points. (#2371)++* Regression in the unrolling of `map`.++* Occasional duplication of entry points leading to compiler crash. (#2374)++* `futhark autotune` no longer tells you to report an issue when the underlying+  program crashes. (#2388)+ ## [0.25.35]  ### Added
docs/c-api.rst view
@@ -501,20 +501,42 @@ :ref:`array-values`.  For an opaque array type ``[]t``, the following functions are always-generated (assuming the generated C type is ``arr_t``):+generated (assuming the generated C type is ``arr1d_t``): -.. c:function:: int futhark_index_opaque_arr_t(struct futhark_context *ctx, struct futhark_opaque_t **out, struct futhark_opaque_arr_t *arr, int64_t i0);+.. c:function:: int futhark_index_opaque_arr1d_t(struct futhark_context *ctx, struct futhark_opaque_t **out, struct futhark_opaque_arr1d_t *arr, int64_t i0);     Asynchronously copy a single element from the array and store it in    ``*out``. Returns a nonzero value if the index is out of bounds. -.. c:function:: const int64_t *futhark_shape_opaque_arr_t(struct futhark_context *ctx, struct futhark_opaque_arr_t *arr);+.. c:function:: int futhark_set_opaque_arr1d_t(struct futhark_context *ctx, struct futhark_opaque_arr1d_t *arr, struct futhark_opaque_t *elem, int64_t i0); +   Copy the provided element into the given index in the array. Returns a+   nonzero value if the index is out of bounds.++.. c:function:: const int64_t *futhark_shape_opaque_arr1d_t(struct futhark_context *ctx, struct futhark_opaque_arr1d_t *arr);+    Return a pointer to the shape of the array, with one element per    dimension. The lifetime of the shape is the same as ``arr``, and    must *not* be manually freed. Assuming ``arr`` is a valid object,    this function cannot fail. +.. c:function:: int futhark_new_opaque_arr1d_t(struct futhark_context *ctx, struct futhark_opaque_arr1d_t **out, struct futhark_opaque_t **elems, int64_t dim0);++   Construct a new opaque array comprising the elements passed in the C array+   ``elems``, whose length must be at least the product of the shape. The+   ``elems`` array is interpreted in row-major order to assemble+   multidimensional arrays. The elements must have the same shape. Returns a+   nonzero value if the elements are invalid or something else goes wrong.++   **Note:** This is an expensive operation as the elements are copied+   sequentially to the new array. You should not use this to frequently+   construct large arrays.++   **Note:** You can use this function to construct empty arrays, but in that+   case the inner dimensions of the element types will be considered zero, which+   may violate type invariants, making it impossible to pass these arrays to+   entry points.+ Additionally, if the element type is a record (or equivalently a tuple), for example if the array type is ``[](f32,f32)``, the following functions are also available:@@ -790,6 +812,12 @@     of this entry point.  These are not necessarily unique to the     entry point. +  * A list of all *attributes* attached to the entry point. These are the string+    representation of the attributes and may require further parsing. Does not+    include attribute brackets used in the Futhark syntax, meaning that an+    attribute ``#[foo]`` becomes simply an entry ``"foo"`` in this list. The+    attributes appear in no particular order.+ * A mapping from the name of each non-scalar type to:    * The C type used to represent this type (which is in practice@@ -831,7 +859,7 @@       * The element type and rank. -     * The operations ``index`` and ``shape``.+     * The operations ``index``, ``shape``, ``set``, and ``new``.   Manifests are defined by the following JSON Schema:
docs/conf.py view
@@ -526,6 +526,13 @@         [],         1,     ),+    (+        "man/futhark-lsp",+        "futhark-lsp",+        "language server for Futhark",+        [],+        1,+    ),     ("man/futhark-pkg", "futhark-pkg", "manage Futhark packages", [], 1),     (         "man/futhark-literate",
docs/index.rst view
@@ -55,6 +55,7 @@    man/futhark-hip.rst    man/futhark-ispc.rst    man/futhark-literate.rst+   man/futhark-lsp.rst    man/futhark-script.rst    man/futhark-multicore.rst    man/futhark-opencl.rst
docs/language-reference.rst view
@@ -482,7 +482,7 @@        : | "(" `exp` `qualsymbol` ")"        : | "(" `qualsymbol` `exp` ")"        : | "(" ( "." `field` )+ ")"-       : | "(" "." `slice` ")"+       : | "(" "." (`slice` | `fieldid`) (`slice` | "." `fieldid`) *  ")"        : | "???"    exp:   `atom`       : | `exp` `qualsymbol` `exp`@@ -497,15 +497,13 @@       : | `exp` [ ".." `exp` ] "..>" `exp`       : | "if" `exp` "then" `exp` "else" `exp`       : | "let" `size`* `pat` "=" `exp` "in" `exp`-      : | "let" `name` `slice` "=" `exp` "in" `exp`+      : | "let" `name` (`slice` | "." `fieldid`)+ "=" `exp` "in" `exp`       : | "let" `name` `type_param`* `pat`+ [":" `type`] "=" `exp` "in" `exp`       : | "(" "\" `pat`+ [":" `type`] "->" `exp` ")"       : | "loop" `pat` ["=" `exp`] `loopform` "do" `exp`       : | "#[" `attr` "]" `exp`-      : | "unsafe" `exp`       : | "assert" `atom` `exp`-      : | `exp` "with" `slice` "=" `exp`-      : | `exp` "with" `fieldid` ("." `fieldid`)* "=" `exp`+      : | `exp` "with" (`slice` | `fieldid`) (`slice` | "." `fieldid`)*  "=" `exp`       : | "match" `exp` ("case" `pat` "->" `exp`)+    slice: "[" `index` ("," `index`)* [","] "]"    field:   `fieldid` "=" `exp`@@ -996,6 +994,13 @@ not be complete and can also be a slice, but in these cases, the value of ``v`` must be an array of the proper size.  This notation is Syntactic sugar for ``let a = a with [i] = v in a``.++``let r.f = v in body``+.......................++Write ``v`` to the field ``f`` of record ``r`` and evaluate ``body``.+Nested field updates are written ``let r.f.g = v in body``.+This notation is syntactic sugar for ``let r = r with f = v in body``.  ``let f params... = e in body`` ...............................
docs/man/futhark-literate.rst view
@@ -244,6 +244,7 @@    script_exp:   `script_fun` `script_exp`*              : | "let" `script_pat` "=" `script_exp` "in" `script_exp`              : | `script_atom` ( "." `fieldid` )*+             : | `id` "[" `script_exp` ( "," `script_exp`)* "]"    script_atom: `script_fun`               : | "(" `script_exp` ")"               : | "(" `script_exp` ( "," `script_exp` )+ ")"
+ docs/man/futhark-lsp.rst view
@@ -0,0 +1,53 @@+.. role:: ref(emphasis)++.. _futhark-lsp(1):++===========+futhark-lsp+===========++SYNOPSIS+========++futhark lsp++DESCRIPTION+===========++Start serving the language server protocol over stdin and stdout.+This is only the server part of the protocol, you likely want to use it via+your editor.+This will enable your editor to provide e.g. hints or hover information by+querying the futhark compiler.++FEATURES+========++Hover Information++  Provides the type of the symbol under the cursor.+  Does not work on the definition of a top-level symbol itself, only references+  to it.++Go To Definition++  Jumps to the place of definition of the symbol under the cursor.++Formatting++  Invokes ``futhark fmt`` to format the current file.++Evaluation Comments++  Comments like ``-- >>> factorial 5`` will be picked up, the editor may offer+  code lenses to evaluate the code contained in the comment.+  Activating the code lens will load the file into the interpreter,+  evaluate the expression and write the result below.++  The evaluation will be aborted after 15 seconds or when it has allocated +  100 GB in total, only the last 100 debugging traces will be retained.++SEE ALSO+========++:ref:`futhark-fmt(1)`
docs/performance.rst view
@@ -191,7 +191,7 @@ ~~~~~~~~~  A sum type value is represented as a tuple containing all the payload-components in order, prefixed with an `i8` tag to identify the+components in order, prefixed with an ``i8`` tag to identify the constructor.  For example,  .. code-block:: futhark
docs/server-protocol.rst view
@@ -3,68 +3,63 @@ Server Protocol =============== -A Futhark program can be compiled to a *server executable*.  Such a-server maintains a Futhark context and presents a line-oriented-interface (over stdin/stdout) for loading and dumping values, as well-as calling the entry points in the program.  The main advantage over-the plain executable interface is that program initialisation is done-only *once*, and we can work with opaque values.+A Futhark program can be compiled to a *server executable*.  Such a server+maintains a Futhark context and presents a line-oriented interface (over+stdin/stdout) for loading and dumping values, as well as calling the entry+points in the program.  The main advantage over the plain executable interface+is that program initialisation is done only *once*, and we can work with opaque+values. -The server interface is not intended for human consumption, but is-useful for writing tools on top of Futhark programs, without having to-use the C API.  Futhark's built-in benchmarking and testing tools use-server executables.+The server interface is not intended for human consumption, but is useful for+writing tools on top of Futhark programs, without having to use the C API.+Futhark's built-in benchmarking and testing tools use server executables. -A server executable is started like any other executable, and supports-most of the same command line options (:ref:`executable-options`).+A server executable is started like any other executable, and supports most of+the same command line options (:ref:`executable-options`).  Basics ------ -Each command is sent as a *single line* on standard input.  A command-consists of space-separated *words*.  A word is either a sequence of-non-space characters (``foo``), *or* double quotes surrounding a-sequence of non-newline and non-quote characters (``"foo bar"``).+Each command is sent as a *single line* on standard input.  A command consists+of space-separated *words*.  A word is either a sequence of non-space characters+(``foo``), *or* double quotes surrounding a sequence of non-newline and+non-quote characters (``"foo bar"``). -The response is sent on standard output. The server will print ``%%%-OK`` on a line by itself to indicate that a command has finished.  It-will also print ``%%% OK`` at startup once initialisation has-finished.  If initialisation fails, the process will terminate.  If a-command fails, the server will print ``%%% FAILURE`` followed by the-error message, and then ``%%% OK`` when it is ready for more input.-Some output may also precede ``%%% FAILURE``, e.g. logging statements-that occured before failure was detected.  Fatal errors that lead to+The response is sent on standard output. The server will print ``%%% OK`` on a+line by itself to indicate that a command has finished.  It will also print+``%%% OK`` at startup once initialisation has finished.  If initialisation+fails, the process will terminate.  If a command fails, the server will print+``%%% FAILURE`` followed by the error message, and then ``%%% OK`` when it is+ready for more input. Some output may also precede ``%%% FAILURE``, e.g. logging+statements that occured before failure was detected.  Fatal errors that lead to server shutdown may be printed to stderr.  Variables --------- -Some commands produce or read variables.  A variable is a mapping from-a name to a Futhark value.  Values can be both transparent (arrays and-primitives), but they can also be *opaque* values.  These can be-produced by entry points and passed to other entry points, but cannot-be directly inspected.+Some commands produce or read variables.  A variable is a mapping from a name to+a Futhark value.  Values can be both transparent (arrays and primitives), but+they can also be *opaque* values.  These can be produced by entry points and+passed to other entry points, but cannot be directly inspected.  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 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).+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+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).  Consumption and aliasing ------------------------ -Since the server protocol closely models the C API, the same rules-apply to entry points that consume their arguments (see-:ref:`api-consumption`).  In particular, consumed variables must still-be freed with the ``free`` command - but this is the only operation-that may be used on consumed variables.+Since the server protocol closely models the C API, the same rules apply to+entry points that consume their arguments (see :ref:`api-consumption`).  In+particular, consumed variables must still be freed with the ``free`` command -+but this is the only operation that may be used on consumed variables.  Commands --------@@ -87,14 +82,14 @@ ``call`` *entry* *o1* ... *oN* *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.+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.  ``restore`` *file* *v1* *t1* ... *vN* *tN* .......................................... -Load *N* values from *file* and store them in the variables *v1* to-*vN* of types *t1* to *tN*, which must not already exist.+Load *N* values from *file* and store them in the variables *v1* to *vN* of+types *t1* to *tN*, which must not already exist.  ``store`` *file* *v1* ... *vN* ..............................@@ -109,28 +104,43 @@ ``rename`` *oldname* *newname* .............................. -Rename the variable *oldname* to *newname*, which must not already-exist.+Rename the variable *oldname* to *newname*, which must not already exist.  ``inputs`` *entry* .................. -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 `*`.+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* ................... -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 type is prefixed by `*`.+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+type is prefixed by `*`.  ``clear`` ......... -Clear all internal caches and counters maintained by the Futhark-context.  Corresponds to :c:func:`futhark_context_clear_caches`.+Clear all internal caches and counters maintained by the Futhark context.+Corresponds to :c:func:`futhark_context_clear_caches`. +``kind`` *type*+...............++Print the kind of type *type*. Always one of:++- ``primitive``+- ``array``+- ``record``+- ``sum``+- ``opaque``++``type`` *v*+............++Print type name of variable *v*.+ ``pause_profiling`` ................... @@ -154,42 +164,100 @@ ``tuning_params`` *entry* ......................... -For each tuning parameters relevant to the given entry point, print-its name, then a space, then its class.+For each tuning parameters relevant to the given entry point, print its name,+then a space, then its class. -This is similar to on :c:func:`futhark_tuning_params_for_sum`, but-note that this command prints *names* and not *integers*.+This is similar to on :c:func:`futhark_tuning_params_for_sum`, but note that+this command prints *names* and not *integers*.  ``tuning_param_class`` *param* ..............................  Corresponds to :c:func:`futhark_get_tuning_param_class`. +``attributes`` *entry*+......................++Print the attributes of the provided entry point in no particular order. Does+not include the attribute brackets used in the Futhark syntax, meaning that an+attribute written as ``#[foo]`` becomes simply ``"foo"`` in the output of this+command.++Array Commands+~~~~~~~~~~~~~~++``elemtype`` *v*+....................++Print the typename of the elements of array-typed variable *v*.++``shape`` *v*+....................++Print the shape of array-typed variable *v* as space-separated integers.++``index`` *v0* *v1* *i0* ... *iN-1*+...................................++Create a new variable *v0* whose value is the result of indexing the variable+*v1*, which must be an array of rank *N*, at position *[i0]...[iN-1]*, where+each *i* is an integer. Fails if the index is out of bounds.+ Record Commands ~~~~~~~~~~~~~~~  ``fields`` *type* ................. -If the given type is a record, print a line for each field of the-record.  The line will contain the name of the field, followed by a-space, followed by the type of the field.  Note that the type name can-contain spaces.  The order of fields is significant, as it is the one-expected by the ``new_record`` command.+If the given type is a record, print a line for each field of the record.  The+line will contain the name of the field, followed by a space, followed by the+type of the field.  Note that the type name can contain spaces.  The order of+fields is significant, as it is the one expected by the ``new_record`` command.  ``new`` *v0* *type* *v1* ... *vN* ................................. -Create a new variable *v0* of type *type*, which must be a record type-with *N* fields, where *v1* to *vN* are variables with the-corresponding field types (the expected order is given by the-``fields`` command).+Create a new variable *v0* of type *type*, which must be a record type with *N*+fields, where *v1* to *vN* are variables with the corresponding field types (the+expected order is given by the ``fields`` command).  ``project`` *to* *from* *field* ............................... -Create a new variable *to* whose value is the field *field* of the-record-typed variable *from*.+Create a new variable *to* whose value is the field *field* of record-typed+variable *from*.++Sum Commands+~~~~~~~~~~~~++``variants`` *type*+...................++Print the names of each variant of *type*, which must be a sum type. Each+variant is followed by a line for each payload value, giving its type. The lines+of payload types are prefixed with a dash and a space (``- ``). The order of+payload types is significant, as it is the one expected by the ``construct`` and+``destruct`` commands.++``construct`` *v0* *type* *variant* *v1* ... *vN*+.................................................++Create a new variable *v0* of type *type*, which must be a sum type including a+variant named *variant* with a payload of *N* values. *v1* to *vN* are variables+of the same types as the values held by the variant. The expected order is given+by the ``variants`` command.++``destruct`` *v0* *v1* .. *vN*+..............................++Copy the values held by an instance of a sum type, given in variable *v0*, to+variables *v1* to *vN*, where N is the number of values stored in the variant of+*v0*. The expected order is given by the ``variants`` command.++``variant`` *v*+...............++Print the variant name of sum-typed variable *v*.  Environment Variables ---------------------
futhark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name:           futhark-version:        0.25.35+version:        0.25.36 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -246,6 +246,7 @@       Futhark.Construct       Futhark.Doc.Generator       Futhark.Error+      Futhark.Eval       Futhark.Fmt.Printer       Futhark.Fmt.Monad       Futhark.FreshNames@@ -304,6 +305,8 @@       Futhark.Internalise.Monomorphise       Futhark.Internalise.ReplaceRecords       Futhark.Internalise.TypesValues+      Futhark.LSP.CodeLens+      Futhark.LSP.CommandType       Futhark.LSP.Compile       Futhark.LSP.Diagnostic       Futhark.LSP.Handlers@@ -470,16 +473,16 @@     , file-embed >=0.0.14.0     , filepath >=1.4.1.1     , free >=5.1.10-    , futhark-data >= 1.1.2.0-    , futhark-server >= 1.2.3.0-    , futhark-manifest >= 1.5.0.0+    , futhark-data >= 1.1.3.0+    , futhark-server >= 1.3.0.0+    , futhark-manifest == 1.7.0.0     , githash >=0.1.6.1     , half >= 0.3     , haskeline     , language-c-quote >= 0.12     , lens-    , lsp >= 2.2.0.0-    , lsp-types >= 2.0.1.0+    , lsp >= 2.8.0.0+    , lsp-types >= 2.4.0.0     , mainland-pretty >=0.7.1     , cmark-gfm >=0.2.1     , megaparsec >=9.0.0
prelude/soacs.fut view
@@ -82,7 +82,7 @@ def map4 'a 'b 'c 'd [n] 'x (f: a -> b -> c -> d -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) : *[n]x =   map (\(a, b, c, d) -> f a b c d) (zip4 as bs cs ds) --- | As `map3`@term, but with one more array.+-- | As `map4`@term, but with one more array. -- -- **Work:** *O(n ✕ W(f))* --
rts/c/scalar.h view
@@ -1339,8 +1339,8 @@  #if defined(ISPC) -SCALAR_FUN_ATTR bool futrts_isinf64(float x) { return !isnan(x) && isnan(x - x); }-SCALAR_FUN_ATTR bool futrts_isfinite64(float x) { return !isnan(x) && !futrts_isinf64(x); }+SCALAR_FUN_ATTR bool futrts_isinf64(double x) { return !isnan(x) && isnan(x - x); }+SCALAR_FUN_ATTR bool futrts_isfinite64(double x) { return !isnan(x) && !futrts_isinf64(x); } SCALAR_FUN_ATTR double fdiv64(double x, double y) { return x / y; } SCALAR_FUN_ATTR double fadd64(double x, double y) { return x + y; } SCALAR_FUN_ATTR double fsub64(double x, double y) { return x - y; }@@ -1482,7 +1482,7 @@ SCALAR_FUN_ATTR double futrts_ceil64(double x) { return ceil(x); }  extern "C" unmasked uniform double nextafter(uniform float x, uniform double y);-SCALAR_FUN_ATTR float futrts_nextafter64(double x, double y) {+SCALAR_FUN_ATTR double futrts_nextafter64(double x, double y) {   double res;   foreach_active (i) {     uniform double r = nextafter(extract(x, i), extract(y, i));@@ -1743,7 +1743,7 @@ SCALAR_FUN_ATTR double futrts_fma64(double a, double b, double c) { return fma(a, b, c); } SCALAR_FUN_ATTR double futrts_round64(double x) { return rint(x); } SCALAR_FUN_ATTR double futrts_ceil64(double x) { return ceil(x); }-SCALAR_FUN_ATTR float futrts_nextafter64(float x, float y) { return nextafter(x, y); }+SCALAR_FUN_ATTR double futrts_nextafter64(double x, double y) { return nextafter(x, y); } SCALAR_FUN_ATTR double futrts_floor64(double x) { return floor(x); } SCALAR_FUN_ATTR bool futrts_isnan64(double x) { return isnan(x); } SCALAR_FUN_ATTR bool futrts_isinf64(double x) { return isinf(x); }@@ -1855,7 +1855,7 @@   return ldexp(x, y); } -SCALAR_FUN_ATTR float futrts_copysign64(double x, double y) {+SCALAR_FUN_ATTR double futrts_copysign64(double x, double y) {   return copysign(x, y); }
rts/c/server.h view
@@ -14,12 +14,33 @@ const char* futhark_get_tuning_param_name(int i); const char* futhark_get_tuning_param_class(int i); -typedef int (*restore_fn)(const void*, FILE *, struct futhark_context*, void*);-typedef void (*store_fn)(const void*, FILE *, struct futhark_context*, void*);+typedef int (*restore_fn)(const void*, FILE*, struct futhark_context*, void*);+typedef void (*store_fn)(const void*, FILE*, struct futhark_context*, void*); typedef int (*free_fn)(const void*, struct futhark_context*, void*);+typedef void* (*array_new_fn)(struct futhark_context *, const void*, const int64_t*);+typedef const int64_t* (*array_shape_fn)(struct futhark_context*, void*);+typedef int (*array_index_fn)(struct futhark_context*, void*, const void*, const int64_t*); typedef int (*project_fn)(struct futhark_context*, void*, const void*);+typedef int (*variant_fn)(struct futhark_context*, const void*); typedef int (*new_fn)(struct futhark_context*, void**, const void*[]);+typedef int (*destruct_fn)(struct futhark_context*, const void*[], const void*); +enum kind {+  PRIMITIVE,+  ARRAY,+  RECORD,+  SUM,+  OPAQUE+};++struct array {+  int rank;+  const struct type *element_type;+  array_new_fn new;+  array_shape_fn shape;+  array_index_fn index;+};+ struct field {   const char *name;   const struct type *type;@@ -32,13 +53,28 @@   new_fn new; }; +struct variant {+  const char *name;+  int num_types;+  const struct type **types;+  new_fn new;+  destruct_fn destruct;+};++struct sum {+  int num_variants;+  const struct variant *variants;+  variant_fn variant;+};+ struct type {   const char *name;   restore_fn restore;   store_fn store;   free_fn free;   const void *aux;-  const struct record *record;+  const enum kind kind;+  const void *info; };  int free_scalar(const void *aux, struct futhark_context *ctx, void *p) {@@ -158,6 +194,7 @@   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 **in_types;@@ -613,23 +650,211 @@   printf("Unknown tuning parameter: %s\n", param); } +void cmd_attributes(struct server_state *s, const char *args[]) {+  const char *name = get_arg(args, 0);+  struct entry_point *e = get_entry_point(s, name);++  if (e == NULL) {+    failure();+    printf("Unknown entry point: %s\n", name);+    return;+  }++  const char **params = e->attrs;+  for (int i = 0; params[i] != NULL; i++) {+    printf("%s\n", params[i]);+  }+}++void cmd_kind(struct server_state *s, const char *args[]) {+  const char *type = get_arg(args, 0);+  const struct type *t = get_type(s, type);++  switch (t->kind) {+    case PRIMITIVE: printf("primitive\n"); return;+    case ARRAY:     printf("array\n");     return;+    case RECORD:    printf("record\n");    return;+    case SUM:       printf("sum\n");       return;+    case OPAQUE:    printf("opaque\n");    return;+  }+  futhark_panic(1, "Invalid kind detected on type \"%s\".\n", t->name);+}++void cmd_type(struct server_state *s, const char *args[]) {+  const char *from_name = get_arg(args, 0);+  struct variable *v = get_variable(s, from_name);++  if (v == NULL) {+    failure();+    printf("Unknown variable: %s\n", from_name);+    return;+  }++  printf("%s\n", v->value.type->name);+}++void cmd_shape(struct server_state *s, const char *args[]) {+  const char *name = get_arg(args, 0);+  struct variable* v = get_variable(s, name);++  if (v == NULL) {+    failure();+    printf("Unknown variable: %s\n", name);+    return;+  }++  if (v->value.type->kind != ARRAY) {+    failure();+    printf("Not an array type\n");+    return;+  }++  const struct array *a = v->value.type->info;++  const int64_t *shape = a->shape(s->ctx, v->value.value.v_ptr);+  for (int i = 0; i < a->rank; ++i) {+    printf("%lld ", shape[i]);+  }+  printf("\n");+}++void cmd_elemtype(struct server_state *s, const char *args[]) {+  const char *type = get_arg(args, 0);+  const struct type *t = get_type(s, type);++  if (t->kind != ARRAY) {+    failure();+    printf("Not an array type\n");+    return;+  }++  const struct array *a = t->info;++  printf("%s\n", a->element_type->name);+}++void cmd_index(struct server_state *s, const char *args[]) {+  const char *to_name = get_arg(args, 0);+  const char *from_name = get_arg(args, 1);+  struct variable* from = get_variable(s, from_name);++  if (from == NULL) {+    failure();+    printf("Unknown variable: %s\n", from_name);+    return;+  }++  if (from->value.type->kind != ARRAY) {+    failure();+    printf("Not an array type\n");+    return;+  }++  const struct array *a = from->value.type->info;++  const int64_t *shape = a->shape(s->ctx, from->value.value.v_ptr);+  int64_t* indices = alloca(a->rank * sizeof(int64_t));+  for (int i = 0; ; ++i) {+    if (!arg_exists(args, 2+i)) {+      if (i != a->rank) {+        failure();+        printf("%d indices expected but %d values provided.\n", a->rank, i);+        return;+      }+      break;+    }+  }+  for (int i = 0; i < a->rank; ++i) {+    const char *idx_arg = get_arg(args, 2+i);+    char* end;+    errno = 0;+    int64_t idx = strtoll(idx_arg, &end, 10);++    if (errno == ERANGE || *end != '\0' || idx < 0 || idx >= shape[i]) {+      failure();+      printf("Invalid index `%s` on dimension %d.\n", idx_arg, i+1);+      return;+    }++    indices[i] = idx;+  }++  struct variable* to = create_variable(s, to_name, a->element_type);++  if (to == NULL) {+    failure();+    printf("Variable already exists: %s\n", to_name);+    return;+  }++  a->index(s->ctx, value_ptr(&to->value), from->value.value.v_ptr, indices);+}+ void cmd_fields(struct server_state *s, const char *args[]) {   const char *type = get_arg(args, 0);   const struct type *t = get_type(s, type);-  const struct record *r = t->record; -  if (r == NULL) {+  if (t->kind != RECORD) {     failure();     printf("Not a record type\n");     return;   } +  const struct record *r = t->info;+   for (int i = 0; i < r->num_fields; i++) {     const struct field f = r->fields[i];     printf("%s %s\n", f.name, f.type->name);   } } +void cmd_variants(struct server_state *s, const char *args[]) {+  const char *type = get_arg(args, 0);+  const struct type *t = get_type(s, type);++  if (t->kind != SUM) {+    failure();+    printf("Not a sum type\n");+    return;+  }++  const struct sum *st = t->info;++  for (int i = 0; i < st->num_variants; i++) {+    const struct variant *v = &st->variants[i];+    printf("%s\n", v->name);+    for (int i = 0; i < v->num_types; i++) {+      const struct type *f = v->types[i];+      printf("- %s\n", f->name);+    }+  }+}++void cmd_variant(struct server_state *s, const char *args[]) {+  const char *name = get_arg(args, 0);+  struct variable* v = get_variable(s, name);++  if (v == NULL) {+    failure();+    printf("Unknown variable: %s\n", name);+    return;+  }++  const struct type *t = get_type(s, v->value.type->name);++  if (t->kind != SUM) {+    failure();+    printf("Not a sum type\n");+    return;+  }++  const struct sum *st = t->info;++  int i = st->variant(s->ctx, v->value.value.v_ptr);+  const struct variant *var = &st->variants[i];+  printf("%s\n", var->name);+}+ void cmd_project(struct server_state *s, const char *args[]) {   const char *to_name = get_arg(args, 0);   const char *from_name = get_arg(args, 1);@@ -644,14 +869,15 @@   }    const struct type *from_type = from->value.type;-  const struct record *r = from_type->record; -  if (r == NULL) {+  if (from_type->kind != RECORD) {     failure();     printf("Not a record type\n");     return;   } +  const struct record *r = from_type->info;+   const struct field *field = NULL;   for (int i = 0; i < r->num_fields; i++) {     if (strcmp(r->fields[i].name, field_name) == 0) {@@ -688,14 +914,14 @@     return;   } -  const struct record* r = type->record;--  if (r == NULL) {+  if (type->kind != RECORD) {     failure();     printf("Not a record type\n");     return;   } +  const struct record *r = type->info;+   int num_args = 0;   for (int i = 2; arg_exists(args, i); i++) {     num_args++;@@ -731,6 +957,119 @@   r->new(s->ctx, value_ptr(&to->value), value_ptrs); } +void cmd_construct(struct server_state *s, const char *args[]) {+  const char *to_name = get_arg(args, 0);+  const char *type_name = get_arg(args, 1);+  const char *variant_name = get_arg(args, 2);+  const struct type *type = get_type(s, type_name);+  struct variable *to = create_variable(s, to_name, type);++  if (to == NULL) {+    failure();+    printf("Variable already exists: %s\n", to_name);+    return;+  }++  if (type->kind != SUM) {+    failure();+    printf("Not a sum type\n");+    return;+  }++  const struct sum *st = type->info;++  for (int i = 0; i < st->num_variants; i++) {+    const struct variant *var = &st->variants[i];+    if (strcmp(var->name, variant_name) == 0) {+      int num_args = 0;+      for (int i = 3; arg_exists(args, i); i++) {+        num_args++;+      }++      if (num_args != var->num_types) {+        failure();+        printf("%d values expected but %d values provided.\n", var->num_types, num_args);+        return;+      }++      const void** value_ptrs = alloca(num_args * sizeof(void*));++      for (int i = 0; i < num_args; i++) {+        const char *vname = get_arg(args, 3+i);+        struct variable* v = get_variable(s, vname);++        if (v == NULL) {+          failure();+          printf("Unknown variable: %s\n", vname);+          return;+        }++        if (strcmp(v->value.type->name, var->types[i]->name) != 0) {+          failure();+          printf("Value %d mismatch: expected type %s, got %s\n",+                i, var->types[i]->name, v->value.type->name);+          return;+        }++        value_ptrs[i] = value_ptr(&v->value);+      }++      var->new(s->ctx, value_ptr(&to->value), value_ptrs);+      return;+    }+  }++  failure();+  printf("No such variant\n");+}++void cmd_destruct(struct server_state *s, const char *args[]) {+  const char *from_name = get_arg(args, 0);+  struct variable *v = get_variable(s, from_name);++  if (v == NULL) {+    failure();+    printf("Unknown variable: %s\n", from_name);+    return;+  }++  if (v->value.type->kind != SUM) {+    failure();+    printf("Not a sum type\n");+    return;+  }++  const struct sum *sum = v->value.type->info;+  const struct variant *var = &sum->variants[sum->variant(s->ctx, v->value.value.v_ptr)];++  int num_args = 0;+  for (int i = 1; arg_exists(args, i); i++) {+    num_args++;+  }++  if (num_args != var->num_types) {+    failure();+    printf("%d variables expected but %d variables provided.  %s\n", var->num_types, num_args, var->name);+    return;+  }++  const void **value_ptrs = alloca(num_args * sizeof(struct variable*));++  for (int i = 0; i < num_args; i++) {+    const char *vname = get_arg(args, i+1);+    struct variable *vn = create_variable(s, vname, var->types[i]);+    if (vn == NULL) {+      failure();+      printf("Variable already exists: %s\n", vname);+      return;+    }+    value_ptrs[i] = value_ptr(&vn->value);+  }++  var->destruct(s->ctx, value_ptrs, v->value.value.v_ptr);+  return;+}+ void cmd_entry_points(struct server_state *s, const char *args[]) {   (void)args;   for (int i = 0; s->prog.entry_points[i].name; i++) {@@ -835,14 +1174,34 @@     cmd_tuning_params(s, tokens+1);   } else if (strcmp(command, "tuning_param_class") == 0) {     cmd_tuning_param_class(s, tokens+1);+  } else if (strcmp(command, "kind") == 0) {+    cmd_kind(s, tokens+1);+  } else if (strcmp(command, "type") == 0) {+    cmd_type(s, tokens+1);+  } else if (strcmp(command, "shape") == 0) {+    cmd_shape(s, tokens+1);+  } else if (strcmp(command, "elemtype") == 0) {+    cmd_elemtype(s, tokens+1);+  } else if (strcmp(command, "index") == 0) {+    cmd_index(s, tokens+1);   } else if (strcmp(command, "fields") == 0) {     cmd_fields(s, tokens+1);+  } else if (strcmp(command, "variants") == 0) {+    cmd_variants(s, tokens+1);+  } else if (strcmp(command, "variant") == 0) {+    cmd_variant(s, tokens+1);   } else if (strcmp(command, "new") == 0) {     cmd_new(s, tokens+1);+  } else if (strcmp(command, "construct") == 0) {+    cmd_construct(s, tokens+1);+  } else if (strcmp(command, "destruct") == 0) {+    cmd_destruct(s, tokens+1);   } else if (strcmp(command, "project") == 0) {     cmd_project(s, tokens+1);   } else if (strcmp(command, "entry_points") == 0) {     cmd_entry_points(s, tokens+1);+  } else if (strcmp(command, "attributes") == 0) {+    cmd_attributes(s, tokens+1);   } else if (strcmp(command, "types") == 0) {     cmd_types(s, tokens+1);   } else {@@ -883,8 +1242,6 @@ // The aux struct lets us write generic method implementations without // code duplication. -typedef void* (*array_new_fn)(struct futhark_context *, const void*, const int64_t*);-typedef const int64_t* (*array_shape_fn)(struct futhark_context*, void*); typedef int (*array_values_fn)(struct futhark_context*, void*, void*); typedef int (*array_free_fn)(struct futhark_context*, void*);
rts/c/uniform.h view
@@ -1104,10 +1104,10 @@  #ifdef FUTHARK_F64_ENABLED -static inline uniform bool futrts_isinf64(uniform float x) {+static inline uniform bool futrts_isinf64(uniform double x) {   return !isnan(x) && isnan(x - x); }-static inline uniform bool futrts_isfinite64(uniform float x) {+static inline uniform bool futrts_isfinite64(uniform double x) {   return !isnan(x) && !futrts_isinf64(x); }
rts/c/values.h view
@@ -427,6 +427,24 @@   return fprintf(out, "%"PRIu64"u64", *src); } +// FLT_DECIMAL_DIG and DBL_DECIMAL_DIG are defined in C11.+// If we want C99 compatibility, we must define them ourselves.+// We choose the standard values on platforms that use the IEEE754 defaults, with fallback to an overestimate.+#ifndef FLT_DECIMAL_DIG+  #if FLT_RADIX == 2 && FLT_MANT_DIG <= 24 && 9 < DECIMAL_DIG+    #define FLT_DECIMAL_DIG 9+  #else+    #define FLT_DECIMAL_DIG DECIMAL_DIG+  #endif+#endif+#ifndef DBL_DECIMAL_DIG+  #if FLT_RADIX == 2 && DBL_MANT_DIG <= 53 && 17 < DECIMAL_DIG+    #define DBL_DECIMAL_DIG 17+  #else+    #define DBL_DECIMAL_DIG DECIMAL_DIG+  #endif+#endif+ static int write_str_f16(FILE *out, const uint16_t *src) {   float x = halfbits2float(*src);   if (isnan(x)) {@@ -436,7 +454,7 @@   } else if (isinf(x)) {     return fprintf(out, "-f16.inf");   } else {-    return fprintf(out, "%.*ff16", FLT_DIG, x);+    return fprintf(out, "%.*gf16", FLT_DECIMAL_DIG, x);   } } @@ -449,7 +467,7 @@   } else if (isinf(x)) {     return fprintf(out, "-f32.inf");   } else {-    return fprintf(out, "%.*ff32", FLT_DIG, x);+    return fprintf(out, "%.*gf32", FLT_DECIMAL_DIG, x);   } } @@ -462,7 +480,7 @@   } else if (isinf(x)) {     return fprintf(out, "-f64.inf");   } else {-    return fprintf(out, "%.*ff64", DBL_DIG, x);+    return fprintf(out, "%.*gf64", DBL_DECIMAL_DIG, x);   } }
src/Futhark/Analysis/DataDependencies.hs view
@@ -78,13 +78,13 @@               map comb $                 zip3                   (patElems pat)-                  ( L.transpose . zipWith (map . depsOf) cases_deps $-                      map (map resSubExp . bodyResult . caseBody) cases+                  ( L.transpose . zipWith (map . depsOfRes) cases_deps $+                      map (bodyResult . caseBody) cases                   )-                  (map (depsOf defbody_deps . resSubExp) (bodyResult defbody))+                  (map (depsOfRes defbody_deps) (bodyResult defbody))        in M.unions $ [branchdeps, deps, defbody_deps] ++ cases_deps-    grow deps (Let pat _ e) =-      let free = freeIn pat <> freeIn e+    grow deps (Let pat aux e) =+      let free = freeIn pat <> freeIn e <> freeIn aux           free_deps = depsOfNames deps free        in M.fromList [(name, free_deps) | name <- patNames pat] `M.union` deps @@ -100,7 +100,7 @@ depsOfVar deps name = oneName name <> M.findWithDefault mempty name deps  depsOfRes :: Dependencies -> SubExpRes -> Names-depsOfRes deps (SubExpRes _ se) = depsOf deps se+depsOfRes deps (SubExpRes cs se) = depsOf deps se <> depsOfNames deps (freeIn cs)  -- | Extend @names@ with direct dependencies in @deps@. depsOfNames :: Dependencies -> Names -> Names
src/Futhark/CLI/Autotune.hs view
@@ -1,9 +1,11 @@ -- | @futhark autotune@ module Futhark.CLI.Autotune (main) where +import Control.Exception import Control.Monad import Data.ByteString.Char8 qualified as SBS import Data.Function (on)+import Data.IORef import Data.List (elemIndex, intersect, minimumBy, sort, sortOn) import Data.Map qualified as M import Data.Maybe@@ -14,12 +16,14 @@ import Futhark.Bench import Futhark.Server import Futhark.Test-import Futhark.Util (maxinum, showText)+import Futhark.Util (fancyTerminal, maxinum, showText) import Futhark.Util.Options+import Futhark.Util.ProgressBar import System.Directory import System.Environment (getExecutablePath) import System.Exit import System.FilePath+import System.IO import Text.Read (readMaybe) import Text.Regex.TDFA @@ -107,7 +111,7 @@  setTuningParam :: Server -> T.Text -> Int -> IO () setTuningParam server name val =-  void $ checkCmd =<< cmdSetTuningParam server name (showText val)+  void $ checkCmd . maybe (Right ()) Left =<< cmdSetTuningParam server name val  setTuningParams :: Server -> Path -> IO () setTuningParams server = mapM_ (uncurry $ setTuningParam server)@@ -306,16 +310,6 @@               T.unwords [v, "is irrelevant for", entry_point]           pure (thresholds, best_runtimes)         else do-          T.putStrLn $-            T.unwords-              [ "Tuning",-                v,-                "on entry point",-                entry_point,-                "and dataset",-                dataset_name-              ]-           sample_run <-             run               server@@ -363,7 +357,8 @@                     | fromIntegral rt * epsilon < fromIntegral best_t -> do                         T.putStrLn $                           T.unwords-                            [ "WARNING! Possible non-monotonicity detected. Previous best run-time for dataset",+                            [ (if fancyTerminal then "\r\ESC[K" else "")+                                <> "WARNING! Possible non-monotonicity detected. Previous best run-time for dataset",                               dataset_name,                               " was",                               showText rt,@@ -395,7 +390,7 @@           when (optVerbose opts > 0) $             putStrLn $               unwords-                [ "Trying e_par",+                [ (if fancyTerminal then "\r\ESC[K" else "") ++ "Trying e_par",                   show middle,                   "and",                   show middle'@@ -428,7 +423,7 @@         (_, _) -> do           when (optVerbose opts > 0) $             putStrLn $-              unwords ["Trying e_pars", show xs]+              unwords [(if fancyTerminal then "\r\ESC[K" else "") ++ "Trying e_pars", show xs]           candidates <-             catMaybes . zipWith (fmap . flip (,)) xs               <$> mapM (runner $ timeout best_t) xs@@ -447,29 +442,74 @@   let progbin = "." </> dropExtension prog   withServer (futharkServerCfg progbin (serverOptions opts)) $ \server -> do     forest <- thresholdForest server+    let paths = tuningPaths forest+    let total = length paths     when (optVerbose opts > 0) $       putStrLn $         ("Threshold forest:\n" <>) $           drawForest (map (fmap show) forest) -    fmap fst . foldM (tuneThreshold opts server datasets) ([], mempty) $-      tuningPaths forest+    counter <- newIORef (0 :: Int)+    let dataset_names =+          T.intercalate "," $ map (\(name, _, ep) -> ep <> ":" <> name) datasets+    result <-+      foldM+        ( \acc tp@(v, _) -> do+            modifyIORef' counter (+ 1)+            n <- readIORef counter+            let bar =+                  "\rTuning: "+                    ++ show n+                    ++ "/"+                    ++ show total+                    ++ " "+                    ++ T.unpack+                      ( progressBar+                          ProgressBar+                            { progressBarSteps = 10,+                              progressBarBound = 1,+                              progressBarElapsed = fromIntegral n / fromIntegral total+                            }+                      )+                    ++ T.unpack v+                    ++ " on "+                    ++ T.unpack dataset_names+            when fancyTerminal $ putStr bar+            hFlush stdout+            r <- tuneThreshold opts server datasets acc tp+            when fancyTerminal $ putStr bar+            hFlush stdout+            pure r+        )+        ([], mempty)+        paths+    when fancyTerminal $ do+      putStr "\r\ESC[K"+      hFlush stdout+    pure (fst result) +onServerException :: ServerException -> IO a+onServerException (ServerException s) = do+  T.hPutStrLn stderr s+  exitFailure+ runAutotuner :: AutotuneOptions -> FilePath -> IO ()-runAutotuner opts prog = do-  best <- tune opts prog+runAutotuner opts prog =+  do+    best <- tune opts prog -  let tuning = T.unlines $ do-        (s, n) <- sortOn fst best-        pure $ s <> "=" <> showText n+    let tuning = T.unlines $ do+          (s, n) <- sortOn fst best+          pure $ s <> "=" <> showText n -  case optTuning opts of-    Nothing -> pure ()-    Just suffix -> do-      T.writeFile (prog <.> suffix) tuning-      putStrLn $ "Wrote " ++ prog <.> suffix+    case optTuning opts of+      Nothing -> pure ()+      Just suffix -> do+        T.writeFile (prog <.> suffix) tuning+        putStrLn $ "Wrote " ++ prog <.> suffix -  T.putStrLn $ "Result of autotuning:\n" <> tuning+    T.putStrLn $ "Result of autotuning:\n" <> tuning+    `catch` onServerException  supportedBackends :: [String] supportedBackends = ["opencl", "cuda", "hip"]
src/Futhark/CLI/Dev.hs view
@@ -200,6 +200,27 @@     )     desc +passOptionWithArg ::+  String ->+  (Maybe String -> UntypedPass) ->+  String ->+  [String] ->+  String ->+  String ->+  FutharkOption+passOptionWithArg desc makePass short long argName argDesc =+  Option+    short+    long+    ( OptArg+        ( \arg -> Right $ \cfg ->+            let pass = makePass arg+             in cfg {futharkPipeline = Pipeline $ getFutharkPipeline cfg ++ [pass]}+        )+        argName+    )+    (desc ++ " " ++ argDesc)+ kernelsMemProg ::   String ->   UntypedPassState ->@@ -271,6 +292,40 @@ soacsPassOption =   typedPassOption soacsProg SOACS +typedPassOptionWithArg ::+  (Checkable torep) =>+  (String -> UntypedPassState -> FutharkM (Prog fromrep)) ->+  (Prog torep -> UntypedPassState) ->+  (Maybe String -> Either String (Pass fromrep torep)) ->+  String ->+  [String] ->+  String ->+  String ->+  FutharkOption+typedPassOptionWithArg getProg putProg makePass =+  passOptionWithArg desc (UntypedPass . perform)+  where+    desc = case makePass Nothing of+      Right pass -> passDescription pass+      Left _ -> "Pass with argument"++    perform arg s config = do+      case makePass arg of+        Left err -> externalErrorS err+        Right pass -> do+          prog <- getProg (passName pass) s+          putProg <$> runPipeline (onePass pass) config prog++soacsPassOptionWithArg ::+  (Maybe String -> Either String (Pass SOACS.SOACS SOACS.SOACS)) ->+  String ->+  [String] ->+  String ->+  String ->+  FutharkOption+soacsPassOptionWithArg =+  typedPassOptionWithArg soacsProg SOACS+ kernelsPassOption ::   Pass GPU.GPU GPU.GPU ->   String ->@@ -433,6 +488,12 @@     long = [passLongOption pass]     pass = unstreamGPU +parseGas :: Maybe String -> Either String (Maybe Int)+parseGas Nothing = Right Nothing+parseGas (Just s) = case reads s of+  [(n, "")] -> Right (Just n)+  _any -> Left $ "Invalid gas value: " <> s+ commandLineOptions :: [FutharkOption] commandLineOptions =   [ Option@@ -640,7 +701,12 @@       (NoArg $ Right $ \opts -> opts {futharkCompilerMode = ToServer})       "Generate a server executable.",     typedPassOption soacsProg Seq firstOrderTransform "f",-    soacsPassOption fuseSOACs "o",+    soacsPassOptionWithArg+      (fmap fuseSOACs . parseGas)+      "o"+      ["fuse"]+      "GAS"+      "(default: infinite, provide integer to limit)",     soacsPassOption inlineAggressively [],     soacsPassOption inlineConservatively [],     soacsPassOption removeDeadFunctions [],
src/Futhark/CLI/Eval.hs view
@@ -1,30 +1,29 @@ -- | @futhark eval@ module Futhark.CLI.Eval (main) where -import Control.Exception import Control.Monad-import Control.Monad.Except (ExceptT, runExceptT, throwError)-import Control.Monad.Free.Church-import Control.Monad.IO.Class (MonadIO, liftIO)+  ( forM_,+  ) import Data.Map qualified as M-import Data.Maybe import Data.Text qualified as T-import Data.Text.IO qualified as T-import Futhark.Compiler-import Futhark.MonadFreshNames-import Futhark.Pipeline+import Futhark.Eval+  ( InterpreterConfig (..),+    interpreterConfig,+    newFutharkiState,+    runExpr,+  ) import Futhark.Util.Options+  ( ArgDescr (NoArg, ReqArg),+    FunOptDescr,+    OptDescr (Option),+    mainWithOptions,+  ) import Futhark.Util.Pretty-import Language.Futhark-import Language.Futhark.Interpreter qualified as I-import Language.Futhark.Parser-import Language.Futhark.Semantic qualified as T-import Language.Futhark.TypeChecker qualified as I-import Language.Futhark.TypeChecker qualified as T-import System.Exit-import System.FilePath-import System.IO-import Prelude+  ( hPutDocLn,+    putDocLn,+  )+import System.Exit (ExitCode (ExitFailure), exitWith)+import System.IO (stderr)  -- | Run @futhark eval@. main :: String -> [String] -> IO ()@@ -36,47 +35,13 @@ runExprs :: [String] -> InterpreterConfig -> IO () runExprs exprs cfg = do   let InterpreterConfig _ file = cfg-  maybe_new_state <- newFutharkiState cfg file-  (src, env, ctx) <- case maybe_new_state of+  maybe_new_state <- newFutharkiState cfg file M.empty+  interpreter_state <- case maybe_new_state of     Left reason -> do       hPutDocLn stderr reason       exitWith $ ExitFailure 2     Right s -> pure s-  mapM_ (runExpr src env ctx) exprs---- Use parseExp, checkExp, then interpretExp.-runExpr :: VNameSource -> T.Env -> I.Ctx -> String -> IO ()-runExpr src env ctx str = do-  uexp <- case parseExp "" (T.pack str) of-    Left (SyntaxError _ serr) -> do-      T.hPutStrLn stderr serr-      exitWith $ ExitFailure 1-    Right e -> pure e-  fexp <- case T.checkExp [] src env uexp of-    (_, Left terr) -> do-      hPutDoc stderr $ I.prettyTypeError terr-      exitWith $ ExitFailure 1-    (_, Right ([], e)) -> pure e-    (_, Right (tparams, e)) -> do-      putDocLn $ "Inferred type of expression: " <> align (pretty (typeOf e))-      T.putStrLn $-        "The following types are ambiguous: "-          <> T.intercalate ", " (map (nameToText . toName . typeParamName) tparams)-      exitWith $ ExitFailure 1-  pval <- runInterpreterNoBreak $ I.interpretExp ctx fexp-  case pval of-    Left err -> do-      hPutDoc stderr $ I.prettyInterpreterError err-      exitWith $ ExitFailure 1-    Right val -> putDoc $ I.prettyValue val <> hardline--data InterpreterConfig = InterpreterConfig-  { interpreterPrintWarnings :: Bool,-    interpreterFile :: Maybe String-  }--interpreterConfig :: InterpreterConfig-interpreterConfig = InterpreterConfig True Nothing+  forM_ exprs $ \expr -> putDocLn =<< runExpr interpreter_state (T.pack expr)  options :: [FunOptDescr InterpreterConfig] options =@@ -96,45 +61,3 @@       (NoArg $ Right $ \config -> config {interpreterPrintWarnings = False})       "Do not print warnings."   ]--newFutharkiState ::-  InterpreterConfig ->-  Maybe FilePath ->-  IO (Either (Doc AnsiStyle) (VNameSource, T.Env, I.Ctx))-newFutharkiState cfg maybe_file = runExceptT $ do-  (ws, imports, src) <--    badOnLeft prettyCompilerError-      =<< liftIO-        ( runExceptT (readProgramFiles [] $ maybeToList maybe_file)-            `catch` \(err :: IOException) ->-              pure (externalErrorS (show err))-        )-  when (interpreterPrintWarnings cfg) $-    liftIO $-      hPutDoc stderr $-        prettyWarnings ws--  ictx <--    foldM (\ctx -> badOnLeft I.prettyInterpreterError <=< runInterpreterNoBreak . I.interpretImport ctx) I.initialCtx $-      map (fmap fileProg) imports--  let (tenv, ienv) =-        let (iname, fm) = last imports-         in ( fileScope fm,-              ictx {I.ctxEnv = I.ctxImports ictx M.! iname}-            )--  pure (src, tenv, ienv)-  where-    badOnLeft :: (err -> err') -> Either err a -> ExceptT err' IO a-    badOnLeft _ (Right x) = pure x-    badOnLeft p (Left err) = throwError $ p err--runInterpreterNoBreak :: (MonadIO m) => F I.ExtOp a -> m (Either I.InterpreterError a)-runInterpreterNoBreak m = runF m (pure . Right) intOp-  where-    intOp (I.ExtOpError err) = pure $ Left err-    intOp (I.ExtOpTrace w v c) = do-      liftIO $ putDocLn $ pretty w <> ":" <+> align (unAnnotate v)-      c-    intOp (I.ExtOpBreak _ _ _ c) = c
src/Futhark/CLI/LSP.hs view
@@ -5,8 +5,10 @@  import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.IORef (newIORef)+import Futhark.LSP.CommandType (CommandType) import Futhark.LSP.Handlers (handlers) import Futhark.LSP.State (emptyState)+import Futhark.Util (showText) import Language.LSP.Protocol.Types   ( SaveOptions (SaveOptions),     TextDocumentSyncKind (TextDocumentSyncKind_Incremental),@@ -14,7 +16,7 @@     type (|?) (InR),   ) import Language.LSP.Server-  ( Options (optTextDocumentSync),+  ( Options (optExecuteCommandCommands, optTextDocumentSync),     ServerDefinition       ( ServerDefinition,         configSection,@@ -31,12 +33,16 @@     runServer,     type (<~>) (Iso),   )+import System.Exit+import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr)  -- | Run @futhark lsp@ main :: String -> [String] -> IO () main _prog _args = do   state_mvar <- newIORef emptyState-  _ <-+  -- makes the lines appear in full in the logs+  hSetBuffering stderr LineBuffering+  code <-     runServer $       ServerDefinition         { onConfigChange = const $ pure (),@@ -48,10 +54,15 @@           interpretHandler = \env -> Iso (runLspT env) liftIO,           options =             defaultOptions-              { optTextDocumentSync = Just syncOptions+              { optTextDocumentSync =+                  Just syncOptions,+                optExecuteCommandCommands =+                  Just $ map showText [minBound :: CommandType .. maxBound]               }         }-  pure ()+  case code of+    0 -> exitSuccess+    _ -> exitWith $ ExitFailure code  syncOptions :: TextDocumentSyncOptions syncOptions =
src/Futhark/CodeGen/Backends/GenericC/CLI.hs view
@@ -299,7 +299,7 @@  cliEntryPoint ::   Manifest -> T.Text -> EntryPoint -> (C.Definition, C.Initializer)-cliEntryPoint manifest entry_point_name (EntryPoint cfun _tuning_params outputs inputs) =+cliEntryPoint manifest entry_point_name (EntryPoint cfun _tuning_params outputs inputs _attrs) =   let (input_items, pack_input, free_input, free_parsed, input_args) =         unzip5 $ readInputs manifest $ map inputType inputs
src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs view
@@ -9,6 +9,7 @@ import Control.Monad import Control.Monad.Reader (asks) import Data.Maybe+import Data.Set qualified as S import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC.Monad import Futhark.CodeGen.Backends.GenericC.Types (opaqueToCType, valueTypeToCType)@@ -135,8 +136,8 @@   Name ->   Function op ->   CompilerM op s (Maybe (C.Definition, (T.Text, Manifest.EntryPoint)))-onEntryPoint _ _ _ (Function Nothing _ _ _) = pure Nothing-onEntryPoint get_consts relevant_params fname (Function (Just (EntryPoint ename results args)) outputs inputs _) = inNewFunction $ do+onEntryPoint _ _ _ (Function Nothing _ _ _ _) = pure Nothing+onEntryPoint get_consts relevant_params fname (Function (Just (EntryPoint ename results args)) outputs inputs attrs _) = inNewFunction $ do   let out_args = map (\p -> [C.cexp|&$id:(paramName p)|]) outputs       in_args = map (\p -> [C.cexp|$id:(paramName p)|]) inputs @@ -214,7 +215,8 @@             -- and what is "results/args" is different between the             -- manifest and ImpCode.             Manifest.entryPointOutputs = map outputManifest results,-            Manifest.entryPointInputs = map inputManifest args+            Manifest.entryPointInputs = map inputManifest args,+            Manifest.entryPointAttrs = map prettyText (S.toList (unAttrs attrs))           }    pure $ Just (cdef, (nameToText ename, manifest))
src/Futhark/CodeGen/Backends/GenericC/Fun.hs view
@@ -55,7 +55,8 @@   pure ([C.cparam|$ty:ty *$id:p_name|], [C.cexp|$id:p_name|])  compileFun :: [C.BlockItem] -> [C.Param] -> (Name, Function op) -> CompilerM op s (C.Definition, C.Func)-compileFun get_constants extra (fname, func@(Function _ outputs inputs body)) = inNewFunction $ do+compileFun get_constants extra (fname, func) = inNewFunction $ do+  let (Function _ outputs inputs _ body) = func   (outparams, out_ptrs) <- mapAndUnzipM compileOutput outputs   inparams <- mapM compileInput inputs @@ -92,7 +93,7 @@ -- fail) and has no extra parameters (meaning it cannot allocate -- memory non-lexxical or do anything fancy). compileVoidFun :: [C.BlockItem] -> (Name, Function op) -> CompilerM op s (C.Definition, C.Func)-compileVoidFun get_constants (fname, func@(Function _ outputs inputs body)) = inNewFunction $ do+compileVoidFun get_constants (fname, func@(Function _ outputs inputs _ body)) = inNewFunction $ do   (outparams, out_ptrs) <- mapAndUnzipM compileOutput outputs   inparams <- mapM compileInput inputs
src/Futhark/CodeGen/Backends/GenericC/Server.hs view
@@ -7,6 +7,7 @@ where  import Data.Bifunctor (first, second)+import Data.List (unzip4) import Data.Map qualified as M import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC.Options@@ -15,6 +16,7 @@ import Futhark.CodeGen.RTS.C (serverH, tuningH, valuesH) import Futhark.Manifest import Futhark.Util (zEncodeText)+import Futhark.Util.Pretty (prettyText) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C import Language.Futhark.Core (nameFromText)@@ -122,15 +124,34 @@     Just (TypeOpaque ctype _ _) -> [C.cty|typename $id:(T.unpack ctype)|]     Nothing -> uncurry primAPIType $ scalarToPrim tname +data Kind+  = Primitive+  | -- TODO: Implement array functions for opaque arrays+    Array+  | Record+  | Sum+  | Opaque++cKind :: Kind -> C.Exp+cKind Primitive = [C.cexp|PRIMITIVE|]+cKind Array = [C.cexp|ARRAY|]+cKind Record = [C.cexp|RECORD|]+cKind Sum = [C.cexp|SUM|]+cKind Opaque = [C.cexp|OPAQUE|]+ -- First component is forward declaration so we don't have to worry -- about ordering. typeBoilerplate :: Manifest -> (T.Text, Type) -> (C.Definition, C.Initializer, [C.Definition])-typeBoilerplate _ (tname, TypeArray _ et rank ops) =-  let type_name = typeStructName tname+typeBoilerplate _ (tname, TypeArray c_type_name et rank ops) =+  let element_type_name = typeStructName et+      type_name = typeStructName tname+      array_name = type_name <> "_array"       aux_name = type_name <> "_aux"       info_name = et <> "_info"-      shape_args = [[C.cexp|shape[$int:i]|] | i <- [0 .. rank - 1]]       array_new_wrap = arrayNew ops <> "_wrap"+      array_index_wrap = arrayIndex ops <> "_wrap"+      shape_args = [[C.cexp|shape[$int:i]|] | i <- [0 .. rank - 1]]+      is_args = [[C.cexp|is[$int:i]|] | i <- [0 .. rank - 1]]    in ( [C.cedecl|const struct type $id:type_name;|],         [C.cinit|&$id:type_name|],         [C.cunit|@@ -139,6 +160,19 @@                                        const typename int64_t* shape) {                 return $id:(arrayNew ops)(ctx, p, $args:shape_args);               }+              int $id:array_index_wrap(struct futhark_context *ctx,+                                       void *dest,+                                       typename $id:c_type_name arr,+                                       const typename int64_t *is) {+                return $id:(arrayIndex ops)(ctx, dest, arr, $args:is_args);+              }+              const struct array $id:array_name = {+                .rank = $int:rank,+                .element_type = &$id:element_type_name,+                .new = (typename array_new_fn)$id:array_new_wrap,+                .shape = (typename array_shape_fn)$id:(arrayShape ops),+                .index = (typename array_index_fn)$id:array_index_wrap,+              };               const struct array_aux $id:aux_name = {                 .name = $string:(T.unpack tname),                 .rank = $int:rank,@@ -153,16 +187,18 @@                 .restore = (typename restore_fn)restore_array,                 .store = (typename store_fn)store_array,                 .free = (typename free_fn)free_array,-                .aux = &$id:aux_name+                .aux = &$id:aux_name,+                .kind = $exp:(cKind Array),+                .info = &$id:array_name               };|]       ) typeBoilerplate manifest (tname, TypeOpaque c_type_name ops extra_ops) =   let type_name = typeStructName tname       aux_name = type_name <> "_aux"-      (record_edecls, record_init) = recordDefs type_name extra_ops+      (transparent_edecls, transparent_init, kind) = transparentDefs type_name extra_ops    in ( [C.cedecl|const struct type $id:type_name;|],         [C.cinit|&$id:type_name|],-        record_edecls+        transparent_edecls           ++ [C.cunit|               const struct opaque_aux $id:aux_name = {                 .store = (typename opaque_store_fn)$id:(opaqueStore ops),@@ -175,11 +211,12 @@                 .store = (typename store_fn)store_opaque,                 .free = (typename free_fn)free_opaque,                 .aux = &$id:aux_name,-                .record = $init:record_init+                .kind = $exp:(cKind kind),+                .info = $init:transparent_init               };|]       )   where-    recordDefs type_name (Just (OpaqueRecord (RecordOps fields new))) =+    transparentDefs type_name (Just (OpaqueRecord (RecordOps fields new))) =       let new_wrap = new <> "_wrap"           record_name = type_name <> "_record"           fields_name = type_name <> "_fields"@@ -209,17 +246,97 @@                .fields = $id:fields_name,                .new = $id:new_wrap              };|],-            [C.cinit|&$id:record_name|]+            [C.cinit|&$id:record_name|],+            Record           )-    recordDefs _ _ = ([], [C.cinit|NULL|])+    transparentDefs type_name (Just (OpaqueSum (SumOps variants variant))) =+      let sum_name = type_name <> "_sum"+          variants_name = type_name <> "_variants"+          onType i type_tname =+            let type_c_type = cType manifest type_tname+                type_v = "v" <> show (i :: Int)+             in ( [C.citem|const $ty:type_c_type $id:type_v =+                            *(const $ty:type_c_type*)types[$int:i];|],+                  [C.citem|$ty:type_c_type *$id:type_v =+                            ($ty:type_c_type*)outs[$int:i];|],+                  [C.cexp|$id:type_v|],+                  [C.cinit|&$id:(typeStructName type_tname)|]+                )+          onVariant (SumVariant name variant_tnames new destruct) =+            let new_wrap = new <> "_wrap"+                destruct_wrap = destruct <> "_wrap"+                types_name = type_name <> "_" <> name <> "_fields"+                (get_types, get_outs, type_args, type_struct_names) = unzip4 $ zipWith onType [0 ..] variant_tnames+             in ( [C.cinit|{.name = $string:(T.unpack name),+                            .num_types = $int:(length variant_tnames),+                            .types = $id:types_name,+                            .new = $id:new_wrap,+                            .destruct = $id:destruct_wrap+                           }|],+                  [C.cunit|+                    const struct type *$id:types_name[] = {+                      $inits:type_struct_names+                    };+                    int $id:new_wrap(struct futhark_context* ctx, void** outp, const void* types[]) {+                      typename $id:c_type_name *out = (typename $id:c_type_name*) outp;+                      $items:get_types+                      return $id:new(ctx, out, $args:type_args);+                    }+                    int $id:destruct_wrap(struct futhark_context* ctx, const void* outs[], const void* inp) {+                      const typename $id:c_type_name in = (const typename $id:c_type_name) inp;+                      $items:get_outs+                      return $id:destruct(ctx, $args:type_args, in);+                    }|]+                ) +          (variant_inits, variant_wraps) = unzip $ map onVariant variants+       in ( foldl1 (++) variant_wraps+              ++ [C.cunit|+             const struct variant $id:variants_name[] = {+               $inits:variant_inits+             };+             const struct sum $id:sum_name = {+               .num_variants = $int:(length variants),+               .variants = $id:variants_name,+               .variant = (int (*)(struct futhark_context *, const void *))$id:variant+             };|],+            [C.cinit|&$id:sum_name|],+            Sum+          )+    transparentDefs type_name (Just (OpaqueArray ops')) = opaqueArrayDefs type_name (opaqueArrayRank ops') (opaqueArrayElemType ops') (opaqueArrayShape ops') (opaqueArrayIndex ops')+    transparentDefs type_name (Just (OpaqueRecordArray ops')) = opaqueArrayDefs type_name (recordArrayRank ops') (recordArrayElemType ops') (recordArrayShape ops') (recordArrayIndex ops')+    transparentDefs _ _ = ([], [C.cinit|NULL|], Opaque)++    opaqueArrayDefs type_name rank et shape index =+      let array_name = type_name <> "_array"+          element_type_name = typeStructName et+          index_wrap = index <> "_wrap"+          is_args = [[C.cexp|is[$int:i]|] | i <- [0 .. rank - 1]]+       in ( [C.cunit|+              int $id:index_wrap(struct futhark_context *ctx,+                                       void *dest,+                                       typename $id:c_type_name arr,+                                       const typename int64_t *is) {+                return $id:index(ctx, dest, arr, $args:is_args);+              }+              const struct array $id:array_name = {+                .rank = $int:rank,+                .element_type = &$id:element_type_name,+                .new = NULL,+                .shape = (typename array_shape_fn)$id:shape,+                .index = (typename array_index_fn)$id:index_wrap,+              };|],+            [C.cinit|&$id:array_name|],+            Array+          )+ entryTypeBoilerplate :: Manifest -> ([C.Definition], [C.Initializer], [C.Definition]) entryTypeBoilerplate manifest =   second concat . unzip3 . map (typeBoilerplate manifest) . M.toList . manifestTypes $     manifest  oneEntryBoilerplate :: Manifest -> (T.Text, EntryPoint) -> ([C.Definition], C.Initializer)-oneEntryBoilerplate manifest (name, EntryPoint cfun tuning_params outputs inputs) =+oneEntryBoilerplate manifest (name, EntryPoint cfun tuning_params outputs inputs attrs) =   let call_f = "call_" <> nameFromText name       out_types = map outputType outputs       in_types = map inputType inputs@@ -228,6 +345,7 @@       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@@ -253,6 +371,10 @@                   $inits:(map textInit tuning_params),                   NULL                 };+                const char* $id:attrs_name[] = {+                  $inits:(map (textInit . prettyText) attrs),+                  NULL+                };                 int $id:call_f(struct futhark_context *ctx, void **outs, void **ins) {                   $items:out_items                   $items:in_items@@ -266,7 +388,8 @@             .in_types = $id:in_types_name,             .out_types = $id:out_types_name,             .in_unique = $id:in_unique_name,-            .out_unique = $id:out_unique_name+            .out_unique = $id:out_unique_name,+            .attrs = $id:attrs_name             }|]       )   where
src/Futhark/CodeGen/Backends/GenericC/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-}  -- | Code generation for public API types.@@ -46,15 +47,16 @@   CompilerM op s () prepareNewMem arr space shape pt = do   let rank = length shape-      arr_size = cproduct [[C.cexp|$exp:k|] | k <- shape]+      arr_size =+        cproduct [[C.cexp|$exp:arr->shape[$int:i]|] | i <- [0 .. length shape - 1]]   resetMem [C.cexp|$exp:arr->mem|] space+  forM_ (zip [0 .. rank - 1] shape) $ \(i, dim_s) ->+    stm [C.cstm|$exp:arr->shape[$int:i] = $exp:dim_s;|]   allocMem     [C.cexp|$exp:arr->mem|]     [C.cexp|$exp:arr_size * $int:(primByteSize pt::Int)|]     space     [C.cstm|err = 1;|]-  forM_ (zip [0 .. rank - 1] shape) $ \(i, dim_s) ->-    stm [C.cstm|$exp:arr->shape[$int:i] = $exp:dim_s;|]  arrayLibraryFunctions ::   Publicness ->@@ -492,7 +494,31 @@     sameShape param_names =       allTrue $ map allEqual $ L.transpose $ zipWith valueShape (map snd fs) param_names -recordArrayIndexFunctions ::+indexingDefs ::+  Int ->+  ([C.Param], PrimType -> Int -> C.Exp -> C.Exp, C.Exp)+indexingDefs rank =+  (index_params, indexExp, in_bounds)+  where+    index_names = ["i" <> prettyText i | i <- [0 .. rank - 1]]+    index_params = [[C.cparam|typename int64_t $id:k|] | k <- index_names]+    indexExp pt r shape =+      cproduct+        [ [C.cexp|$int:(primByteSize pt::Int)|],+          csum (zipWith (\x y -> [C.cexp|$id:x * $exp:y|]) index_names strides)+        ]+      where+        strides = do+          d <- [0 .. r - 1]+          pure $ cproduct [[C.cexp|$exp:shape[$int:i]|] | i <- [d + 1 .. r - 1]]++    in_bounds =+      allTrue+        [ [C.cexp|$id:p >= 0 && $id:p < arr->$id:(tupleField 0)->shape[$int:i]|]+        | (p, i) <- zip index_names [0 .. rank - 1]+        ]++recordArrayIndexFunction ::   Space ->   OpaqueTypes ->   Name ->@@ -500,7 +526,7 @@   Name ->   [ValueType] ->   CompilerM op s Manifest.CFuncName-recordArrayIndexFunctions space _types desc rank elemtype vds = do+recordArrayIndexFunction space _types desc rank elemtype vds = do   index_f <- publicName $ "index_" <> opaqueName desc   ctx_ty <- contextType   array_ct <- opaqueToCType desc@@ -532,30 +558,14 @@    pure index_f   where-    index_names = ["i" <> prettyText i | i <- [0 .. rank - 1]]-    index_params = [[C.cparam|typename int64_t $id:k|] | k <- index_names]-    indexExp pt r shape =-      cproduct-        [ [C.cexp|$int:(primByteSize pt::Int)|],-          csum (zipWith (\x y -> [C.cexp|$id:x * $exp:y|]) index_names strides)-        ]-      where-        strides = do-          d <- [0 .. r - 1]-          pure $ cproduct [[C.cexp|$exp:shape[$int:i]|] | i <- [d + 1 .. r - 1]]--    in_bounds =-      allTrue-        [ [C.cexp|$id:p >= 0 && $id:p < arr->$id:(tupleField 0)->shape[$int:i]|]-        | (p, i) <- zip index_names [0 .. rank - 1]-        ]+    (index_params, indexExp, in_bounds) = indexingDefs rank      setField copy j (ValueType _ (Rank r) pt)       | r == rank =           -- Easy case: just copy the scalar from the array into the           -- variable.           copy-            CopyNoBarrier+            CopyBarrier             [C.cexp|(unsigned char*)&v->$id:(tupleField j)|]             [C.cexp|0|]             DefaultSpace@@ -581,8 +591,86 @@             space             $ cproduct ([C.cexp|$int:(primByteSize pt::Int)|] : shape) -recordArrayShapeFunctions :: Name -> CompilerM op s Manifest.CFuncName-recordArrayShapeFunctions desc = do+recordArraySetFunction ::+  Space ->+  OpaqueTypes ->+  Name ->+  Int ->+  Name ->+  [ValueType] ->+  CompilerM op s Manifest.CFuncName+recordArraySetFunction space _types desc rank elemtype vds = do+  index_f <- publicName $ "set_" <> opaqueName desc+  ctx_ty <- contextType+  array_ct <- opaqueToCType desc+  obj_ct <- opaqueToCType elemtype+  copy <- asks $ opsCopy . envOperations++  set_items <- collect $ zipWithM_ (setField copy) [0 ..] vds++  headerDecl+    (OpaqueDecl desc)+    [C.cedecl|int $id:index_f($ty:ctx_ty *ctx,+                              $ty:array_ct *arr,+                              $ty:obj_ct *v,+                              $params:index_params);|]+  libDecl+    [C.cedecl|int $id:index_f($ty:ctx_ty *ctx,+                              $ty:array_ct *arr,+                              $ty:obj_ct *v,+                              $params:index_params) {+                int err = 0;+                if (!$exp:in_bounds) {+                  err = 1;+                  set_error(ctx, strdup("Index out of bounds."));+                } else if (!$exp:same_shape) {+                  err = 1;+                  set_error(ctx, strdup("Element shape differs from array shape"));+                } else {+                  $items:set_items+                }+                return err;+              }|]++  pure index_f+  where+    (index_params, indexExp, in_bounds) = indexingDefs rank++    same_shape = allTrue $ do+      (j, ValueType _ (Rank r) _) <- zip [0 ..] vds+      guard $ r > rank+      pure+        [C.cexp|memcmp(v->$id:(tupleField j)->shape,+                       &arr->$id:(tupleField j)->shape[$int:rank],+                       $int:(r-rank) * sizeof(int64_t)) == 0|]++    setField copy j (ValueType _ (Rank r) pt)+      | r == rank =+          copy+            CopyBarrier+            [C.cexp|arr->$id:(tupleField j)->mem.mem|]+            (indexExp pt rank [C.cexp|arr->$id:(tupleField j)->shape|])+            space+            [C.cexp|(unsigned char*)&v->$id:(tupleField j)|]+            [C.cexp|0|]+            DefaultSpace+            [C.cexp|$int:(primByteSize pt::Int)|]+      | otherwise = do+          let shape = do+                i <- [rank .. r - 1]+                pure [C.cexp|arr->$id:(tupleField j)->shape[$int:i]|]+          copy+            CopyNoBarrier+            [C.cexp|arr->$id:(tupleField j)->mem.mem|]+            (indexExp pt r [C.cexp|arr->$id:(tupleField j)->shape|])+            space+            [C.cexp|v->$id:(tupleField j)->mem.mem|]+            [C.cexp|0|]+            space+            $ cproduct ([C.cexp|$int:(primByteSize pt::Int)|] : shape)++recordArrayShapeFunction :: Name -> CompilerM op s Manifest.CFuncName+recordArrayShapeFunction desc = do   shape_f <- publicName $ "shape_" <> opaqueName desc   ctx_ty <- contextType   array_ct <- opaqueToCType desc@@ -601,7 +689,7 @@    pure shape_f -opaqueArrayIndexFunctions ::+recordArrayNewFunction ::   Space ->   OpaqueTypes ->   Name ->@@ -609,11 +697,147 @@   Name ->   [ValueType] ->   CompilerM op s Manifest.CFuncName-opaqueArrayIndexFunctions = recordArrayIndexFunctions+recordArrayNewFunction space types desc rank elemtype vds = do+  new_f <- publicName $ "new_" <> opaqueName desc+  ctx_ty <- contextType+  array_ct <- opaqueToCType desc+  obj_ct <- opaqueToCType elemtype+  copy <- asks $ opsCopy . envOperations+  ops <- asks envOperations -opaqueArrayShapeFunctions :: Name -> CompilerM op s Manifest.CFuncName-opaqueArrayShapeFunctions = recordArrayShapeFunctions+  check_items <- collect checkElemShapes +  alloc_items <- collect $ zipWithM_ allocateField [0 ..] vds++  set_items <- collect $ zipWithM_ (handleField copy) [0 ..] vds++  let end_items = [C.citems|end: *out = v;|]++  headerDecl+    (OpaqueDecl desc)+    [C.cedecl|int $id:new_f($ty:ctx_ty *ctx, $ty:array_ct **out,+                            $ty:obj_ct **elems, $params:shape_params);|]+  libDecl+    [C.cedecl|int $id:new_f($ty:ctx_ty *ctx, $ty:array_ct **out,+                            $ty:obj_ct **elems, $params:shape_params) {+                int err = 0;+                typename int64_t n = $exp:(cproduct outer_shape);+                $items:check_items+                if (err != 0) {+                  set_error(ctx, strdup("Cannot construct arrays with elements of different shapes."));+                  return 1;+                }+                $ty:array_ct* v = malloc(sizeof($ty:array_ct));+                $items:(criticalSection ops (alloc_items<>set_items<>end_items))+                return err;+              }|]++  pure new_f+  where+    elemtype' = lookupOpaqueType elemtype types+    shape_names = ["dim" <> prettyText i | i <- [0 .. rank - 1]]+    shape_params = [[C.cparam|typename int64_t $id:k|] | k <- shape_names]+    outer_shape = [[C.cexp|$id:k|] | k <- shape_names]++    allocateField i (ValueType _ (Rank r) pt) = do+      let shape =+            outer_shape+              ++ [ [C.cexp|n==0?0:elems[0]->$id:(tupleField i)->shape[$int:j]|]+                 | j <- [0 .. r - rank - 1]+                 ]++      stm [C.cstm|v->$id:(tupleField i) = malloc(sizeof(*v->$id:(tupleField i)));|]+      prepareNewMem [C.cexp|v->$id:(tupleField i)|] space shape pt+      stm+        [C.cstm|if (err != 0) {+                    free(v->$id:(tupleField i));+                    free(v);+                    v = NULL;+                    goto end;+                  }|]++    handleField copy i (ValueType _ (Rank r) pt) = do+      let elem_size =+            cproduct $+              [C.cexp|$int:(primByteSize pt::Int)|]+                : [ [C.cexp|v->$id:(tupleField i)->shape[$int:rank+$int:j]|]+                  | j <- [0 .. r - rank - 1]+                  ]++      copy_items <-+        collect $+          copy+            CopyNoBarrier+            [C.cexp|v->$id:(tupleField i)->mem.mem|]+            [C.cexp|i*$exp:elem_size|]+            space+            ( if r == rank+                then [C.cexp|(unsigned char*)&elems[i]->$id:(tupleField i)|]+                else [C.cexp|elems[i]->$id:(tupleField i)->mem.mem|]+            )+            [C.cexp|0|]+            (if r == rank then DefaultSpace else space)+            elem_size++      stm+        [C.cstm|for (typename int64_t i = 0; i < n; i++) {+                  $items:copy_items+                  if (err != 0) {+                    goto end;+                  }+                }|]++    checkSameShape x y = do+      forM_ (zip [0 ..] (opaquePayload types elemtype')) $ \case+        (fi, ValueType _ (Rank r) _) -> do+          let fi' = tupleField fi+          forM_ [0 .. r - 1] $ \i ->+            stm+              [C.cstm|if ($exp:x->$id:fi'->shape[$int:i]+                          !=+                          $exp:y->$id:fi'->shape[$int:i]) {+                          err = 1;+                      }|]++    checkElemShapes = do+      check_one <- collect $ checkSameShape [C.cexp|elems[0]|] [C.cexp|elems[i]|]+      stm+        [C.cstm|for (typename int64_t i = 1; i < n; i++)+                { $items:check_one }|]++opaqueArrayIndexFunction ::+  Space ->+  OpaqueTypes ->+  Name ->+  Int ->+  Name ->+  [ValueType] ->+  CompilerM op s Manifest.CFuncName+opaqueArrayIndexFunction = recordArrayIndexFunction++opaqueArrayShapeFunction :: Name -> CompilerM op s Manifest.CFuncName+opaqueArrayShapeFunction = recordArrayShapeFunction++opaqueArrayNewFunction ::+  Space ->+  OpaqueTypes ->+  Name ->+  Int ->+  Name ->+  [ValueType] ->+  CompilerM op s Manifest.CFuncName+opaqueArrayNewFunction = recordArrayNewFunction++opaqueArraySetFunction ::+  Space ->+  OpaqueTypes ->+  Name ->+  Int ->+  Name ->+  [ValueType] ->+  CompilerM op s Manifest.CFuncName+opaqueArraySetFunction = recordArraySetFunction+ sumVariants ::   Name ->   [(Name, [(EntryPointType, [Int])])] ->@@ -806,14 +1030,18 @@     <$> ( Manifest.RecordArrayOps rank (nameToText elemtype)             <$> recordArrayProjectFunctions types desc fs vds             <*> recordArrayZipFunctions types desc fs vds rank-            <*> recordArrayIndexFunctions space types desc rank elemtype vds-            <*> recordArrayShapeFunctions desc+            <*> recordArrayIndexFunction space types desc rank elemtype vds+            <*> recordArrayShapeFunction desc+            <*> recordArrayNewFunction space types desc rank elemtype vds+            <*> recordArraySetFunction space types desc rank elemtype vds         ) opaqueExtraOps space types desc (OpaqueArray rank elemtype _) vds =   Just . Manifest.OpaqueArray     <$> ( Manifest.OpaqueArrayOps rank (nameToText elemtype)-            <$> opaqueArrayIndexFunctions space types desc rank elemtype vds-            <*> opaqueArrayShapeFunctions desc+            <$> opaqueArrayIndexFunction space types desc rank elemtype vds+            <*> opaqueArrayShapeFunction desc+            <*> opaqueArrayNewFunction space types desc rank elemtype vds+            <*> opaqueArraySetFunction space types desc rank elemtype vds         )  opaqueLibraryFunctions ::
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -537,7 +537,7 @@   mapM_ atInit =<< collect (compileCode init_consts)  compileFunc :: (Name, Imp.Function op) -> CompilerM op s PyFunDef-compileFunc (fname, Imp.Function _ outputs inputs body) = do+compileFunc (fname, Imp.Function _ outputs inputs _ body) = do   body' <- collect $ compileCode body   let inputs' = map (compileName . Imp.paramName) inputs   let ret = Return $ tupleOrSingle $ compileOutput outputs@@ -840,7 +840,7 @@       [PyStmt],       [(Imp.ExternalValue, PyExp)]     )-prepareEntry (Imp.EntryPoint _ results args) (fname, Imp.Function _ outputs inputs _) = do+prepareEntry (Imp.EntryPoint _ results args) (fname, Imp.Function _ outputs inputs _ _) = do   let output_paramNames = map (compileName . Imp.paramName) outputs       funTuple = tupleOrSingle $ fmap Var output_paramNames @@ -938,8 +938,8 @@   [PyStmt] ->   (Name, Imp.Function op) ->   CompilerM op s (Maybe (PyFunDef, T.Text, PyExp))-callEntryFun _ (_, Imp.Function Nothing _ _ _) = pure Nothing-callEntryFun pre_timing fun@(fname, Imp.Function (Just entry) _ _ _) = do+callEntryFun _ (_, Imp.Function Nothing _ _ _ _) = pure Nothing+callEntryFun pre_timing fun@(fname, Imp.Function (Just entry) _ _ _ _) = do   let Imp.EntryPoint ename _ decl_args = entry   (_, prepare_in, body_bin, _, res) <- prepareEntry entry fun
src/Futhark/CodeGen/Backends/GenericPython/AST.hs view
@@ -197,7 +197,7 @@     "class"       <+> pretty cname       <> ":"-        </> indent 2 (stack (map pretty body))+        </> indent 2 (stack $ punctuate line $ map pretty body)  instance Pretty PyExcept where   pretty (Catch pyexp stms) =@@ -207,4 +207,4 @@       </> indent 2 (vsep $ map pretty stms)  instance Pretty PyProg where-  pretty (PyProg stms) = vsep (map pretty stms)+  pretty (PyProg stms) = stack $ punctuate line $ map pretty stms
src/Futhark/CodeGen/Backends/MulticoreC.hs view
@@ -88,70 +88,70 @@  closureFreeStructField :: VName -> Name closureFreeStructField v =-  nameFromString "free_" <> nameFromString (prettyString v)+  nameFromString "free_" <> nameFromText (prettyText v)  closureRetvalStructField :: VName -> Name closureRetvalStructField v =-  nameFromString "retval_" <> nameFromString (prettyString v)+  nameFromString "retval_" <> nameFromText (prettyText v)  data ValueType = Prim PrimType | MemBlock | RawMem -compileFreeStructFields :: [VName] -> [(C.Type, ValueType)] -> [C.FieldGroup]+compileFreeStructFields :: [VName] -> [(C.Type, C.Type, ValueType)] -> [C.FieldGroup] compileFreeStructFields = zipWith field   where-    field name (ty, Prim _) =-      [C.csdecl|$ty:ty $id:(closureFreeStructField name);|]-    field name (_, _) =+    field name (_, storage_ty, Prim _) =+      [C.csdecl|$ty:storage_ty $id:(closureFreeStructField name);|]+    field name (_, _, _) =       [C.csdecl|$ty:defaultMemBlockType $id:(closureFreeStructField name);|] -compileRetvalStructFields :: [VName] -> [(C.Type, ValueType)] -> [C.FieldGroup]+compileRetvalStructFields :: [VName] -> [(C.Type, C.Type, ValueType)] -> [C.FieldGroup] compileRetvalStructFields = zipWith field   where-    field name (ty, Prim _) =+    field name (ty, _, Prim _) =       [C.csdecl|$ty:ty *$id:(closureRetvalStructField name);|]-    field name (_, _) =+    field name (_, _, _) =       [C.csdecl|$ty:defaultMemBlockType $id:(closureRetvalStructField name);|]  compileSetStructValues ::   (C.ToIdent a) =>   a ->   [VName] ->-  [(C.Type, ValueType)] ->+  [(C.Type, C.Type, ValueType)] ->   [C.Stm] compileSetStructValues struct = zipWith field   where-    field name (_, Prim pt) =+    field name (_, _, Prim pt) =       [C.cstm|$id:struct.$id:(closureFreeStructField name)=$exp:(toStorage pt (C.toExp name noLoc));|]-    field name (_, MemBlock) =+    field name (_, _, MemBlock) =       [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name.mem;|]-    field name (_, RawMem) =+    field name (_, _, RawMem) =       [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name;|]  compileSetRetvalStructValues ::   (C.ToIdent a) =>   a ->   [VName] ->-  [(C.Type, ValueType)] ->+  [(C.Type, C.Type, ValueType)] ->   [C.Stm] compileSetRetvalStructValues struct vnames we = concat $ zipWith field vnames we   where-    field name (ct, Prim _) =+    field name (ct, _, Prim _) =       [C.cstms|$id:struct.$id:(closureRetvalStructField name)=(($ty:ct*)&$id:name);                $escstm:("#if defined(ISPC)")                $id:struct.$id:(closureRetvalStructField name)+= programIndex;                $escstm:("#endif")|]-    field name (_, MemBlock) =+    field name (_, _, MemBlock) =       [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name.mem;|]-    field name (_, RawMem) =+    field name (_, _, RawMem) =       [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name;|] -compileGetRetvalStructVals :: (C.ToIdent a) => a -> [VName] -> [(C.Type, ValueType)] -> [C.InitGroup]+compileGetRetvalStructVals :: (C.ToIdent a) => a -> [VName] -> [(C.Type, C.Type, ValueType)] -> [C.InitGroup] compileGetRetvalStructVals struct = zipWith field   where-    field name (ty, Prim pt) =+    field name (ty, _storage_ty, Prim _) =       let inner = [C.cexp|*$id:struct->$id:(closureRetvalStructField name)|]-       in [C.cdecl|$ty:ty $id:name = $exp:(fromStorage pt inner);|]-    field name (ty, _) =+       in [C.cdecl|$ty:ty $id:name = $exp:inner;|]+    field name (ty, _, _) =       [C.cdecl|$ty:ty $id:name =                  {.desc = $string:(prettyString name),                  .mem = $id:struct->$id:(closureRetvalStructField name),@@ -161,32 +161,33 @@   (C.ToIdent a) =>   a ->   [VName] ->-  [(C.Type, ValueType)] ->+  [(C.Type, C.Type, ValueType)] ->   [C.InitGroup] compileGetStructVals struct = zipWith field   where-    field name (ty, Prim pt) =+    field name (ty, _storage_ty, Prim pt) =       let inner = [C.cexp|$id:struct->$id:(closureFreeStructField name)|]        in [C.cdecl|$ty:ty $id:name = $exp:(fromStorage pt inner);|]-    field name (ty, _) =+    field name (ty, _, _) =       [C.cdecl|$ty:ty $id:name =                  {.desc = $string:(prettyString name),                   .mem = $id:struct->$id:(closureFreeStructField name),                   .size = 0, .references = NULL};|] -compileWriteBackResVals :: (C.ToIdent a) => a -> [VName] -> [(C.Type, ValueType)] -> [C.Stm]+compileWriteBackResVals :: (C.ToIdent a) => a -> [VName] -> [(C.Type, C.Type, ValueType)] -> [C.Stm] compileWriteBackResVals struct = zipWith field   where-    field name (_, Prim pt) =-      [C.cstm|*$id:struct->$id:(closureRetvalStructField name) = $exp:(toStorage pt (C.toExp name noLoc));|]-    field name (_, _) =+    field name (_, _, Prim _) =+      [C.cstm|*$id:struct->$id:(closureRetvalStructField name) = $exp:(C.toExp name noLoc);|]+    field name (_, _, _) =       [C.cstm|$id:struct->$id:(closureRetvalStructField name) = $id:name.mem;|] -paramToCType :: Param -> GC.CompilerM op s (C.Type, ValueType)-paramToCType (ScalarParam _ pt) = do-  let t = primStorageType pt-  pure (t, Prim pt)-paramToCType (MemParam name space') = mcMemToCType name space'+paramToCType :: Param -> GC.CompilerM op s (C.Type, C.Type, ValueType)+paramToCType (ScalarParam _ pt) =+  pure (primTypeToCType pt, primStorageType pt, Prim pt)+paramToCType (MemParam name space') = do+  (ct, vt) <- mcMemToCType name space'+  pure (ct, ct, vt)  mcMemToCType :: VName -> Space -> GC.CompilerM op s (C.Type, ValueType) mcMemToCType v space = do@@ -252,8 +253,8 @@   Name ->   MCCode ->   a ->-  [(VName, (C.Type, ValueType))] ->-  [(VName, (C.Type, ValueType))] ->+  [(VName, (C.Type, C.Type, ValueType))] ->+  [(VName, (C.Type, C.Type, ValueType))] ->   GC.CompilerM Multicore s Name generateParLoopFn lexical basename code fstruct free retval = do   let (fargs, fctypes) = unzip free@@ -286,9 +287,9 @@   DefSpecifier s ->   Name ->   [VName] ->-  [(C.Type, ValueType)] ->+  [(C.Type, C.Type, ValueType)] ->   [VName] ->-  [(C.Type, ValueType)] ->+  [(C.Type, C.Type, ValueType)] ->   GC.CompilerM Multicore s Name prepareTaskStruct def name free_args free_ctypes retval_args retval_ctypes = do   let makeStruct s =@@ -326,7 +327,7 @@    e' <- GC.compileExp e -  let lexical = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] params seq_code+  let lexical = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] params mempty seq_code    fstruct <-     prepareTaskStruct multicoreDef "task" free_args free_ctypes retval_args retval_ctypes@@ -351,7 +352,7 @@   -- Generate the nested segop function if available   case par_task of     Just (ParallelTask nested_code) -> do-      let lexical_nested = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] params nested_code+      let lexical_nested = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] params mempty nested_code       fnpar_task <- generateParLoopFn lexical_nested (name <> "_nested_task") nested_code fstruct free retval       GC.stm [C.cstm|$id:ftask_name.nested_fn = $id:fnpar_task;|]     Nothing ->@@ -370,7 +371,7 @@   free_ctypes <- mapM paramToCType free   let free_args = map paramName free -  let lexical = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] free body+  let lexical = lexicalMemoryUsageMC TraverseKernels $ Function Nothing [] free mempty body    fstruct <-     prepareTaskStruct multicoreDef (s' <> "_parloop_struct") free_args free_ctypes mempty mempty
src/Futhark/CodeGen/Backends/MulticoreISPC.hs view
@@ -205,7 +205,7 @@ -- it in ISPC, both in a varying or uniform context. This involves handling -- for the fact that ISPC cannot pass structs by value to external functions. compileBuiltinFun :: (Name, Function op) -> ISPCCompilerM ()-compileBuiltinFun (fname, func@(Function _ outputs inputs _))+compileBuiltinFun (fname, func@(Function _ outputs inputs _ _))   | isNothing $ functionEntry func = do       let extra = [[C.cparam|$tyqual:uniform struct futhark_context * $tyqual:uniform ctx|]]           extra_c = [[C.cparam|struct futhark_context * ctx|]]@@ -699,15 +699,15 @@ compileGetStructVals ::   Name ->   [VName] ->-  [(C.Type, MC.ValueType)] ->+  [(C.Type, C.Type, MC.ValueType)] ->   ISPCCompilerM [C.BlockItem] compileGetStructVals struct a b = concat <$> zipWithM field a b   where     struct' = struct <> "_"-    field name (ty, MC.Prim pt) = do+    field name (ty, _, MC.Prim pt) = do       let inner = [C.cexp|$id:struct'->$id:(MC.closureFreeStructField name)|]       pure [C.citems|$tyqual:uniform $ty:ty $id:name = $exp:(fromStorage pt inner);|]-    field name (_, _) = do+    field name (_, _, _) = do       strlit <- makeStringLiteral $ prettyString name       pure         [C.citems|$tyqual:uniform struct memblock $id:name;@@ -746,7 +746,7 @@    e' <- compileExp e -  let lexical = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] params seq_code+  let lexical = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] params mempty seq_code    fstruct <-     MC.prepareTaskStruct sharedDef "task" free_args free_ctypes retval_args retval_ctypes@@ -773,7 +773,7 @@     -- Generate the nested segop function if available     case par_task of       Just (ParallelTask nested_code) -> do-        let lexical_nested = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] params nested_code+        let lexical_nested = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] params mempty nested_code         fnpar_task <-           MC.generateParLoopFn             lexical_nested@@ -825,7 +825,7 @@   free_ctypes <- mapM MC.paramToCType free   let free_args = map paramName free -  let lexical = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] free body+  let lexical = lexicalMemoryUsageMC OpaqueKernels $ Function Nothing [] free mempty body   -- Generate ISPC kernel   fstruct <- MC.prepareTaskStruct sharedDef "param_struct" free_args free_ctypes [] []   let fstruct' = fstruct <> "_"
src/Futhark/CodeGen/Backends/MulticoreWASM.hs view
@@ -66,8 +66,8 @@ fRepMyRep :: Imp.Definitions Imp.Multicore -> [JSEntryPoint] fRepMyRep prog =   let Imp.Functions fs = Imp.defFuns prog-      function (Imp.Function entry _ _ _) = do-        Imp.EntryPoint n res args <- entry+      function fun = do+        Imp.EntryPoint n res args <- Imp.functionEntry fun         Just $           JSEntryPoint             { name = nameToString n,
src/Futhark/CodeGen/Backends/PyOpenCL.hs view
@@ -315,18 +315,17 @@             ArgKeyword "dtype" (Var $ compilePrimType bt)           ]   stm $ Assign val' nparr-  stm $-    Exp $-      Call-        (Var "cl.enqueue_copy")-        [ Arg $ Var "self.queue",-          Arg val',-          Arg mem,-          ArgKeyword "src_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt),-          ArgKeyword "is_blocking" $ Var "synchronous"-        ]+  stm . Exp $+    Call+      (Var "cl.enqueue_copy")+      [ Arg $ Var "self.queue",+        Arg val',+        Arg mem,+        ArgKeyword "src_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt),+        ArgKeyword "is_blocking" $ Var "synchronous"+      ]   stm $ Exp $ simpleCall "sync" [Var "self"]-  pure $ Index val' $ IdxExp $ Integer 0+  pure $ fromStorage bt $ Index val' $ IdxExp $ Integer 0 readOpenCLScalar _ _ _ space =   error $ "Cannot read from '" ++ space ++ "' memory space."
src/Futhark/CodeGen/Backends/SequentialWASM.hs view
@@ -60,7 +60,7 @@ fRepMyRep :: Imp.Program -> [JSEntryPoint] fRepMyRep prog =   let Imp.Functions fs = Imp.defFuns prog-      function (Imp.Function entry _ _ _) = do+      function (Imp.Function entry _ _ _ _) = do         Imp.EntryPoint n res args <- entry         Just $           JSEntryPoint
src/Futhark/CodeGen/ImpCode.hs view
@@ -113,7 +113,8 @@ import Futhark.IR.Pretty () import Futhark.IR.Prop.Names import Futhark.IR.Syntax.Core-  ( EntryPointType (..),+  ( Attrs (..),+    EntryPointType (..),     ErrorMsg (..),     ErrorMsgPart (..),     OpaqueType (..),@@ -228,6 +229,7 @@   { functionEntry :: Maybe EntryPoint,     functionOutput :: [Param],     functionInput :: [Param],+    functionAttrs :: Attrs,     functionBody :: Code a   }   deriving (Show)@@ -524,11 +526,12 @@       ppRes (u, t) = pretty u <> pretty t  instance (Pretty op) => Pretty (FunctionT op) where-  pretty (Function entry outs ins body) =+  pretty (Function entry outs ins attrs body) =     stack       [ "inputs" <+> nestedBlock (stack $ map pretty ins),         "outputs" <+> nestedBlock (stack $ map pretty outs),         "entry" <+> nestedBlock (pretty entry),+        "attributes" <+> nestedBlock (pretty attrs),         "body" <+> nestedBlock (pretty body)       ] @@ -706,8 +709,8 @@   foldMap = foldMapDefault  instance Traversable FunctionT where-  traverse f (Function entry outs ins body) =-    Function entry outs ins <$> traverse f body+  traverse f (Function entry outs ins attrs body) =+    Function entry outs ins attrs <$> traverse f body  instance Functor Code where   fmap = fmapDefault
src/Futhark/CodeGen/ImpGen.hs view
@@ -689,7 +689,7 @@   OpaqueTypes ->   FunDef rep ->   ImpM rep r op ()-compileFunDef types (FunDef entry _ fname rettype params body) =+compileFunDef types (FunDef entry attrs fname rettype params body) =   local (\env -> env {envFunction = name_entry `mplus` Just fname}) $ do     ((outparams, inparams, results, args), body') <- collect' compile     let entry' = case (name_entry, results, args) of@@ -697,7 +697,7 @@             Just $ Imp.EntryPoint name_entry' results' args'           _ ->             Nothing-    emitFunction fname $ Imp.Function entry' outparams inparams body'+    emitFunction fname $ Imp.Function entry' outparams inparams attrs body'   where     (name_entry, params_entry, ret_entry) = case entry of       Nothing -> (Nothing, Nothing, Nothing)@@ -1927,7 +1927,7 @@   body <- collect $ do     mapM_ addParam $ outputs ++ inputs     m-  emitFunction fname $ Imp.Function Nothing outputs inputs body+  emitFunction fname $ Imp.Function Nothing outputs inputs mempty body   where     addParam (Imp.MemParam name space) =       addVar name $ MemVar Nothing $ MemEntry space
src/Futhark/CodeGen/ImpGen/GPU.hs view
@@ -197,7 +197,7 @@    -- If any of the sizes involve a variable that is not known at this   -- point, then we cannot check the requirements.-  if not $ all in_scope $ namesToList $ freeIn alloc_sizes+  if not $ allNames in_scope $ freeIn alloc_sizes     then pure Nothing     else do       shared_memory_capacity :: TV Int64 <- dPrim "shared_memory_capacity"
src/Futhark/CodeGen/ImpGen/GPU/Base.hs view
@@ -912,10 +912,12 @@             )           _ -> (id, id) -      int-        | primBitSize t == 16 = int16-        | primBitSize t == 32 = int32-        | otherwise = int64+      int = case primBitSize t of+        8 -> int8+        16 -> int16+        32 -> int32+        64 -> int64+        _ -> error "impossible integer bit size"    sWhile (tvExp run_loop) $ do     assumed <~~ Imp.var old t@@ -1055,7 +1057,7 @@ simpleKernelBlocks max_num_tblocks kernel_size = do   tblock_size <- dPrim "tblock_size"   fname <- askFunction-  let tblock_size_key = keyWithEntryPoint fname $ nameFromString $ prettyString $ tvVar tblock_size+  let tblock_size_key = keyWithEntryPoint fname $ nameFromText $ prettyText $ tvVar tblock_size   addTuningParam tblock_size_key $ Just Imp.SizeThreadBlock   sOp $ Imp.GetSize (tvVar tblock_size) tblock_size_key Imp.SizeThreadBlock   virt_num_tblocks <- dPrimVE "virt_num_tblocks" $ kernel_size `divUp` tvExp tblock_size
src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs view
@@ -222,7 +222,7 @@       lmem <- sAlloc "local_mem" lmem_total_size (Space "shared")       let arrInLMem ptype name len_se offset =             sArray-              (name <> "_" <> nameFromString (prettyString ptype))+              (name <> "_" <> nameFromText (prettyText ptype))               ptype               (Shape [len_se])               lmem
src/Futhark/Compiler.hs view
@@ -11,6 +11,7 @@     module Futhark.Compiler.Config,     readProgramFile,     readProgramFiles,+    readProgramFilesExceptKnown,     readProgramOrDie,     readUntypedProgram,     readUntypedProgramOrDie,@@ -24,6 +25,7 @@ import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Loc (Loc (..), posCoff, posFile)+import Data.Map qualified as M import Data.Text.IO qualified as T import Futhark.Analysis.Alias qualified as Alias import Futhark.Compiler.Config@@ -171,11 +173,21 @@ -- including all imports. readProgramFiles ::   (MonadError CompilerError m, MonadIO m) =>+  [Name] ->+  [FilePath] ->+  m (Warnings, Imports, VNameSource)+readProgramFiles extra_eps = readProgramFilesExceptKnown extra_eps M.empty++-- | Read and type-check a Futhark library, comprising multiple files,+-- including all imports. Use a VFS cache for IO.+readProgramFilesExceptKnown ::+  (MonadError CompilerError m, MonadIO m) =>   [I.Name] ->+  VFS ->   [FilePath] ->   m (Warnings, Imports, VNameSource)-readProgramFiles extra_eps =-  throwOnProgError <=< liftIO . readLibrary extra_eps+readProgramFilesExceptKnown extra_eps vfs files =+  throwOnProgError <=< liftIO $ readLibraryExceptKnown extra_eps files vfs  -- | Read and parse (but do not type-check) a Futhark program, -- including all imports.
src/Futhark/Compiler/Program.hs view
@@ -4,6 +4,7 @@ -- more high-level API. module Futhark.Compiler.Program   ( readLibrary,+    readLibraryExceptKnown,     readUntypedLibrary,     Imports,     FileModule (..),@@ -441,13 +442,25 @@   [E.Name] ->   -- | The files to read.   [FilePath] ->+  IO (Either (NE.NonEmpty ProgError) (Warnings, Imports, VNameSource))+readLibrary extra_eps fps = readLibraryExceptKnown extra_eps fps M.empty++-- | Read and type-check some Futhark files.+readLibraryExceptKnown ::+  -- | Extra functions that should be marked as entry points; only+  -- applies to the immediate files, not any imports imported.+  [E.Name] ->+  -- | The files to read.+  [FilePath] ->+  -- | Files which are already cached+  VFS ->   IO (Either (NE.NonEmpty ProgError) (E.Warnings, Imports, VNameSource))-readLibrary extra_eps fps =+readLibraryExceptKnown extra_eps fps vfs =   ( fmap frob       . typeCheckProg mempty (lpNameSource noLoadedProg)       <=< fmap (setEntryPoints (E.defaultEntryPoint : extra_eps) fps)   )-    <$> readUntypedLibraryExceptKnown [] M.empty fps+    <$> readUntypedLibraryExceptKnown [] vfs fps   where     frob (y, z) = (foldMap (cfWarnings . lfMod) y, asImports y, z)
+ src/Futhark/Eval.hs view
@@ -0,0 +1,169 @@+module Futhark.Eval+  ( InterpreterConfig (..),+    runExpr,+    interpreterConfig,+    newFutharkiState,+    Evaluation (..),+    EvalRecordRef (),+    runEvalRecordRef,+  )+where++import Control.Exception (IOException, catch)+import Control.Monad (foldM, when, (<=<))+import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.Free.Church (F, runF)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)+import Data.IORef (IORef, modifyIORef')+import Data.Map qualified as M+import Data.Maybe (maybeToList)+import Data.Sequence (Seq, (|>))+import Data.Text qualified as T+import Futhark.Compiler (prettyWarnings, readProgramFilesExceptKnown)+import Futhark.Compiler.Program (VFS, fileProg, fileScope)+import Futhark.Error (externalErrorS, prettyCompilerError)+import Futhark.FreshNames (VNameSource)+import Futhark.Util.Pretty (commasep, hPutDoc, hPutDocLn, hardline, putDocLn)+import Language.Futhark.Interpreter qualified as I+import Language.Futhark.Parser (parseExp)+import Language.Futhark.Parser.Monad (SyntaxError (SyntaxError))+import Language.Futhark.Pretty (toName)+import Language.Futhark.Prop (typeOf)+import Language.Futhark.Semantic qualified as T+import Language.Futhark.Syntax (nameToText, typeParamName)+import Language.Futhark.TypeChecker qualified as T+import Prettyprinter (Doc, align, pretty, unAnnotate, vcat, (<+>))+import Prettyprinter.Render.Terminal (AnsiStyle)+import System.Exit (ExitCode (ExitFailure), exitWith)+import System.IO (stderr)++-- | The class of monads that can perform expression evaluation.+class (Monad m) => Evaluation m where+  abort :: Doc AnsiStyle -> m b+  trace :: Doc AnsiStyle -> m ()++instance (Evaluation m) => Evaluation (ExceptT (Doc AnsiStyle) m) where+  trace :: Doc AnsiStyle -> ExceptT e m ()+  trace = lift . trace++  abort = throwError++instance Evaluation IO where+  abort reason = do+    hPutDocLn stderr reason+    exitWith $ ExitFailure 1++  trace = putDocLn++newtype EvalRecordRef a+  = EvalRecordRef+      (ExceptT (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) a)+  deriving (Functor, Applicative, Monad, MonadIO)++instance Evaluation EvalRecordRef where+  abort :: Doc AnsiStyle -> EvalRecordRef b+  abort = EvalRecordRef . throwError++  trace :: Doc AnsiStyle -> EvalRecordRef ()+  trace message = EvalRecordRef $ do+    messagesRef <- lift ask+    liftIO $ modifyIORef' messagesRef (|> message)++runEvalRecordRef ::+  IORef (Seq (Doc AnsiStyle)) ->+  EvalRecordRef a ->+  IO (Either (Doc AnsiStyle) a)+runEvalRecordRef msgRef (EvalRecordRef action) =+  flip runReaderT msgRef $ runExceptT action++newtype InterpreterState = InterpreterState (VNameSource, T.Env, I.Ctx)++-- | Run an expression in the given interpreter state. The expression is parsed,+-- type checked, and then run. Returns a prettyprinted result. Must be run in a+-- monad that supports aborting and traces.+runExpr ::+  (Evaluation m) =>+  InterpreterState ->+  T.Text ->+  m (Doc AnsiStyle)+runExpr (InterpreterState (src, env, ctx)) str = do+  uexp <- case parseExp "" str of+    Left (SyntaxError _ serr) -> abort $ pretty serr+    Right e -> pure e+  fexp <- case T.checkExp [] src env uexp of+    (_, Left terr) -> do+      abort $ T.prettyTypeError terr+    (_, Right ([], e)) -> pure e+    (_, Right (tparams, e)) ->+      abort $+        vcat+          [ "Inferred type of expression: " <> align (pretty (typeOf e)),+            "The following types are ambiguous: "+              <> commasep (map (pretty . nameToText . toName . typeParamName) tparams)+          ]+  pval <- runInterpreterNoBreak $ I.interpretExp ctx fexp+  case pval of+    Left err -> do+      abort $ I.prettyInterpreterError err+    Right val -> pure $ I.prettyValue val <> hardline++data InterpreterConfig = InterpreterConfig+  { interpreterPrintWarnings :: Bool,+    interpreterFile :: Maybe String+  }++interpreterConfig :: InterpreterConfig+interpreterConfig = InterpreterConfig True Nothing++newFutharkiState ::+  (MonadIO m, Evaluation m) =>+  InterpreterConfig ->+  Maybe FilePath ->+  VFS ->+  m (Either (Doc AnsiStyle) InterpreterState)+newFutharkiState cfg maybe_file vfs = runExceptT $ do+  (ws, imports, src) <-+    badOnLeft prettyCompilerError+      =<< liftIO+        ( runExceptT (readProgramFilesExceptKnown [] vfs $ maybeToList maybe_file)+            `catch` \(err :: IOException) ->+              pure (externalErrorS (show err))+        )+  when (interpreterPrintWarnings cfg) $+    liftIO $+      hPutDoc stderr $+        prettyWarnings ws++  ictx <-+    let foldFile ctx =+          badOnLeft I.prettyInterpreterError+            <=< runInterpreterNoBreak+              . I.interpretImport ctx+     in foldM foldFile I.initialCtx $+          map (fmap fileProg) imports++  let (tenv, ienv) =+        let (iname, fm) = last imports+         in ( fileScope fm,+              ictx {I.ctxEnv = I.ctxImports ictx M.! iname}+            )++  pure $ InterpreterState (src, tenv, ienv)+  where+    badOnLeft :: (Monad m) => (err -> err') -> Either err a -> ExceptT err' m a+    badOnLeft _ (Right x) = pure x+    badOnLeft p (Left err) = throwError $ p err++runInterpreterNoBreak ::+  (Evaluation m) =>+  F I.ExtOp a ->+  m (Either I.InterpreterError a)+runInterpreterNoBreak m = runF m (pure . Right) intOp+  where+    intOp (I.ExtOpError err) = pure $ Left err+    intOp (I.ExtOpTrace w v c) = do+      trace $ pretty w <> ":" <+> align (unAnnotate v)+      c+    intOp (I.ExtOpBreak _ _ _ c) = c
src/Futhark/Fmt/Printer.hs view
@@ -230,16 +230,21 @@ updates ::   UncheckedExp ->   (UncheckedExp, [(Fmt, Fmt)])-updates (RecordUpdate src fs ve _ _) = second (++ [(fs', ve')]) $ updates src-  where-    fs' = sep "." $ fmt <$> fs-    ve' = fmt ve-updates (Update src is ve _) = second (++ [(is', ve')]) $ updates src+updates (Update src steps ve _ _) = second (++ [(steps', ve')]) $ updates src   where-    is' = brackets $ sep ("," <> space) $ map fmt is+    steps' = fmtUpdatePath steps     ve' = fmt ve updates e = (e, []) +fmtUpdatePath :: [UpdateStep NoInfo Name] -> Fmt+fmtUpdatePath = go True+  where+    go _ [] = nil+    go first (UpdateStepField f : rest) =+      (if first then fmt f else "." <> fmt f) <> go False rest+    go _ (UpdateStepSlice is : rest) =+      brackets (sep ("," <> space) $ map fmt is) <> go False rest+ fmtUpdate :: UncheckedExp -> Fmt fmtUpdate e =   -- Special case multiple chained Updates/RecordUpdates.@@ -271,7 +276,6 @@   fmt (Negate e loc) = addComments loc $ "-" <> fmt e   fmt (Not e loc) = addComments loc $ "!" <> fmt e   fmt e@Update {} = fmtUpdate e-  fmt e@RecordUpdate {} = fmtUpdate e   fmt (Assert e1 e2 _ loc) =     addComments loc $ "assert" <+> fmt e1 </> fmt e2   fmt (Lambda params body rettype _ loc) =@@ -289,12 +293,12 @@     addComments loc $ parens $ fmt x <+> fmtBinOp binop   fmt (OpSectionRight binop _ x _ _ loc) =     addComments loc $ parens $ fmtBinOp binop <+> fmt x-  fmt (ProjectSection fields _ loc) =-    addComments loc $ parens $ "." <> sep "." (fmt <$> fields)-  fmt (IndexSection idxs _ loc) =-    addComments loc $ parens ("." <> idxs')+  fmt (UpdateSection steps _ loc) =+    addComments loc $ parens $ mconcat (zipWith step [0 :: Int ..] steps)     where-      idxs' = brackets $ sep ("," <> space) $ map fmt idxs+      step _ (UpdateStepField f) = "." <> fmt f+      step 0 (UpdateStepSlice is) = "." <> brackets (sep ("," <> space) $ map fmt is)+      step _ (UpdateStepSlice is) = brackets (sep ("," <> space) $ map fmt is)   fmt (Constr n [] _ loc) =     addComments loc $ "#" <> fmt n   fmt (Constr n cs _ loc) =@@ -387,14 +391,14 @@         | null tparams = space <> params'         | null params = space <> tparams'         | otherwise = space <> tparams' <+> params'-  fmt (LetWith dest src idxs ve body loc)+  fmt (LetWith dest src steps ve body loc)     | dest == src =         addComments loc $           lineIndent             ve             ( "let"                 <+> fmt dest-                <> idxs'+                <> fmtLetLhsUpdatePath steps                   <+> "="             )             (fmt ve)@@ -408,12 +412,10 @@                 <+> "="                 <+> fmt src                 <+> "with"-                <+> idxs'+                <+> fmtUpdatePath steps             )             (fmt ve)             </> letBody body-    where-      idxs' = brackets $ sep ", " $ map fmt idxs   fmt (Range start maybe_step end loc) =     addComments loc $ fmt start <> step <> end'     where@@ -437,6 +439,12 @@     addComments loc $ fmt f <+> fmt_args     where       fmt_args = sepArgs fmt $ fmap snd args++fmtLetLhsUpdatePath :: [UpdateStep NoInfo Name] -> Fmt+fmtLetLhsUpdatePath = mconcat . map step+  where+    step (UpdateStepSlice is) = brackets (sep ("," <> space) $ map fmt is)+    step (UpdateStepField f) = "." <> fmt f  letBody :: UncheckedExp -> Fmt letBody body@(AppExp LetPat {} _) = fmt body
src/Futhark/IR/GPU/Sizes.hs view
@@ -37,8 +37,6 @@   | -- | Likely not useful on its own, but querying the     -- maximum can be handy.     SizeSharedMemory-  | -- | A bespoke size with a default.-    SizeBespoke Name Int64   | -- | Amount of registers available per threadblock. Mostly     -- meaningful for querying the maximum.     SizeRegisters@@ -59,15 +57,12 @@   pretty SizeTile = "tile_size"   pretty SizeRegTile = "reg_tile_size"   pretty SizeSharedMemory = "shared_memory"-  pretty (SizeBespoke k def) =-    "bespoke" <> parens (pretty k <> comma <+> pretty def)   pretty SizeRegisters = "registers"   pretty SizeCache = "cache"  -- | The default value for the size.  If 'Nothing', that means the backend gets to decide. sizeDefault :: SizeClass -> Maybe Int64 sizeDefault (SizeThreshold _ x) = x-sizeDefault (SizeBespoke _ x) = Just x sizeDefault _ = Nothing  -- | A wrapper supporting a phantom type for indicating what we are counting.
src/Futhark/IR/Parse.hs view
@@ -69,7 +69,7 @@   lexeme . fmap nameFromString $     (:) <$> satisfy leading <*> many (satisfy constituent)   where-    leading c = isAlpha c || c `elem` ("_+-*/%=!<>|&^.#" :: String)+    leading c = isAlpha c || c `elem` ("_+-*/%=!<>|&^." :: String)  pVName :: Parser VName pVName = lexeme $ do@@ -853,9 +853,7 @@               <$> choice [Just <$> pInt64, "def" $> Nothing]               <* pComma               <*> pKernelPath-          ),-      keyword "bespoke"-        *> parens (GPU.SizeBespoke <$> pName <* pComma <*> pInt64)+          )     ]   where     pKernelPath = many pStep
src/Futhark/IR/Prop/Names.hs view
@@ -18,6 +18,7 @@     namesIntersect,     namesSubtract,     mapNames,+    allNames,      -- * Class     FreeIn (..),@@ -114,6 +115,10 @@ -- | Map over the names in a set. mapNames :: (VName -> VName) -> Names -> Names mapNames f vs = namesFromList $ map f $ namesToList vs++-- | Check if predicate holds for all names in set.+allNames :: (VName -> Bool) -> Names -> Bool+allNames f (Names vs) = all f vs  -- | A computation to build a free variable set. newtype FV = FV {unFV :: Names}
src/Futhark/IR/SOACS/Simplify.hs view
@@ -680,13 +680,20 @@   | Just (Screma w arrs form) <- asSOAC op,     Constant (IntValue (Int64Value k)) <- w,     "unroll" `inAttrs` stmAuxAttrs aux =-      Simplify $-        auxing aux $-          FOT.transformScrema-            pat-            (Constant (IntValue (Int64Value k)))-            arrs-            form+      -- We unroll maps in a more direct way, and pass everything else on to+      -- general sequentialisation.+      case isMapSOAC form of+        Just map_lam -> Simplify $ do+          arrs_elems <- fmap transpose . forM [0 .. k - 1] $ \i -> do+            map_lam' <- renameLambda map_lam+            eLambda map_lam' $ map (`eIndex` [eSubExp (constant i)]) arrs+          forM_ (zip3 (patNames pat) arrs_elems (lambdaReturnType map_lam)) $+            \(v, arr_elems, t) ->+              certifying (mconcat (map resCerts arr_elems)) $+                letBindNames [v] . BasicOp $+                  ArrayLit (map resSubExp arr_elems) t+        _ ->+          Simplify . auxing aux $ FOT.transformScrema pat w arrs form -- simplifyKnownIterationSOAC _ _ _ _ = Skip @@ -853,7 +860,7 @@       | arr `ST.elem` vtable,         all (`ST.elem` vtable) $ unCerts cs,         Just js' <- fixWith v js,-        all (`ST.elem` vtable) $ namesToList $ freeIn js' =+        allNames (`ST.elem` vtable) $ freeIn js' =           Just (pat, js', idx)     indexesWith _ _ = Nothing @@ -921,19 +928,19 @@     -- everything else must be map-invariant.     arrayIsMapParam (pat', ArrayIndexing cs arr slice) =       arr `elem` map_param_names-        && all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn slice)+        && allNames (`ST.elem` vtable) (freeIn cs <> freeIn slice)         && not (null slice)         && (not (null $ sliceDims slice) || (topLevelPat pat' && onlyUsedOnce arr))     arrayIsMapParam (_, ArrayRearrange cs arr perm) =       arr `elem` map_param_names-        && all (`ST.elem` vtable) (namesToList $ freeIn cs)+        && allNames (`ST.elem` vtable) (freeIn cs)         && not (null perm)     arrayIsMapParam (_, ArrayReshape cs arr new_shape) =       arr `elem` map_param_names-        && all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn new_shape)+        && allNames (`ST.elem` vtable) (freeIn cs <> freeIn new_shape)     arrayIsMapParam (_, ArrayCopy cs arr) =       arr `elem` map_param_names-        && all (`ST.elem` vtable) (namesToList $ freeIn cs)+        && allNames (`ST.elem` vtable) (freeIn cs)     arrayIsMapParam (_, ArrayVar {}) =       False @@ -1019,7 +1026,7 @@      scope = scopeOf $ bodyStms $ lambdaBody map_lam -    invariantToMap = all (`ST.elem` vtable) . namesToList . freeIn+    invariantToMap = allNames (`ST.elem` vtable) . freeIn      onStm (transformed, map_infos, stms) (Let (Pat [pe]) aux (BasicOp (Reshape arr new_shape)))       | ([(res, _, screma_pe)], map_pesres') <- partition matches map_infos,
src/Futhark/IR/SegOp.hs view
@@ -1224,9 +1224,8 @@         space_slice <- map (DimFix . Var . fst) $ unSegSpace space,         space_slice `isPrefixOf` unSlice slice,         remaining_slice <- Slice $ drop (length space_slice) (unSlice slice),-        all (isJust . flip ST.lookup vtable) $-          namesToList $-            freeIn arr <> freeIn remaining_slice <> freeIn (stmAuxCerts aux) =+        allNames (isJust . flip ST.lookup vtable) $+          freeIn arr <> freeIn remaining_slice <> freeIn (stmAuxCerts aux) =           Just (remaining_slice, arr)       | otherwise =           Nothing
src/Futhark/Internalise/Defunctionalise.hs view
@@ -447,12 +447,12 @@     )   where     closureFromDynamicFun (vn, Binding _ (DynamicFun (clsr_env, sv) _)) =-      let name = nameFromString $ prettyString vn+      let name = nameFromText $ prettyText vn        in ( RecordFieldExplicit (L noLoc name) clsr_env mempty,             (vn, Binding Nothing sv)           )     closureFromDynamicFun (vn, Binding _ sv) =-      let name = nameFromString $ prettyString vn+      let name = nameFromText $ prettyText vn           tp' = structTypeFromSV sv        in ( RecordFieldExplicit               (L noLoc name)@@ -584,8 +584,7 @@ defuncExp OpSection {} = error "defuncExp: unexpected operator section." defuncExp OpSectionLeft {} = error "defuncExp: unexpected operator section." defuncExp OpSectionRight {} = error "defuncExp: unexpected operator section."-defuncExp ProjectSection {} = error "defuncExp: unexpected projection section."-defuncExp IndexSection {} = error "defuncExp: unexpected projection section."+defuncExp UpdateSection {} = error "defuncExp: unexpected projection section." defuncExp (AppExp (Loop sparams pat loopinit form e3 loc) res) = do   (e1', sv1) <- defuncExp $ loopInitExp loopinit   env <- askEnv@@ -628,33 +627,36 @@     ( AppExp (Index e0' idxs' loc) res,       Dynamic $ toParam Observe $ typeOf expr     )-defuncExp (Update e1 idxs e2 loc) = do-  (e1', sv) <- defuncExp e1-  idxs' <- mapM defuncDimIndex idxs-  e2' <- defuncExp' e2-  pure (Update e1' idxs' e2' loc, sv)  -- Note that we might change the type of the record field here.  This -- is not permitted in the type checker due to problems with type -- inference, but it actually works fine.-defuncExp (RecordUpdate e1 fs e2 _ loc) = do+defuncExp (Update e1 steps e2 t loc) = do   (e1', sv1) <- defuncExp e1   (e2', sv2) <- defuncExp e2-  let sv = staticField sv1 sv2 fs-  pure-    ( RecordUpdate e1' fs e2' (Info $ structTypeFromSV sv1) loc,-      sv-    )+  steps' <- mapM defuncStep steps+  let sv' = updateStatic sv1 steps sv2+  pure (Update e1' steps' e2' t loc, sv')   where-    staticField (RecordSV svs) sv2 (f : fs') =-      case lookup f svs of-        Just sv ->+    defuncStep (UpdateStepField f) =+      pure $ UpdateStepField f+    defuncStep (UpdateStepSlice idxs) =+      UpdateStepSlice <$> mapM defuncDimIndex idxs++    updateStatic _ [] newv = newv+    updateStatic (RecordSV fs) (UpdateStepField f : rest) newv =+      case lookup f fs of+        Just old ->           RecordSV $-            (f, staticField sv sv2 fs') : filter ((/= f) . fst) svs-        Nothing -> error "Invalid record projection."-    staticField (Dynamic t@(Scalar Record {})) sv2 fs'@(_ : _) =-      staticField (svFromType t) sv2 fs'-    staticField _ sv2 _ = sv2+            (f, updateStatic old rest newv) : filter ((/= f) . fst) fs+        Nothing ->+          error "Invalid record projection."+    updateStatic (Dynamic t'@(Scalar Record {})) steps0 newv =+      updateStatic (svFromType t') steps0 newv+    updateStatic cur (UpdateStepSlice _ : _) _ =+      cur+    updateStatic _ _ _ =+      error "defuncExp Update: invalid update." defuncExp (Assert e1 e2 desc loc) = do   (e1', _) <- defuncExp e1   (e2', sv) <- defuncExp e2@@ -726,7 +728,7 @@ defuncSoacExp e@OpSection {} = pure e defuncSoacExp e@OpSectionLeft {} = pure e defuncSoacExp e@OpSectionRight {} = pure e-defuncSoacExp e@ProjectSection {} = pure e+defuncSoacExp e@UpdateSection {} = pure e defuncSoacExp (Parens e loc) =   Parens <$> defuncSoacExp e <*> pure loc defuncSoacExp (Lambda params e0 decl tp loc) = do@@ -1088,7 +1090,7 @@   tp typeFromSV (LambdaSV _ _ _ env) =   Scalar . Record . M.fromList $-    map (bimap (nameFromString . prettyString) (typeFromSV . bindingSV)) $+    map (bimap (nameFromText . prettyText) (typeFromSV . bindingSV)) $       M.toList env typeFromSV (RecordSV ls) =   let ts = map (fmap typeFromSV) ls
src/Futhark/Internalise/Entry.hs view
@@ -67,7 +67,7 @@     g (E.TERecord tes _) =       "{" <> mconcat (intersperse ", " (map onField tes)) <> "}"       where-        onField (L _ k, te) = E.nameToText k <> ":" <> f te+        onField (L _ k, te) = E.nameToText k <> ": " <> f te     g (E.TESum cs _) =       mconcat (intersperse " | " (map onConstr cs))       where
src/Futhark/Internalise/Exps.hs view
@@ -41,7 +41,7 @@ internaliseValBinds types = mapM_ $ internaliseValBind types  internaliseFunName :: VName -> Name-internaliseFunName = nameFromString . prettyString+internaliseFunName = nameFromText . prettyText  shiftRetAls :: Int -> RetAls -> RetAls shiftRetAls d (RetAls pals rals) = RetAls pals $ map (+ d) rals@@ -743,49 +743,149 @@       letTupExp' desc $ I.BasicOp $ I.UnOp (I.Neg I.Bool) e'     _ ->       error "Futhark.Internalise.internaliseExp: non-int/bool type in Not"-internaliseExp desc (E.Update src slice ve loc) = locating loc $ do-  ves <- internaliseExp "lw_val" ve-  srcs <- internaliseExpToVars "src" src-  (src_dims, ve_dims) <- case (srcs, ves) of-    (src_v : _, ve_v : _) ->-      (,)-        <$> (I.arrayDims <$> lookupType src_v)-        <*> (I.arrayDims <$> subExpType ve_v)-    _ -> pure ([], []) -- Will this happen?-  (idxs', cs) <- internaliseSlice src_dims slice-  let src_dims' = sliceDims (Slice idxs')-      rank = length src_dims'-      errormsg =-        "Shape "-          <> errorShape src_dims'-          <> " of slice does not match shape "-          <> errorShape (take rank ve_dims)-          <> " of value."--  let comb sname ve' = do-        sname_t <- lookupType sname-        let full_slice = fullSlice sname_t idxs'-            rowtype = sname_t `setArrayDims` sliceDims full_slice-        ve'' <--          ensureShape errormsg rowtype "lw_val_correct_shape" ve'-        letInPlace desc sname full_slice $ BasicOp $ SubExp ve''-  certifying cs $ map I.Var <$> zipWithM comb srcs ves-internaliseExp desc (E.RecordUpdate src fields ve _ loc) = locating loc $ do-  src' <- internaliseExp desc src-  ve' <- internaliseExp desc ve-  replace (E.typeOf src) fields ve' src'+internaliseExp desc (E.Update src steps ve _ loc) = locating loc $ do+  src_vals <- internaliseExpToVars desc src+  ve_vals <- internaliseExp "update_val" ve+  lowerPath (E.typeOf src) src_vals steps ve_vals   where-    replace (E.Scalar (E.Record m)) (f : fs) ve' src'-      | Just t <- M.lookup f m = do+    lowerPath ::+      E.StructType ->+      [I.VName] ->+      [E.UpdateStep Info VName] ->+      [I.SubExp] ->+      InternaliseM [I.SubExp]+    lowerPath base_t base_vs path_steps new_vals+      | all noSlice path_steps =+          lowerPathFields base_t base_vs path_steps new_vals+      where+        noSlice E.UpdateStepSlice {} = False+        noSlice _ = True+    lowerPath base_t base_vs path_steps new_vals = do+      let focused0 = zip [0 ..] (map (const Nothing) base_vs)+      updates <- go base_vs mempty base_t focused0 path_steps new_vals+      pure $+        [ M.findWithDefault (I.Var v) i updates+        | (i, v) <- zip [0 ..] base_vs+        ]++    lowerPathFields ::+      E.StructType ->+      [I.VName] ->+      [E.UpdateStep Info VName] ->+      [I.SubExp] ->+      InternaliseM [I.SubExp]+    lowerPathFields _ _ [] new_vals =+      pure new_vals+    lowerPathFields base_t base_vs (E.UpdateStepField f : rest) new_vals = do+      (before, field_vals, after, field_t) <- splitField base_t f base_vs+      updated_field_vals <- lowerPathFields field_t field_vals rest new_vals+      pure $ map I.Var before ++ updated_field_vals ++ map I.Var after+    lowerPathFields _ _ _ _ =+      error "lowerPathFields: unexpected slice step"++    go ::+      [I.VName] ->+      Certs ->+      E.StructType ->+      [(Int, Maybe (I.Slice I.SubExp))] ->+      [E.UpdateStep Info VName] ->+      [I.SubExp] ->+      InternaliseM (M.Map Int I.SubExp)+    go root_vs certs _ focused [] new_vals = do+      when (length focused /= length new_vals) $+        error "internaliseExp Update: update arity mismatch"++      let errormsg = errorMsg [ErrorString "Shape of slice does not match shape of value."]++          writeBack (i, m_slice) ve' = do+            let sname = root_vs !! i+            case m_slice of+              Nothing -> pure ve'+              Just sl -> do+                sname_t <- lookupType sname+                let rowtype = sname_t `setArrayDims` sliceDims sl+                ve'' <- ensureShape errormsg rowtype "update_val_correct_shape" ve'+                certifying certs $ I.Var <$> letInPlace desc sname sl (BasicOp $ SubExp ve'')++      fmap M.fromList . forM (zip focused new_vals) $ \(f, ve') -> do+        res <- writeBack f ve'+        pure (fst f, res)+    go root_vs certs base_t focused (E.UpdateStepField f : rest) new_vals = do+      (_before, field_vals, _after, field_t) <- splitField base_t f focused+      go root_vs certs field_t field_vals rest new_vals+    go root_vs certs base_t focused (E.UpdateStepSlice slice : rest) new_vals = do+      current_dims <- dimsOfType base_t++      (idxs', cs) <- internaliseSlice current_dims slice++      let current_slice =+            I.Slice $+              idxs'+                ++ map+                  (\d -> I.DimSlice (constant (0 :: Int64)) d (constant (1 :: Int64)))+                  (drop (length idxs') current_dims)+      focused' <-+        forM focused $ \(i, m_slice) -> do+          slice' <- case m_slice of+            Nothing -> do+              root_dims <- I.arrayDims <$> lookupType (root_vs !! i)+              pure . I.Slice $+                idxs'+                  ++ map+                    (\d -> I.DimSlice (constant (0 :: Int64)) d (constant (1 :: Int64)))+                    (drop (length idxs') root_dims)+            Just sl -> subExpSlice $ sliceSlice (primExpSlice sl) (primExpSlice current_slice)+          pure (i, Just slice')++      go root_vs (certs <> cs) (indexType base_t slice) focused' rest new_vals++    dimsOfType :: E.StructType -> InternaliseM [SubExp]+    dimsOfType (E.Array _ shape _) = mapM dimOfSize $ E.shapeDims shape+    dimsOfType _ = pure []++    dimOfSize :: E.Size -> InternaliseM SubExp+    dimOfSize d+      | Just _ <- E.isAnySize d =+          error "lowerPath: unexpected anonymous size in slice type"+    dimOfSize (E.IntLit n _ _) = pure $ intConst Int64 n+    dimOfSize (E.Var (E.QualName _ v) _ _) = pure $ I.Var v+    dimOfSize d =+      error $ "lowerPath: unexpected size expression " ++ prettyString d++    splitField ::+      E.StructType ->+      Name ->+      [a] ->+      InternaliseM ([a], [a], [a], E.StructType)+    splitField (E.Scalar (E.Record m)) f vals+      | Just field_t <- M.lookup f m =           let i =                 sum . map (internalisedTypeSize . snd) $-                  takeWhile ((/= f) . fst) . sortFields $-                    m-              k = internalisedTypeSize t-              (bef, to_update, aft) = splitAt3 i k src'-          src'' <- replace t fs ve' to_update-          pure $ bef ++ src'' ++ aft-    replace _ _ ve' _ = pure ve'+                  takeWhile ((/= f) . fst) $+                    sortFields m+              k = internalisedTypeSize field_t+              (before, field_vals, after) = splitAt3 i k vals+           in pure (before, field_vals, after, field_t)+    splitField t f _ =+      error $+        "lowerPath: missing field "+          ++ prettyString f+          ++ " in type "+          ++ prettyString t++    indexType :: E.StructType -> [E.DimIndex] -> E.StructType+    indexType (E.Array u (E.Shape dims) et) idxs =+      case dims' of+        [] -> E.Scalar et+        ds -> E.Array u (E.Shape ds) et+      where+        dims' = keptPrefix <> suffix+        keptPrefix = [d | (d, i) <- zip prefix idxs, keepDim i]+        prefix = take (length idxs) dims+        suffix = drop (length idxs) dims+        keepDim E.DimFix {} = False+        keepDim E.DimSlice {} = True+    indexType t _ = t internaliseExp desc (E.Attr attr e loc) = do   attr' <- internaliseAttr attr   e' <- local (f attr') $ internaliseExp desc e@@ -915,10 +1015,8 @@   error $ "internaliseExp: Unexpected left operator section at " ++ locStr (srclocOf e) internaliseExp _ e@E.OpSectionRight {} =   error $ "internaliseExp: Unexpected right operator section at " ++ locStr (srclocOf e)-internaliseExp _ e@E.ProjectSection {} =+internaliseExp _ e@E.UpdateSection {} =   error $ "internaliseExp: Unexpected projection section at " ++ locStr (srclocOf e)-internaliseExp _ e@E.IndexSection {} =-  error $ "internaliseExp: Unexpected index section at " ++ locStr (srclocOf e)  internaliseArg :: Name -> (E.Exp, Maybe VName) -> InternaliseM [SubExp] internaliseArg desc (arg, argdim) = do@@ -2205,9 +2303,3 @@     compact (ErrorString x : ErrorString y : parts) =       compact (ErrorString (x <> y) : parts)     compact (x : y) = x : compact y--errorShape :: [a] -> ErrorMsg a-errorShape dims =-  "["-    <> mconcat (intersperse "][" $ map (ErrorMsg . pure . ErrorVal int64) dims)-    <> "]"
src/Futhark/Internalise/FullNormalise.hs view
@@ -198,17 +198,17 @@ getOrdering final (Constr n es ty loc) = do   es' <- mapM (getOrdering False) es   nameExp final $ Constr n es' ty loc-getOrdering final (Update eb slice eu loc) = do+getOrdering final (Update eb steps eu ty loc) = do+  steps' <- mapM onStep steps   eu' <- getOrdering False eu-  slice' <- astMap mapper slice   eb' <- getOrdering False eb-  nameExp final $ Update eb' slice' eu' loc+  nameExp final $ Update eb' steps' eu' ty loc   where     mapper = identityMapper {mapOnExp = getOrdering False}-getOrdering final (RecordUpdate eb ns eu ty loc) = do-  eb' <- getOrdering False eb-  eu' <- getOrdering False eu-  nameExp final $ RecordUpdate eb' ns eu' ty loc+    onStep (UpdateStepSlice slice) =+      UpdateStepSlice <$> astMap mapper slice+    onStep (UpdateStepField f) =+      pure $ UpdateStepField f getOrdering final (Lambda params body mte ret loc) = do   body' <- transformBody body   nameExp final $ Lambda params body' mte ret loc@@ -240,37 +240,42 @@       | Named p <- xp, p == vn = Just $ ExpSubst x       | Named p <- yp, p == vn = Just $ ExpSubst y       | otherwise = Nothing-getOrdering final (ProjectSection names (Info ty) loc) = do+getOrdering final (UpdateSection steps (Info ty) loc) = do+  steps' <- mapM transformStep steps   xn <- newVName "x"   let (xty, RetType dims ret) = case ty of         Scalar (Arrow _ _ d xty' ret') -> (toParam d xty', ret')-        _ -> error $ "not a function type for project section: " ++ prettyString ty+        _ -> error $ "not a function type for section update: " ++ prettyString ty       x = Var (qualName xn) (Info $ toStruct xty) mempty-      body = foldl project x names+      body = fst $ foldl applyStep (x, toStruct xty) steps'   nameExp final $ Lambda [Id xn (Info xty) mempty] body Nothing (Info (RetType dims ret)) loc   where-    project e field =-      case typeOf e of+    mapper = identityMapper {mapOnExp = getOrdering False}++    transformStep (UpdateStepField f) =+      pure $ UpdateStepField f+    transformStep (UpdateStepSlice slice) =+      UpdateStepSlice <$> astMap mapper slice++    applyStep (e, t) (UpdateStepField field) =+      case t of         Scalar (Record fs)-          | Just t <- M.lookup field fs ->-              Project field e (Info t) mempty-        t ->+          | Just t' <- M.lookup field fs ->+              (Project field e (Info t') mempty, t')+        _ ->           error $-            "desugar ProjectSection: type "+            "desugar UpdateSection: type "               ++ prettyString t               ++ " does not have field "               ++ prettyString field-getOrdering final (IndexSection slice (Info ty) loc) = do-  slice' <- astMap mapper slice-  xn <- newVName "x"-  let (xty, RetType dims ret) = case ty of-        Scalar (Arrow _ _ d xty' ret') -> (toParam d xty', ret')-        _ -> error $ "not a function type for index section: " ++ prettyString ty-      x = Var (qualName xn) (Info $ toStruct xty) mempty-      body = AppExp (Index x slice' loc) (Info (AppRes (toStruct ret) []))-  nameExp final $ Lambda [Id xn (Info xty) mempty] body Nothing (Info (RetType dims ret)) loc-  where-    mapper = identityMapper {mapOnExp = getOrdering False}+    applyStep (e, t) (UpdateStepSlice slice) =+      let t' = stripArray (fixedDims slice) t+          e' = AppExp (Index e slice loc) (Info (AppRes t' []))+       in (e', t')++    fixedDims = length . filter isFix+    isFix DimFix {} = True+    isFix _ = False getOrdering _ (Ascript e _ _) = getOrdering False e getOrdering final (AppExp (Apply f args loc) resT) = do   args' <-@@ -327,16 +332,20 @@   where     isOr = baseName (qualLeaf op) == "||"     isAnd = baseName (qualLeaf op) == "&&"-getOrdering final (AppExp (LetWith (Ident dest dty dloc) (Ident src sty sloc) slice e body _) _) = do+getOrdering final (AppExp (LetWith (Ident dest dty dloc) (Ident src sty sloc) steps e body _) _) = do+  steps' <- mapM onStep steps   e' <- getOrdering False e-  slice' <- astMap mapper slice-  -- Carefully synthesize a location that does not have the body in it --  -- this is so profiling information will be more precise.   let loc' = srcspan dloc e-  addBind $ PatBind [] (Id dest dty dloc) (Update (Var (qualName src) sty sloc) slice' e' loc')+  addBind $+    PatBind+      []+      (Id dest dty dloc)+      (Update (Var (qualName src) sty sloc) steps' e' (Info (unInfo sty)) loc')   getOrdering final body   where     mapper = identityMapper {mapOnExp = getOrdering False}+    onStep (UpdateStepSlice slice) = UpdateStepSlice <$> astMap mapper slice+    onStep (UpdateStepField f) = pure $ UpdateStepField f getOrdering final (AppExp (Index e slice loc) resT) = do   e' <- getOrdering False e   slice' <- astMap mapper slice
src/Futhark/Internalise/Monomorphise.hs view
@@ -697,29 +697,31 @@     (yp, ytype, yargext)     (rettype, [])     loc-transformExp (ProjectSection fields (Info t) loc) = do+transformExp (UpdateSection steps (Info t) loc) = do   t' <- transformType t-  desugarProjectSection fields t' loc-transformExp (IndexSection idxs (Info t) loc) = do-  idxs' <- mapM transformDimIndex idxs-  desugarIndexSection idxs' t loc+  steps' <- mapM transformStep steps+  desugarUpdateSection steps' t' loc+  where+    transformStep (UpdateStepSlice idxs) =+      UpdateStepSlice <$> mapM transformDimIndex idxs+    transformStep (UpdateStepField f) =+      pure $ UpdateStepField f transformExp (Project n e tp loc) = do   tp' <- traverse transformType tp   e' <- transformExp e   pure $ Project n e' tp' loc-transformExp (Update e1 idxs e2 loc) =+transformExp (Update e1 steps e2 t loc) =   Update     <$> transformExp e1-    <*> mapM transformDimIndex idxs-    <*> transformExp e2-    <*> pure loc-transformExp (RecordUpdate e1 fs e2 t loc) =-  RecordUpdate-    <$> transformExp e1-    <*> pure fs+    <*> mapM transformStep steps     <*> transformExp e2     <*> traverse transformType t     <*> pure loc+  where+    transformStep (UpdateStepSlice idxs) =+      UpdateStepSlice <$> mapM transformDimIndex idxs+    transformStep (UpdateStepField f) =+      pure $ UpdateStepField f transformExp (Assert e1 e2 desc loc) =   Assert <$> transformExp e1 <*> transformExp e2 <*> pure desc <*> pure loc transformExp (Constr name all_es t loc) =@@ -790,10 +792,10 @@       (v, pat, var_e) <- patAndVar argtype       pure (v, id, var_e, [pat]) -desugarProjectSection :: [Name] -> StructType -> SrcLoc -> MonoM Exp-desugarProjectSection fields (Scalar (Arrow _ _ _ t1 (RetType dims t2))) loc = do-  p <- newVName "project_p"-  let body = foldl project (Var (qualName p) (Info t1) mempty) fields+desugarUpdateSection :: [UpdateStep Info VName] -> StructType -> SrcLoc -> MonoM Exp+desugarUpdateSection steps (Scalar (Arrow _ _ _ t1 (RetType dims t2))) loc = do+  p <- newVName "section_p"+  let body = fst $ foldl applyStep (Var (qualName p) (Info t1) mempty, t1) steps   pure $     Lambda       [Id p (Info $ toParam Observe t1) mempty]@@ -802,33 +804,26 @@       (Info (RetType dims t2))       loc   where-    project e field =-      case typeOf e of+    applyStep (e, t) (UpdateStepField field) =+      case t of         Scalar (Record fs)-          | Just t <- M.lookup field fs ->-              Project field e (Info t) mempty-        t ->+          | Just t' <- M.lookup field fs ->+              (Project field e (Info t') mempty, t')+        _ ->           error $-            "desugarOpSection: type "+            "desugarUpdateSection: type "               ++ prettyString t               ++ " does not have field "               ++ prettyString field-desugarProjectSection _ t _ = error $ "desugarOpSection: not a function type: " ++ prettyString t+    applyStep (e, t) (UpdateStepSlice idxs) =+      let t' = stripArray (fixedDims idxs) t+          e' = AppExp (Index e idxs loc) (Info (AppRes t' []))+       in (e', t') -desugarIndexSection :: [DimIndex] -> StructType -> SrcLoc -> MonoM Exp-desugarIndexSection idxs (Scalar (Arrow _ _ _ t1 (RetType dims t2))) loc = do-  p <- newVName "index_i"-  t1' <- transformType t1-  t2' <- transformType t2-  let body = AppExp (Index (Var (qualName p) (Info t1') loc) idxs loc) (Info (AppRes (toStruct t2') []))-  pure $-    Lambda-      [Id p (Info $ toParam Observe t1') mempty]-      body-      Nothing-      (Info (RetType dims t2'))-      loc-desugarIndexSection _ t _ = error $ "desugarIndexSection: not a function type: " ++ prettyString t+    fixedDims = length . filter isFix+    isFix DimFix {} = True+    isFix _ = False+desugarUpdateSection _ t _ = error $ "desugarUpdateSection: not a function type: " ++ prettyString t  transformPat :: Pat (TypeBase Size u) -> MonoM (Pat (TypeBase Size u)) transformPat = traverse transformType@@ -1007,6 +1002,10 @@     arrowCleanType paramed (Scalar ty) =       Scalar $ arrowCleanScalar paramed ty +removeEntryPoint :: PolyBinding -> PolyBinding+removeEntryPoint (PolyBinding (_, name, tparams, params, rettype, body, attrs, loc)) =+  PolyBinding (Nothing, name, tparams, params, rettype, body, attrs, loc)+ -- Monomorphise a polymorphic function at the types given in the instance -- list. Monomorphises the body of the function as well. Returns the fresh name -- of the generated monomorphic function and its 'ValBind' representation.@@ -1226,7 +1225,9 @@    pure     env-      { envPolyBindings = M.insert (valBindName valbind) valbind' $ envPolyBindings env,+      { envPolyBindings =+          M.insert (valBindName valbind) (removeEntryPoint valbind') $+            envPolyBindings env,         envGlobalScope = global <> envGlobalScope env,         envScope =           S.insert (valBindName valbind) global
+ src/Futhark/LSP/CodeLens.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-}++module Futhark.LSP.CodeLens (evalLensesFor, execute, resolve) where++import Control.Arrow ((>>>))+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (AllocationLimitExceeded (AllocationLimitExceeded), handle)+import Control.Lens ((^.))+import Control.Monad (void)+import Control.Monad.Except (Except, ExceptT, MonadError (throwError), runExceptT)+import Control.Monad.Trans (MonadIO (liftIO), lift)+import Data.Aeson (FromJSON (parseJSON))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types qualified as Aeson+import Data.Foldable (toList)+import Data.Function ((&))+import Data.IORef (IORef, newIORef, readIORef)+import Data.Map.Strict qualified as M+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Sequence (Seq ((:|>)))+import Data.Sequence qualified as Seq+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Mixed.Rope qualified as R+import Futhark.Compiler.Program (VFS)+import Futhark.Eval (Evaluation (abort), InterpreterConfig (InterpreterConfig), newFutharkiState, runEvalRecordRef, runExpr)+import Futhark.LSP.CommandType qualified as CommandType+import Futhark.LSP.Tool (transformVFS)+import Futhark.Util (showText)+import Futhark.Util.Pretty (docText, plural, pretty, vcat)+import Language.LSP.Protocol.Message (SMethod (SMethod_WorkspaceApplyEdit))+import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (..), CodeLens (..), Command (..), ErrorCodes (ErrorCodes_InvalidParams), LSPErrorCodes, Position (..), Range (..), TextEdit (..), UInt, Uri, WorkspaceEdit (..), fromNormalizedFilePath, toNormalizedUri, uriToNormalizedFilePath, type (|?) (..))+import Language.LSP.Server (LspT, getVirtualFile, getVirtualFiles, sendRequest)+import Language.LSP.VFS (file_text)+import Prettyprinter (Doc)+import Prettyprinter.Render.Terminal (AnsiStyle)+import System.Mem (enableAllocationLimit, setAllocationCounter)+import System.Timeout (timeout)++-- | All the possible lenses+--+-- I tried some trickery with GADTs here for advanced type safety, but I+-- ultimately didn't succeed because I was unable to write/derive instances+newtype LensPayload+  = EvalLensPayload EvalLensData++instance Aeson.ToJSON LensPayload where+  -- it is necessary to make sure that this mirror with @FromJSON@+  toJSON :: LensPayload -> Aeson.Value+  toJSON (EvalLensPayload payload) = payloadWithType "EvalLens" payload+    where+      payloadWithType :: (Aeson.ToJSON a) => Text -> a -> Aeson.Value+      payloadWithType typ load =+        Aeson.Object . KeyMap.fromList $+          [ ("type", Aeson.toJSON typ),+            ("payload", Aeson.toJSON load)+          ]++instance Aeson.FromJSON LensPayload where+  -- it is necessary to make sure that this mirror with @toJSON@+  parseJSON :: Aeson.Value -> Aeson.Parser LensPayload+  parseJSON = Aeson.withObject "LensPayload" $ \object -> do+    (typ :: Text) <- Aeson.parseField object "type"+    case typ of+      "EvalLens" -> EvalLensPayload <$> Aeson.parseField object "payload"+      _ -> fail $ "Unknown Lens Type: " ++ T.unpack typ++-- which document, which line+-- this is valid as long as the document has an eval comment on that line+data EvalLensData = EvalLensData+  { eldTextDocument :: Uri,+    eldLine :: UInt+  }++instance Aeson.ToJSON EvalLensData where+  toJSON :: EvalLensData -> Aeson.Value+  toJSON (EvalLensData textDoc line) = Aeson.toJSON (textDoc, line)++instance Aeson.FromJSON EvalLensData where+  parseJSON :: Aeson.Value -> Aeson.Parser EvalLensData+  parseJSON o = do+    (textDoc, line) <- parseJSON o+    pure $ EvalLensData textDoc line++evalLensPrefix :: T.Text+evalLensPrefix = "-- >>>"++evalLensesFor :: Uri -> LspT () IO (Either Text [CodeLens])+evalLensesFor file_uri = runExceptT $ do+  vfile <-+    lift (getVirtualFile $ toNormalizedUri file_uri) >>= \case+      Nothing -> throwError . T.pack $ "Could not find file: " ++ show file_uri+      Just vfile -> pure vfile++  let commentLines =+        vfile ^. file_text+          & R.lines+          & zip [0 :: UInt ..]+          & mapMaybe filterComment++  pure $+    commentLines+      & map evalLens+  where+    filterComment (i, line) = i <$ T.stripPrefix evalLensPrefix line+    evalLens i =+      CodeLens+        { _command = Nothing,+          _data_ =+            Just . Aeson.toJSON . EvalLensPayload $+              EvalLensData+                { eldTextDocument = file_uri,+                  eldLine = i+                },+          _range =+            Range+              { _start = Position {_line = i, _character = 0},+                _end = Position {_line = i, _character = maxBound}+              }+        }++resolve :: CodeLens -> Except Text CodeLens+resolve (CodeLens _ (Just _) _) =+  throwError "CodeLens is already resolved"+resolve (CodeLens _ _ Nothing) =+  throwError "CodeLens doesn't have data attached"+resolve (CodeLens range Nothing (Just payload)) =+  case Aeson.fromJSON payload :: Aeson.Result LensPayload of+    Aeson.Error msg -> throwError $ T.pack msg+    Aeson.Success _ ->+      pure $+        CodeLens+          { _range = range,+            _data_ = Nothing,+            _command =+              Just+                Command+                  { _arguments = Just [payload],+                    _title = "Evaluate",+                    _command = showText CommandType.CodeLens+                  }+          }++type Execute a = ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) a++-- | Decode the arguments+execute :: Maybe [Aeson.Value] -> Execute ()+execute (Just [argument]) = case Aeson.fromJSON argument :: Aeson.Result LensPayload of+  Aeson.Success payload -> executeLens payload+  Aeson.Error msg ->+    throwError+      ( "Failed to decode CodeLens command argument: " <> T.pack msg,+        InR ErrorCodes_InvalidParams+      )+execute bad =+  throwError+    ( "Expected exactly one argument for the CodeLens Command, got: "+        <> showText bad,+      InR ErrorCodes_InvalidParams+    )++-- | Dispatch to the correct lens executor+--+-- (currently there's only one)+executeLens :: LensPayload -> Execute ()+executeLens (EvalLensPayload payloadData) = executeEvalLens payloadData++-- | Execute a Evaluation Lens+executeEvalLens :: EvalLensData -> Execute ()+executeEvalLens (EvalLensData docUri line) = do+  -- retrieve the file+  file <-+    lift (getVirtualFile $ toNormalizedUri docUri) >>= \case+      Nothing ->+        throwError+          ( "Could not find document specified in Command: " <> showText docUri,+            InR ErrorCodes_InvalidParams+          )+      Just file -> pure file++  -- check the line+  let lineText = R.toText . R.getLine (fromIntegral line) $ file ^. file_text+  expressionText <- case T.stripPrefix evalLensPrefix lineText of+    Nothing ->+      throwError+        ( "Specified line does not contain an evaluation comment",+          InR ErrorCodes_InvalidParams+        )+    Just expression -> pure expression++  currentVFS <- lift $ transformVFS <$> getVirtualFiles+  result <- liftIO $ performEvaluation currentVFS expressionText++  publishResult result $ file ^. file_text++  pure ()+  where+    publishResult (result, traces) fileRope =+      void . lift $+        sendRequest SMethod_WorkspaceApplyEdit workSpaceEditParams $+          const (pure ())+      where+        findResultLinesEnd i+          -- don't override other eval comments+          | T.isPrefixOf evalLensPrefix commentLine =+              i+          -- replace all output comments+          | T.isPrefixOf "-- " commentLine =+              findResultLinesEnd $ succ i+          -- stop otherwise+          | otherwise = i+          where+            commentLine = R.toText $ R.getLine i fileRope+        insertText =+          -- TODO: configurable retained trace count+          let droppedTraceCount = Seq.length traces - 100+              truncatedTraces =+                Seq.drop droppedTraceCount traces+                  & if droppedTraceCount > 0+                    then+                      ( "Hiding "+                          <> pretty droppedTraceCount+                          <> plural " trace" " traces" droppedTraceCount+                          Seq.<|+                      )+                    else id+              allDocs = truncatedTraces :|> either id id result+              commentLines =+                T.lines+                  >>> map ("-- " <>)+                  >>> T.unlines+           in commentLines . docText . vcat . toList $ allDocs+        insertResultEdit =+          TextEdit+            { _newText = insertText,+              _range =+                Range+                  { _end =+                      Position+                        { _character = 0,+                          -- insert below the evaluation comment+                          _line = line + 1+                        },+                    _start =+                      Position+                        { _line =+                            -- replace the entire comment range+                            -- removes any previous results+                            fromIntegral+                              . findResultLinesEnd+                              . succ+                              . fromIntegral+                              $ line,+                          _character = 0+                        }+                  }+            }+        workSpaceEditParams =+          ApplyWorkspaceEditParams+            { _label = Just "Insert result of code lens evaluation",+              _edit =+                WorkspaceEdit+                  { _documentChanges = Nothing,+                    _changeAnnotations = Nothing,+                    _changes = Just $ M.singleton docUri [insertResultEdit]+                  }+            }++    performEvaluation ::+      VFS ->+      Text ->+      IO (Either (Doc AnsiStyle) (Doc AnsiStyle), Seq (Doc AnsiStyle))+    performEvaluation currentVFS expressionText = do+      resultVar <- newEmptyMVar+      traceRef <- newIORef Seq.empty+      _evaluationTid <- forkIO $ putMVar resultVar =<< evaluationAction traceRef+      (,) <$> takeMVar resultVar <*> readIORef traceRef+      where+        setupLimits = do+          -- I was unable to trigger the timeout with a lower limit at all+          setAllocationCounter 100_000_000_000+          enableAllocationLimit++        evaluationAction ::+          IORef (Seq (Doc AnsiStyle)) ->+          IO (Either (Doc AnsiStyle) (Doc AnsiStyle))+        evaluationAction traceRef = interpret $ do+          -- do not print warnings, no file+          let interpreterConfig = InterpreterConfig False Nothing+          let filePath =+                toNormalizedUri docUri+                  & uriToNormalizedFilePath+                  & fmap fromNormalizedFilePath++          -- load the file the expression is located in+          interpreterState <-+            newFutharkiState interpreterConfig filePath currentVFS+              >>= either abort pure++          liftIO setupLimits++          runExpr interpreterState expressionText+          where+            -- TODO: Configurable allocation limit+            handleOom AllocationLimitExceeded =+              pure (Left "Computation ran out of memory")++            -- TODO: Configurable timeout+            handleTimeout action =+              timeout timeoutMilliseconds action+                & fmap (fromMaybe (Left "Computation ran out of time"))+              where+                timeoutMilliseconds = 15 * 10 ^ (6 :: Int)++            interpret =+              handle handleOom . handleTimeout . runEvalRecordRef traceRef
+ src/Futhark/LSP/CommandType.hs view
@@ -0,0 +1,5 @@+module Futhark.LSP.CommandType (CommandType (..)) where++data CommandType+  = CodeLens+  deriving (Show, Read, Enum, Bounded)
src/Futhark/LSP/Compile.hs view
@@ -5,25 +5,19 @@ module Futhark.LSP.Compile (tryTakeStateFromIORef, tryReCompile) where  import Colog.Core (logStringStderr, (<&))-import Control.Lens.Getter (view) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.IORef (IORef, readIORef, writeIORef)-import Data.Map qualified as M import Data.Maybe (fromMaybe)-import Data.Text qualified as T import Futhark.Compiler.Program (LoadedProg, lpFilePaths, lpWarnings, noLoadedProg, reloadProg) import Futhark.LSP.Diagnostic (diagnosticSource, maxDiagnostic, publishErrorDiagnostics, publishWarningDiagnostics) import Futhark.LSP.State (State (..), emptyState, updateStaleContent, updateStaleMapping)-import Futhark.LSP.Tool (computeMapping)+import Futhark.LSP.Tool (computeMapping, transformVFS) import Language.Futhark.Warnings (listWarnings) import Language.LSP.Protocol.Types   ( filePathToUri,-    fromNormalizedFilePath,     toNormalizedUri,-    uriToNormalizedFilePath,   ) import Language.LSP.Server (LspT, flushDiagnosticsBySource, getVirtualFile, getVirtualFiles)-import Language.LSP.VFS (VFS, vfsMap, virtualFileText)  -- | Try to take state from IORef, if it's empty, try to compile. tryTakeStateFromIORef :: IORef State -> Maybe FilePath -> LspT () IO State@@ -89,20 +83,6 @@       logStringStderr <& "Compilation failed, publishing diagnostics"       publishErrorDiagnostics prog_error       pure emptyState---- | Transform VFS to a map of file paths to file contents.--- This is used to pass the file contents to the compiler.-transformVFS :: VFS -> M.Map FilePath T.Text-transformVFS vfs =-  M.foldrWithKey-    ( \uri virtual_file acc ->-        case uriToNormalizedFilePath uri of-          Nothing -> acc-          Just file_path ->-            M.insert (fromNormalizedFilePath file_path) (virtualFileText virtual_file) acc-    )-    M.empty-    (view vfsMap vfs)  getLoadedProg :: State -> LoadedProg getLoadedProg state = fromMaybe noLoadedProg (stateProgram state)
src/Futhark/LSP/Handlers.hs view
@@ -1,22 +1,28 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExplicitNamespaces #-}  -- | The handlers exposed by the language server. module Futhark.LSP.Handlers (handlers) where  import Colog.Core (logStringStderr, (<&)) import Control.Lens ((^.))-import Control.Monad.Except (MonadError (throwError), liftEither)+import Control.Monad.Except (ExceptT, MonadError (throwError), liftEither, throwError) import Control.Monad.Trans (lift)-import Control.Monad.Trans.Except (runExceptT)+import Control.Monad.Trans.Except (runExcept, runExceptT)+import Data.Aeson qualified as Aeson import Data.Aeson.Types (Value (Array, String))-import Data.Bifunctor (first)+import Data.Bifunctor (bimap, first) import Data.Function ((&))-import Data.IORef+import Data.IORef (IORef) import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as T import Data.Text.Mixed.Rope qualified as R import Data.Vector qualified as V import Futhark.Fmt.Printer (fmtToText)+import Futhark.LSP.CodeLens qualified as CodeLens+import Futhark.LSP.CommandType (CommandType (CodeLens)) import Futhark.LSP.Compile (tryReCompile, tryTakeStateFromIORef) import Futhark.LSP.State (State (..)) import Futhark.LSP.Tool (findDefinitionRange, getHoverInfoFromState)@@ -24,11 +30,37 @@ import Futhark.Util.Pretty (prettyText) import Language.Futhark.Core (locText) import Language.Futhark.Parser.Monad (SyntaxError (SyntaxError))-import Language.LSP.Protocol.Lens (HasUri (uri))+import Language.LSP.Protocol.Lens (HasTextDocument (textDocument), HasUri (uri), arguments, command, line, params, range, start) import Language.LSP.Protocol.Message+  ( Method (..),+    SMethod (..),+    TNotificationMessage (TNotificationMessage),+    TRequestMessage (TRequestMessage),+    TResponseError (TResponseError, _code, _message, _xdata),+  ) import Language.LSP.Protocol.Types-import Language.LSP.Server (Handlers, LspM, getVirtualFile, notificationHandler, requestHandler)+  ( ClientCapabilities,+    CodeLens,+    Definition (Definition),+    DefinitionParams (DefinitionParams),+    DidChangeTextDocumentParams (DidChangeTextDocumentParams),+    DidSaveTextDocumentParams (DidSaveTextDocumentParams),+    DocumentFormattingParams (DocumentFormattingParams),+    ErrorCodes (ErrorCodes_InvalidParams, ErrorCodes_InvalidRequest, ErrorCodes_ParseError),+    HoverParams (HoverParams),+    LSPErrorCodes,+    Null (..),+    Position (Position, _character, _line),+    Range (Range, _end, _start),+    TextEdit (TextEdit, _newText, _range),+    Uri (Uri),+    toNormalizedUri,+    uriToFilePath,+    type (|?) (..),+  )+import Language.LSP.Server (Handlers, LspM, LspT, getVirtualFile, notificationHandler, requestHandler) import Language.LSP.VFS (file_text)+import Text.Read (readMaybe)  onInitializeHandler :: Handlers (LspM ()) onInitializeHandler = notificationHandler SMethod_Initialized $ \_msg ->@@ -158,6 +190,73 @@           _code = InR ErrorCodes_InvalidParams         } +onDocumentCodeLenses :: Handlers (LspM ())+onDocumentCodeLenses =+  requestHandler SMethod_TextDocumentCodeLens $ \request respond ->+    let textDocUri = request ^. params . textDocument . uri+     in do+          logStringStderr <& ("textDocument/CodeLens for " ++ show textDocUri)+          eitherLenses <- CodeLens.evalLensesFor textDocUri+          respond $ bimap failure success eitherLenses+  where+    success :: [CodeLens] -> [CodeLens] |? Null+    success = InL++    failure message =+      TResponseError+        { _xdata = Nothing,+          _message = message,+          _code = InR ErrorCodes_InvalidRequest+        }++onDocumentCodeLensResolve :: Handlers (LspM ())+onDocumentCodeLensResolve =+  requestHandler SMethod_CodeLensResolve $ \request respond ->+    let codeLens = request ^. params+        codeLensLine = codeLens ^. (range . start . line)+     in do+          logStringStderr <& ("Resolving code lens on line " ++ show codeLensLine)+          let result = runExcept $ CodeLens.resolve codeLens+          respond . first failure $ result+  where+    failure :: Text -> TResponseError Method_CodeLensResolve+    failure text =+      TResponseError+        { _xdata = Nothing,+          _message = text,+          _code = InR ErrorCodes_InvalidParams+        }++-- | Dispatch to the correct Command Handler+executeCommand ::+  Text ->+  Maybe [Aeson.Value] ->+  ExceptT (Text, LSPErrorCodes |? ErrorCodes) (LspT () IO) ()+executeCommand cmd_name cmd_params = case readMaybe $ T.unpack cmd_name of+  Just CodeLens -> CodeLens.execute cmd_params+  Nothing ->+    throwError+      ( "Unknown command name: " <> cmd_name,+        InR ErrorCodes_InvalidRequest+      )++onWorkspaceExecuteCommandHandler :: Handlers (LspM ())+onWorkspaceExecuteCommandHandler =+  requestHandler SMethod_WorkspaceExecuteCommand $ \request respond ->+    let parameters = request ^. params+     in do+          let commandName = parameters ^. command+          let commandArgs = parameters ^. arguments+          result <- runExceptT $ executeCommand commandName commandArgs+          respond $ bimap (uncurry failure) (const $ InR Null) result+  where+    failure message err =+      TResponseError+        { _xdata = Nothing,+          _message = message,+          _code = err+        }+ -- | Given an 'IORef' tracking the state, produce a set of handlers. -- When we want to add more features to the language server, this is -- the thing to change.@@ -167,11 +266,14 @@     [ onInitializeHandler,       onDocumentOpenHandler,       onDocumentCloseHandler,+      onDocumentCodeLenses,+      onDocumentCodeLensResolve,       onDocumentFormattingHandler,       onDocumentSaveHandler state_mvar,       onDocumentChangeHandler state_mvar,       onDocumentFocusHandler state_mvar,       goToDefinitionHandler state_mvar,       onHoverHandler state_mvar,-      onWorkspaceDidChangeConfiguration state_mvar+      onWorkspaceDidChangeConfiguration state_mvar,+      onWorkspaceExecuteCommandHandler     ]
src/Futhark/LSP/Tool.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ -- | Generally useful definition used in various places in the -- language server implementation. module Futhark.LSP.Tool@@ -6,9 +8,12 @@     rangeFromLoc,     posToUri,     computeMapping,+    transformVFS,   ) where +import Control.Lens.Getter ((^.))+import Data.Map qualified as M import Data.Text qualified as T import Futhark.Compiler.Program (lpImports) import Futhark.LSP.PositionMapping@@ -29,7 +34,8 @@   ) import Language.LSP.Protocol.Types import Language.LSP.Server (LspM, getVirtualFile)-import Language.LSP.VFS (VirtualFile, virtualFileText, virtualFileVersion)+import Language.LSP.VFS (VFS, VirtualFile, vfsMap, virtualFileText, virtualFileVersion)+import Language.LSP.VFS qualified as VFS  -- | Retrieve hover info for the definition referenced at the given -- file at the given line and column number (the two 'Int's).@@ -126,3 +132,21 @@ rangeFromLoc :: Loc -> Range rangeFromLoc (Loc start end) = Range (getStartPos start) (getEndPos end) rangeFromLoc NoLoc = Range (Position 0 0) (Position 0 5) -- only when file not found, throw error after moving to vfs++-- | Transform VFS to a map of file paths to file contents.+-- This is used to pass the file contents to the compiler.+transformVFS :: VFS -> M.Map FilePath T.Text+transformVFS vfs =+  M.foldrWithKey+    ( \uri virtual_file acc ->+        case uriToNormalizedFilePath uri of+          Nothing -> acc+          Just file_path ->+            M.insert (fromNormalizedFilePath file_path) (virtualFileText virtual_file) acc+    )+    M.empty+    (M.mapMaybe keepOpenFile (vfs ^. vfsMap))+  where+    keepOpenFile = \case+      VFS.Open file -> Just file+      VFS.Closed _ -> Nothing
src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs view
@@ -314,7 +314,7 @@ aggSummaryLoopTotal scope_bef scope_loop scals_loop _ access   | Set ls <- translateAccessSummary scope_loop scals_loop access,     nms <- foldl (<>) mempty $ map freeIn $ S.toList ls,-    all inBeforeScope $ namesToList nms = do+    allNames inBeforeScope nms =       pure $ Set ls   where     inBeforeScope v =
src/Futhark/Optimise/BlkRegTiling.hs view
@@ -720,7 +720,7 @@ mkTileMemSizes height_A _width_B common_dim is_B_not_transp = do   tk_name <- nameFromText . prettyText <$> newVName "Tk"   ty_name <- nameFromText . prettyText <$> newVName "Ty"-  ry_name <- nameFromString . prettyString <$> newVName "Ry"+  ry_name <- nameFromText . prettyText <$> newVName "Ry"    -- until we change the copying to use lmads we need to   --   guarantee that Tx=Ty AND Rx = Ry AND Tx | Tk@@ -1057,8 +1057,8 @@             (M.empty, M.empty)             $ M.toList arr_tab0 -        tx_name <- nameFromString . prettyString <$> newVName "Tx"-        ty_name <- nameFromString . prettyString <$> newVName "Ty"+        tx_name <- nameFromText . prettyText <$> newVName "Tx"+        ty_name <- nameFromText . prettyText <$> newVName "Ty"          tx0 <- letSubExp "Tx" $ Op $ SizeOp $ GetSize tx_name SizeTile         ty0 <- letSubExp "Ty" $ Op $ SizeOp $ GetSize ty_name SizeTile
src/Futhark/Optimise/Fusion.hs view
@@ -31,15 +31,17 @@ data FusionEnv = FusionEnv   { vNameSource :: VNameSource,     fusionCount :: Int,-    fuseScans :: Bool+    fuseScans :: Bool,+    gas :: Maybe Int   } -freshFusionEnv :: FusionEnv-freshFusionEnv =+freshFusionEnv :: Maybe Int -> FusionEnv+freshFusionEnv gas =   FusionEnv     { vNameSource = blankNameSource,       fusionCount = 0,-      fuseScans = True+      fuseScans = True,+      gas = gas     }  newtype FusionM a = FusionM (ReaderT (Scope SOACS) (State FusionEnv) a)@@ -57,6 +59,15 @@   putNameSource source =     modify (\env -> env {vNameSource = source}) +useGas :: a -> FusionM a -> FusionM a+useGas g m = do+  is_out_of_gas <- gets (maybe False (<= 0) . gas)+  if is_out_of_gas+    then pure g+    else+      modify (\s -> s {gas = (\gas' -> max 0 (gas' - 1)) <$> gas s})+        >> m+ runFusionM :: (MonadFreshNames m) => Scope SOACS -> FusionEnv -> FusionM a -> m a runFusionM scope fenv (FusionM a) = modifyNameSource $ \src ->   let x = runReaderT a scope@@ -115,23 +126,24 @@ -- find the neighbors -> verify that fusion causes no cycles -> fuse vTryFuseNodesInGraph node_1 node_2 dg@DepGraph {dgGraph = g}   | not (G.gelem node_1 g && G.gelem node_2 g) = pure dg-  | vFusionFeasability dg node_1 node_2 = do-      let (ctx1, ctx2) = (G.context g node_1, G.context g node_2)-      fres <- vFuseContexts edgs infusable_nodes ctx1 ctx2-      case fres of-        Just (inputs, _, nodeT, outputs) -> do-          nodeT' <--            if null fusedC-              then pure nodeT-              else do-                let (_, _, _, deps_1) = ctx1-                    (_, _, _, deps_2) = ctx2-                    -- make copies of everything that was not-                    -- previously consumed-                    old_cons = map (getName . fst) $ filter (isCons . fst) (deps_1 <> deps_2)-                makeCopiesOfFusedExcept old_cons nodeT-          contractEdge node_2 (inputs, node_1, nodeT', outputs) dg-        Nothing -> pure dg+  | vFusionFeasability dg node_1 node_2 =+      useGas dg $ do+        let (ctx1, ctx2) = (G.context g node_1, G.context g node_2)+        fres <- vFuseContexts edgs infusable_nodes ctx1 ctx2+        case fres of+          Just (inputs, _, nodeT, outputs) -> do+            nodeT' <-+              if null fusedC+                then pure nodeT+                else do+                  let (_, _, _, deps_1) = ctx1+                      (_, _, _, deps_2) = ctx2+                      -- make copies of everything that was not+                      -- previously consumed+                      old_cons = map (getName . fst) $ filter (isCons . fst) (deps_1 <> deps_2)+                  makeCopiesOfFusedExcept old_cons nodeT+            contractEdge node_2 (inputs, node_1, nodeT', outputs) dg+          Nothing -> pure dg   | otherwise = pure dg   where     edgs = map G.edgeLabel $ edgesBetween dg node_1 node_2@@ -144,11 +156,12 @@ hTryFuseNodesInGraph :: G.Node -> G.Node -> DepGraphAug FusionM hTryFuseNodesInGraph node_1 node_2 dg@DepGraph {dgGraph = g}   | not (G.gelem node_1 g && G.gelem node_2 g) = pure dg-  | hFusionFeasability dg node_1 node_2 = do-      fres <- hFuseContexts (G.context g node_1) (G.context g node_2)-      case fres of-        Just ctx -> contractEdge node_2 ctx dg-        Nothing -> pure dg+  | hFusionFeasability dg node_1 node_2 =+      useGas dg $ do+        fres <- hFuseContexts (G.context g node_1) (G.context g node_2)+        case fres of+          Just ctx -> contractEdge node_2 ctx dg+          Nothing -> pure dg   | otherwise = pure dg  hFuseContexts :: DepContext -> DepContext -> FusionM (Maybe DepContext)@@ -559,10 +572,13 @@ -- Fixed-point iteration. keepTrying :: DepGraphAug FusionM -> DepGraphAug FusionM keepTrying f g = do-  prev_fused <- gets fusionCount-  g' <- f g-  aft_fused <- gets fusionCount-  if prev_fused /= aft_fused then keepTrying f g' else pure g'+  useGas g $ do+    prev_fused <- gets fusionCount+    g' <- f g+    aft_fused <- gets fusionCount+    if prev_fused /= aft_fused+      then keepTrying f g'+      else pure g'  doAllFusion :: DepGraphAug FusionM doAllFusion =@@ -623,16 +639,17 @@  doFusionInLambda :: Lambda SOACS -> FusionM (Lambda SOACS, Bool) doFusionInLambda lam = do-  -- To clean up previous instances of fusion.-  lam' <- simplifyLambda lam-  prev_count <- gets fusionCount-  newbody <- inScopeOf lam' $ doFusionBody $ lambdaBody lam'-  aft_count <- gets fusionCount-  -- To clean up any inner fusion.-  lam'' <--    (if prev_count /= aft_count then simplifyLambda else pure)-      lam' {lambdaBody = newbody}-  pure (lam'', prev_count /= aft_count)+  useGas (lam, False) $ do+    -- To clean up previous instances of fusion.+    lam' <- simplifyLambda lam+    prev_count <- gets fusionCount+    newbody <- inScopeOf lam' $ doFusionBody $ lambdaBody lam'+    aft_count <- gets fusionCount+    -- To clean up any inner fusion.+    lam'' <-+      (if prev_count /= aft_count then simplifyLambda else pure)+        lam' {lambdaBody = newbody}+    pure (lam'', prev_count /= aft_count)   where     doFusionBody :: Body SOACS -> FusionM (Body SOACS)     doFusionBody body = do@@ -646,32 +663,34 @@   graph_fused <- doAllFusion graph_not_fused   linearizeGraph graph_fused -fuseConsts :: [VName] -> Stms SOACS -> PassM (Stms SOACS)-fuseConsts outputs stms =+fuseConsts :: Maybe Int -> [VName] -> Stms SOACS -> PassM (Stms SOACS)+fuseConsts g outputs stms =   runFusionM     (scopeOf stms)-    freshFusionEnv+    (freshFusionEnv g)     (fuseGraph (mkBody stms (varsRes outputs))) -fuseFun :: Stms SOACS -> FunDef SOACS -> PassM (FunDef SOACS)-fuseFun consts fun = do+fuseFun :: Maybe Int -> Stms SOACS -> FunDef SOACS -> PassM (FunDef SOACS)+fuseFun g consts fun = do   fun_stms' <-     runFusionM       (scopeOf fun <> scopeOf consts)-      freshFusionEnv+      (freshFusionEnv g)       (fuseGraph (funDefBody fun))   pure fun {funDefBody = (funDefBody fun) {bodyStms = fun_stms'}} --- | The pass definition.+-- | Pass definition with an optional bound on the number of+-- iterations of the fusion convergence loop.  'Just n' runs at+-- most @n@ iterations; 'Nothing' means no bound (iterate until convergence). {-# NOINLINE fuseSOACs #-}-fuseSOACs :: Pass SOACS SOACS-fuseSOACs =+fuseSOACs :: Maybe Int -> Pass SOACS SOACS+fuseSOACs g =   Pass     { passName = "Fuse SOACs",       passDescription = "Perform higher-order optimisation, i.e., fusion.",       passFunction = \p ->         intraproceduralTransformationWithConsts-          (fuseConsts (namesToList $ freeIn (progFuns p)))-          fuseFun+          (fuseConsts g (namesToList $ freeIn (progFuns p)))+          (fuseFun g)           p     }
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -657,7 +657,7 @@  loopInvariantStm :: (ASTRep rep) => ST.SymbolTable rep -> Stm rep -> Bool loopInvariantStm vtable =-  all (`nameIn` ST.availableAtClosestLoop vtable) . namesToList . freeIn+  allNames (`nameIn` ST.availableAtClosestLoop vtable) . freeIn  matchBlocker ::   (SimplifiableRep rep) =>@@ -677,7 +677,7 @@       -- contributes to memory or array size, because that will allow       -- allocations to be hoisted.       cond_loop_invariant =-        all (`nameIn` ST.availableAtClosestLoop vtable) $ namesToList $ freeIn cond+        allNames (`nameIn` ST.availableAtClosestLoop vtable) $ freeIn cond        desirableToHoist usage stm =         is_alloc_fun stm
src/Futhark/Optimise/Simplify/Rules/Loop.hs view
@@ -159,9 +159,8 @@         (invariant, explpat', (mergeParam, mergeInit) : merge', resExp : resExps)      allExistentialInvariant namesOfInvariant mergeParam =-      all (invariantOrNotMergeParam namesOfInvariant) $-        namesToList $-          freeIn mergeParam `namesSubtract` oneName (paramName mergeParam)+      allNames (invariantOrNotMergeParam namesOfInvariant) $+        freeIn mergeParam `namesSubtract` oneName (paramName mergeParam)     invariantOrNotMergeParam namesOfInvariant name =       (name `notNameIn` namesOfLoopParams)         || (name `nameIn` namesOfInvariant)
src/Futhark/Optimise/Sink.hs view
@@ -102,7 +102,7 @@     sunkHere v stm =       v         `nameIn` free_in_stms-        && all (`ST.available` vtable) (namesToList (freeIn stm))+        && allNames (`ST.available` vtable) (freeIn stm)     sunk = namesFromList $ foldMap (patNames . stmPat) sunk_stms  optimiseLoop ::
src/Futhark/Optimise/TileLoops.hs view
@@ -278,7 +278,7 @@     invariantTo names stm =       case patNames (stmPat stm) of         [] -> True -- Does not matter.-        v : _ -> all (`notNameIn` names) (namesToList $ M.findWithDefault mempty v variance)+        v : _ -> allNames (`notNameIn` names) (M.findWithDefault mempty v variance)      consumed_in_prestms =       foldMap consumedInStm $ fst $ Alias.analyseStms mempty prestms@@ -1177,7 +1177,7 @@   gid_x <- newVName "gid_x"   gid_y <- newVName "gid_y" -  tile_size_key <- nameFromString . prettyString <$> newVName "tile_size"+  tile_size_key <- nameFromText . prettyText <$> newVName "tile_size"   tile_size <- letSubExp "tile_size" $ Op $ SizeOp $ GetSize tile_size_key SizeTile   tblock_size <- letSubExp "tblock_size" $ BasicOp $ BinOp (Mul Int64 OverflowUndef) tile_size tile_size
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -620,12 +620,12 @@                   =<< segmentedUpdateKernel nest' perm (stmAuxCerts aux) arr slice v                 pure acc'         _ -> addStmToAcc stm acc-maybeDistributeStm stm@(Let _ aux (BasicOp (Concat d (x :| xs) w))) acc =+maybeDistributeStm stm@(Let _ _ (BasicOp (Concat d (x :| xs) w))) acc =   distributeSingleStm acc stm >>= \case     Just (kernels, _, nest, acc') ->       localScope (typeEnvFromDistAcc acc') $         segmentedConcat nest-          >>= kernelOrNot (stmAuxCerts aux) stm acc kernels acc'+          >>= kernelOrNot mempty stm acc kernels acc'     _ ->       addStmToAcc stm acc   where@@ -633,7 +633,7 @@       isSegmentedOp nest [0] mempty mempty [] (x : xs) $         \pat _ _ _ (x' : xs') ->           let d' = d + length (snd nest) + 1-           in addStm $ Let pat aux $ BasicOp $ Concat d' (x' :| xs') w+           in addStm $ Let pat mempty $ BasicOp $ Concat d' (x' :| xs') w maybeDistributeStm stm acc =   addStmToAcc stm acc
src/Futhark/Pass/ExtractKernels/Intrablock.hs view
@@ -70,7 +70,7 @@   let available v =         v `M.member` outside_scope           && v `notElem` map kernelInputName inps-  unless (all available $ namesToList $ freeIn (wss_min ++ wss_avail)) $+  unless (allNames available $ freeIn (wss_min ++ wss_avail)) $     fail "Irregular parallelism"    ((intra_avail_par, kspace, read_input_stms), prelude_stms) <- lift $
src/Futhark/Passes.hs view
@@ -59,7 +59,7 @@       simplifySOACS,       performCSE True,       simplifySOACS,-      fuseSOACs,+      fuseSOACs Nothing,       performCSE True,       simplifySOACS,       removeDeadFunctions@@ -74,7 +74,7 @@     [ applyAD,       simplifySOACS,       performCSE True,-      fuseSOACs,+      fuseSOACs Nothing,       performCSE True,       simplifySOACS     ]
src/Futhark/Script.hs view
@@ -37,14 +37,13 @@ import Control.Monad import Control.Monad.Except (MonadError (..)) import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Bifunctor (bimap) import Data.Binary qualified as Bin import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Char import Data.Functor import Data.IORef-import Data.List (intersperse)+import Data.List (find, intersperse) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T@@ -58,14 +57,14 @@ import Futhark.Test.Values qualified as V import Futhark.Util (nubOrd) import Futhark.Util.Pretty hiding (line, sep, space, (</>))-import Language.Futhark.Core (Name, nameFromText, nameToText)+import Language.Futhark.Core (nameFromText, nameToText) import Language.Futhark.Tuple (areTupleFields, tupleFieldNames) import System.FilePath ((</>)) import Text.Megaparsec import Text.Megaparsec.Char (space) import Text.Megaparsec.Char.Lexer (charLiteral) -type TypeMap = M.Map TypeName (Maybe [(Name, TypeName)])+type TypeMap = M.Map TypeName (Maybe [Field])  typeMap :: (MonadIO m) => Server -> m TypeMap typeMap server = do@@ -73,14 +72,15 @@   where     onTypes types = M.fromList . zip types <$> mapM onType types     onType t =-      either (const Nothing) (Just . map onField) <$> cmdFields server t-    onField = bimap nameFromText (T.drop 1) . T.breakOn " "+      either (const Nothing) Just <$> cmdFields server t -isRecord :: TypeName -> TypeMap -> Maybe [(Name, TypeName)]+isRecord :: TypeName -> TypeMap -> Maybe [Field] isRecord t m = join $ M.lookup t m  isTuple :: TypeName -> TypeMap -> Maybe [TypeName]-isTuple t m = areTupleFields . M.fromList =<< isRecord t m+isTuple t m = areTupleFields . M.fromList . map unpack =<< isRecord t m+  where+    unpack (Field f ft) = (nameFromText f, ft)  -- | Like a 'Server', but keeps a bit more state to make FutharkScript -- more convenient.@@ -121,6 +121,7 @@   | Tuple [Exp]   | Record [(T.Text, Exp)]   | Project Exp T.Text+  | Index Exp [Exp]   | StringLit T.Text   | Let [VarName] Exp Exp   | -- | Server-side variable, *not* Futhark variable (these are@@ -150,6 +151,8 @@         parens $ commasep $ map (align . pretty) vs       pprPrec _ (Project e f) =         pprPrec 1 e <> "." <> pretty f+      pprPrec _ (Index e is) =+        pprPrec 1 e <> brackets (commasep $ map pretty is)       pprPrec _ (StringLit s) = pretty $ show s       pprPrec _ (Record m) = braces $ align $ commasep $ map field m         where@@ -166,11 +169,15 @@ inBraces :: Parser () -> Parser a -> Parser a inBraces sep = between (lexeme sep "{") (lexeme sep "}") +inBrackets :: Parser () -> Parser a -> Parser a+inBrackets sep = between (lexeme sep "[") (lexeme sep "]")+ -- | Parse a FutharkScript expression, given a whitespace parser. parseExp :: Parsec Void T.Text () -> Parsec Void T.Text Exp parseExp sep =   choice     [ pLet,+      try pIndex,       try $ Call <$> pFunc <*> some pAtom,       pAtom     ]@@ -222,15 +229,22 @@           FuncFut <$> lVarName         ] +    pIndex =+      Index+        <$> (Call . FuncFut <$> rawVarName <*> pure [])+        <*> inBrackets sep (parseExp sep `sepEndBy` pComma)+     reserved = ["let", "in"] -    lVarName = lexeme sep . try $ do+    rawVarName = do       v <- fmap T.pack $ (:) <$> satisfy isAlpha <*> many (satisfy constituent)       guard $ v `notElem` reserved       pure v       where         constituent c = isAlphaNum c || c == '\'' || c == '_' +    lVarName = lexeme sep $ try rawVarName+     lIntStr = lexeme sep . try . fmap T.pack $ some $ satisfy isDigit      pFieldName = lVarName <|> lIntStr@@ -495,11 +509,11 @@   (MonadIO m, MonadError T.Text m) =>   ScriptServer ->   T.Text ->-  (Name, b) ->+  Field ->   m VarName-getField server from (f, _) = do+getField server from (Field f _) = do   to <- newVar server "field"-  cmdMaybe $ cmdProject (scriptServer server) to from $ nameToText f+  cmdMaybe $ cmdProject (scriptServer server) to from f   pure to  unTuple ::@@ -511,7 +525,7 @@ 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 (k, kt)+        V.ValueAtom . SValue kt . VVar <$> getField server v (Field (nameToText k) kt) unTuple _ v = pure [v]  project ::@@ -526,15 +540,42 @@     Just v -> pure v project server (V.ValueAtom (SValue t (VVar v))) f   | Just fs <- isRecord t $ scriptTypes server =-      case lookup f' fs of+      case find ((== f) . fieldName) fs of         Nothing -> throwError $ "Type " <> t <> " does not have a field " <> f <> "."-        Just ft ->-          V.ValueAtom . SValue ft . VVar <$> getField server v (f', ft)-  where-    f' = nameFromText f+        Just (Field _ ft) ->+          V.ValueAtom . SValue ft . VVar <$> getField server v (Field f ft) project _ _ _ =   throwError "Cannot project from non-record." +index ::+  (MonadIO m, MonadError T.Text m) =>+  ScriptServer ->+  ExpValue ->+  [ExpValue] ->+  m ExpValue+index server (V.ValueAtom (SValue array_type (VVar array_var))) is = do+  shape <- cmdEither $ cmdShape (scriptServer server) array_var+  is' <- mapM asInt is+  unless (all inBounds $ zip shape is') $+    throwError $+      "Index "+        <> prettyText is'+        <> " out of bounds for array of shape "+        <> mconcat (map (prettyText . (: [])) shape)+        <> "."+  elem_var <- newVar server "field"+  cmdMaybe $ cmdIndex (scriptServer server) elem_var array_var is'+  let elem_type = T.drop (2 * length is) array_type -- UGH! XXX+  pure $ V.ValueAtom $ SValue elem_type $ VVar elem_var+  where+    asInt (V.ValueAtom (SValue _ (VVal v)))+      | Just x <- V.getValue v = pure $ fromInteger x+    asInt v = throwError $ "Invalid index type: " <> prettyText (fmap scriptValueType v)++    inBounds (d, i) = i >= 0 && i < d+index _ _ _ =+  throwError "Cannot index non-array."+ -- | Evaluate a FutharkScript expression relative to some running server. evalExp ::   forall m.@@ -588,12 +629,13 @@             mkRecord t =<< zipWithM (interValToVar bad) ts vs       interValToVar bad t (V.ValueRecord vs)         | Just fs <- isRecord t types,-          Just vs' <- mapM ((`M.lookup` vs) . nameToText . fst) fs =-            mkRecord t =<< zipWithM (interValToVar bad) (map snd fs) vs'+          Just vs' <- mapM ((`M.lookup` vs) . fieldName) fs =+            mkRecord t =<< zipWithM (interValToVar bad) (map fieldType fs) vs'       interValToVar _ t (V.ValueAtom (SValue vt (VVar v)))         | Just t_fs <- isRecord t types,           Just vt_fs <- isRecord vt types,-          vt_fs == t_fs =+          map fieldName vt_fs == map fieldName t_fs,+          map fieldType vt_fs == map fieldType t_fs =             mkRecord t =<< mapM (getField sserver v) vt_fs       interValToVar _ t (V.ValueAtom (SValue _ (VVal v)))         | Just v' <- coerceValue t v =@@ -619,6 +661,10 @@       evalExp' vtable (Project e f) = do         e' <- evalExp' vtable e         project sserver e' f+      evalExp' vtable (Index e is) = do+        e' <- evalExp' vtable e+        is' <- mapM (evalExp' vtable) is+        index sserver e' is'       evalExp' vtable (Call (FuncBuiltin name) es) =         builtin sserver name =<< mapM (evalExp' vtable) es       evalExp' vtable (Call (FuncFut name) es)@@ -704,7 +750,7 @@   throwError $ "Function " <> fname <> " not fully applied." getExpValue server (V.ValueAtom (SValue t (VVar v)))   | Just fs <- isRecord t types =-      tupleOrRecord . M.fromList . zip (map fst fs)+      tupleOrRecord . M.fromList . zip (map (nameFromText . fieldName) fs)         <$> mapM (onField v) fs   | not $ primArrayType t =       throwError $ "Type " <> t <> " has no external representation."@@ -716,8 +762,8 @@     tupleOrRecord m =       maybe (V.ValueRecord $ M.mapKeys nameToText m) V.ValueTuple $ areTupleFields m -    onField from (f, ft) = do-      to <- getField server from (f, ft)+    onField from (Field f ft) = do+      to <- getField server from $ Field f ft       getExpValue server $ V.ValueAtom $ SValue ft $ VVar to getExpValue server (V.ValueTuple vs) =   V.ValueTuple <$> traverse (getExpValue server) vs@@ -757,6 +803,7 @@ varsInExp :: Exp -> S.Set EntryName varsInExp ServerVar {} = mempty varsInExp (Project e _) = varsInExp e+varsInExp (Index e is) = varsInExp e <> foldMap varsInExp is varsInExp (Call (FuncFut v) es) = S.insert v $ foldMap varsInExp es varsInExp (Call (FuncBuiltin _) es) = foldMap varsInExp es varsInExp (Tuple es) = foldMap varsInExp es
src/Language/Futhark/FreeVars.hs view
@@ -83,8 +83,7 @@   OpSection {} -> mempty   OpSectionLeft _ _ e _ _ _ -> freeInExp e   OpSectionRight _ _ e _ _ _ -> freeInExp e-  ProjectSection {} -> mempty-  IndexSection idxs _ _ -> foldMap freeInDimIndex idxs+  UpdateSection steps _ _ -> foldMap freeInUpdateStep steps   AppExp (Loop sparams pat e1 form e3 _) _ ->     let (e2fv, e2ident) = formVars form      in freeInExp (loopInitExp e1)@@ -100,14 +99,14 @@       <> freeInExp e1       <> freeInExp e2   Project _ e _ _ -> freeInExp e-  AppExp (LetWith id1 id2 idxs e1 e2 _) _ ->+  AppExp (LetWith id1 id2 steps e1 e2 _) _ ->     ident id2-      <> foldMap freeInDimIndex idxs+      <> foldMap freeInUpdateStep steps       <> freeInExp e1       <> (freeInExp e2 `freeWithout` S.singleton (identName id1))   AppExp (Index e idxs _) _ -> freeInExp e <> foldMap freeInDimIndex idxs-  Update e1 idxs e2 _ -> freeInExp e1 <> foldMap freeInDimIndex idxs <> freeInExp e2-  RecordUpdate e1 _ e2 _ _ -> freeInExp e1 <> freeInExp e2+  Update e1 steps e2 _ _ ->+    freeInExp e1 <> foldMap freeInUpdateStep steps <> freeInExp e2   Assert e1 e2 _ _ -> freeInExp e1 <> freeInExp e2   Constr _ es _ _ -> foldMap freeInExp es   Attr _ e _ -> freeInExp e@@ -116,6 +115,10 @@       caseFV (CasePat p eCase _) =         (freeInPat p <> freeInExp eCase)           `freeWithoutL` patNames p++freeInUpdateStep :: UpdateStep Info VName -> FV+freeInUpdateStep (UpdateStepSlice idxs) = foldMap freeInDimIndex idxs+freeInUpdateStep (UpdateStepField _) = mempty  freeInDimIndex :: DimIndexBase Info VName -> FV freeInDimIndex (DimFix e) = freeInExp e
src/Language/Futhark/Interpreter.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE Strict #-}+ -- | An interpreter operating on type-checked source Futhark terms. -- Relatively slow. module Language.Futhark.Interpreter@@ -44,7 +46,7 @@   ) import Data.List qualified as L import Data.List.NonEmpty qualified as NE-import Data.Map qualified as M+import Data.Map.Strict qualified as M import Data.Maybe import Data.Monoid hiding (Sum) import Data.Ord@@ -909,14 +911,11 @@   is' <- mapM (evalDimIndex env) is   arr <- eval env e   evalIndex loc env is' arr-evalAppExp env (LetWith dest src is v body loc) = do+evalAppExp env (LetWith dest src steps v body loc) = do   let Ident src_vn (Info src_t) _ = src-  dest' <--    maybe oob pure-      =<< writeArray-        <$> mapM (evalDimIndex env) is-        <*> evalTermVar env (qualName src_vn) (toStruct src_t)-        <*> eval env v+  src_v <- evalTermVar env (qualName src_vn) (toStruct src_t)+  v' <- eval env v+  dest' <- maybe oob pure =<< evalUpdateSteps env steps src_v v'   let t = T.BoundV [] $ toStruct $ unInfo $ identType dest   eval (valEnv (M.singleton (identName dest) (Just t, dest')) <> env) body   where@@ -1053,19 +1052,13 @@   apply loc env intrinsicsNeg ev eval env (Not e loc) =   apply loc env intrinsicsNot =<< eval env e-eval env (Update src is v loc) =-  maybe oob pure-    =<< writeArray <$> mapM (evalDimIndex env) is <*> eval env src <*> eval env v+eval env (Update src steps v _ loc) = do+  src' <- eval env src+  v' <- eval env v+  res <- evalUpdateSteps env steps src' v'+  maybe oob pure res   where     oob = bad loc env "Bad update"-eval env (RecordUpdate src all_fs v _ _) =-  update <$> eval env src <*> pure all_fs <*> eval env v-  where-    update _ [] v' = v'-    update (ValueRecord src') (f : fs) v'-      | Just f_v <- M.lookup f src' =-          ValueRecord $ M.insert f (update f_v fs v') src'-    update _ _ _ = error "eval RecordUpdate: invalid value." -- We treat zero-parameter lambdas as simply an expression to -- evaluate immediately.  Note that this is *not* the same as a lambda -- that takes an empty tuple '()' as argument!  Zero-parameter lambdas@@ -1085,15 +1078,18 @@     ValueFun $ \x -> do       f <- evalTermVar env qv $ toStruct t       apply2 loc env f x y-eval env (IndexSection is _ loc) = do-  is' <- mapM (evalDimIndex env) is-  pure $ ValueFun $ evalIndex loc env is'-eval _ (ProjectSection ks _ _) =-  pure $ ValueFun $ flip (foldM walk) ks+eval env (UpdateSection steps _ loc) =+  pure $ ValueFun $ evalSection steps   where-    walk (ValueRecord fs) f-      | Just v' <- M.lookup f fs = pure v'-    walk _ _ = error "Value does not have expected field."+    evalSection [] v = pure v+    evalSection (UpdateStepField f : rest) (ValueRecord fs)+      | Just v' <- M.lookup f fs =+          evalSection rest v'+    evalSection (UpdateStepField _ : _) _ =+      error "Value does not have expected field."+    evalSection (UpdateStepSlice is : rest) arr = do+      is' <- mapM (evalDimIndex env) is+      evalIndex loc env is' arr >>= evalSection rest eval env (Project f e _ _) = do   project f <$> eval env e eval env (Assert what e (Info s) loc) = do@@ -1117,6 +1113,26 @@   pure v eval env (Attr _ e _) =   eval env e++evalUpdateSteps :: Env -> [UpdateStep Info VName] -> Value -> Value -> EvalM (Maybe Value)+evalUpdateSteps env = go+  where+    go [] _ newv = pure $ Just newv+    go (UpdateStepField f : rest) (ValueRecord fs) newv+      | Just old <- M.lookup f fs = do+          newf <- go rest old newv+          pure $ fmap (\v' -> ValueRecord $ M.insert f v' fs) newf+    go (UpdateStepField _ : _) _ _ =+      error "eval update: invalid field update."+    go (UpdateStepSlice is : rest) arr newv = do+      is' <- mapM (evalDimIndex env) is+      case indexArray is' arr of+        Nothing -> pure Nothing+        Just old -> do+          newsub <- go rest old newv+          case newsub of+            Nothing -> pure Nothing+            Just vsub -> pure $ writeArray is' arr vsub  evalCase ::   Value ->
src/Language/Futhark/Parser/Parser.y view
@@ -40,6 +40,8 @@  } +%expect 0+ %name prog Prog %name futharkType TypeExp %name expression Exp@@ -574,14 +576,8 @@      | Atom '..' Exp2            {% twoDotsRange $2 }      | '-' Exp2  %prec juxtprec  { Negate $2 (srcspan $1 $>) }      | '!' Exp2 %prec juxtprec   { Not $2 (srcspan $1 $>) }--     | Exp2 with '[' DimIndices ']' '=' Exp2-       { Update $1 $4 $7 (srcspan $1 $>) }-     | Exp2 with '...[' DimIndices ']' '=' Exp2-       { Update $1 $4 $7 (srcspan $1 $>) }--     | Exp2 with FieldAccesses_ '=' Exp2-       { RecordUpdate $1 (map unLoc $3) $5 NoInfo (srcspan $1 $>) }+     | Exp2 with Update '=' Exp2+       { Update $1 $3 $5 NoInfo (srcspan $1 $>) }       | ApplyList {% applyExp $1 } @@ -669,13 +665,39 @@         | Exps1_ ','     { $1 }         | Exp            { [$1] } -FieldAccesses :: { [L Name] }-               : '.' FieldId FieldAccesses { $2 : $3 }-               |                           { [] }+Update :: { [UpdateStep NoInfo Name] }+           : UpdateStep UpdateTail { $1 : $2 } -FieldAccesses_ :: { [L Name] }-               : FieldId FieldAccesses { $1 : $2 }+UpdateTail :: { [UpdateStep NoInfo Name] }+               : UpdateStep UpdateTail { $1 : $2 }+               |                              { [] } +UpdateStep :: { UpdateStep NoInfo Name }+               : '[' DimIndices ']'    { UpdateStepSlice $2 }+               | '...[' DimIndices ']' { UpdateStepSlice $2 }+               | FieldId               { UpdateStepField (unLoc $1) }+               | '.' FieldId           { UpdateStepField (unLoc $2) }++LetUpdate :: { [UpdateStep NoInfo Name] }+          : LetUpdateStep LetUpdateTail { $1 : $2 }++LetUpdateTail :: { [UpdateStep NoInfo Name] }+              : LetUpdateStep LetUpdateTail { $1 : $2 }+              |                             { [] }++LetUpdateStep :: { UpdateStep NoInfo Name }+              : '...[' DimIndices ']' { UpdateStepSlice $2 }+              | '.' FieldId           { UpdateStepField (unLoc $2) }++SectionUpdate :: { [UpdateStep NoInfo Name] }+              : '.' FieldId SectionUpdateTail            { UpdateStepField (unLoc $2) : $3 }+              | '.' '[' DimIndices ']' SectionUpdateTail { UpdateStepSlice $3 : $5 }++SectionUpdateTail :: { [UpdateStep NoInfo Name] }+                  : '.' FieldId SectionUpdateTail           { UpdateStepField (unLoc $2) : $3 }+                  | '...[' DimIndices ']' SectionUpdateTail { UpdateStepSlice $2 : $4 }+                  |                                         { [] }+ Field :: { FieldBase NoInfo Name }        : FieldId '=' Exp { RecordFieldExplicit $1 $3 (srcspan $1 $>) }        | id              { let L loc (ID s) = $1 in RecordFieldImplicit (L loc s) NoInfo (srclocOf loc) }@@ -692,14 +714,17 @@        { AppExp (LetPat [] $2 $4 $5 (srcspan $1 $>)) NoInfo }       | let id LocalFunTypeParams FunParams1 maybeAscription(TypeExp) '=' Exp LetBody-       { let L nameloc (ID name) = $2-           in AppExp (LetFun (name, srclocOf nameloc) ($3, fst $4 : snd $4, $5, NoInfo, $7)-                     $8 (srcspan $1 $>))-                     NoInfo}+       { let { L nameloc (ID name) = $2 }+         in AppExp (LetFun (name, srclocOf nameloc) ($3, fst $4 : snd $4, $5, NoInfo, $7)+                    $8 (srcspan $1 $>)) NoInfo+       } -     | let id '...[' DimIndices ']' '=' Exp LetBody-       { let L vloc (ID v) = $2; ident = Ident v NoInfo (srclocOf vloc)-         in AppExp (LetWith ident ident $4 $7 $8 (srcspan $1 $>)) NoInfo }+     | let id LetUpdate '=' Exp LetBody+       { let { L vloc (ID v) = $2+             ; ident = Ident v NoInfo (srclocOf vloc)+             }+         in AppExp (LetWith ident ident $3 $5 $6 (srcspan $1 $>)) NoInfo+       }  LetBody :: { UncheckedExp }     : in Exp %prec letprec { $2 }@@ -754,11 +779,8 @@   | '(' BinOp ')'     { OpSection (fst $2) NoInfo (srcspan $1 $>) } -  | '(' '.' FieldAccesses_ ')'-    { ProjectSection (map unLoc $3) NoInfo (srcspan $1 $>) }--  | '(' '.' '[' DimIndices ']' ')'-    { IndexSection $4 NoInfo (srcspan $1 $>) }+  | '(' SectionUpdate ')'+    { UpdateSection $2 NoInfo (srcspan $1 $>) }  RangeExp :: { UncheckedExp }   : Exp2 '...' Exp2           { AppExp (Range $1 Nothing (ToInclusive $3) (srcspan $1 $>)) NoInfo }
src/Language/Futhark/Pretty.hs view
@@ -16,7 +16,6 @@ import Control.Monad import Data.Char (chr) import Data.Functor-import Data.List (intersperse) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as M import Data.Maybe@@ -271,11 +270,11 @@     retdecl' = case (pretty <$> unAnnot rettype) `mplus` (pretty <$> retdecl) of       Just rettype' -> colon <+> align rettype'       Nothing -> mempty-prettyAppExp _ (LetWith dest src idxs ve body _)+prettyAppExp _ (LetWith dest src steps ve body _)   | dest == src =       "let"         <+> pretty dest-        <> list (map pretty idxs)+        <> prettyLetLhsUpdate steps           <+> equals           <+> align (pretty ve)           </> letBody body@@ -285,7 +284,7 @@         <+> equals         <+> pretty src         <+> "with"-        <+> brackets (commasep (map pretty idxs))+        <+> prettyUpdate steps         <+> "="         <+> align (pretty ve)         </> letBody body@@ -309,6 +308,12 @@     prettyExp 0 f       <+> hsep (map (prettyExp 10 . snd) $ NE.toList args) +prettyLetLhsUpdate :: (IsName vn, Annot f) => [UpdateStep f vn] -> Doc a+prettyLetLhsUpdate = mconcat . map pp+  where+    pp (UpdateStepSlice idxs) = brackets (commasep (map pretty idxs))+    pp (UpdateStepField f) = "." <> pretty f+ instance (IsName vn, Annot f) => Pretty (AppExpBase f vn) where   pretty = prettyAppExp (-1) @@ -364,16 +369,10 @@ prettyExp _ (Project k e _ _) = prettyExp 11 e <> "." <> pretty k prettyExp _ (Negate e _) = "-" <> pretty e prettyExp _ (Not e _) = "!" <> pretty e-prettyExp _ (Update src idxs ve _) =-  pretty src-    <+> "with"-    <+> brackets (commasep (map pretty idxs))-    <+> "="-    <+> align (pretty ve)-prettyExp _ (RecordUpdate src fs ve _ _) =+prettyExp _ (Update src steps ve _ _) =   pretty src     <+> "with"-    <+> mconcat (intersperse "." (map pretty fs))+    <+> prettyUpdate steps     <+> "="     <+> align (pretty ve) prettyExp _ (Assert e1 e2 _ _) =@@ -391,12 +390,12 @@   parens $ pretty x <+> ppBinOp binop prettyExp _ (OpSectionRight binop _ x _ _ _) =   parens $ ppBinOp binop <+> pretty x-prettyExp _ (ProjectSection fields _ _) =-  parens $ mconcat $ map p fields+prettyExp _ (UpdateSection steps _ _) =+  parens $ mconcat $ zipWith p [(0 :: Int) ..] steps   where-    p name = "." <> pretty name-prettyExp _ (IndexSection idxs _ _) =-  parens $ "." <> brackets (commasep (map pretty idxs))+    p _ (UpdateStepField name) = "." <> pretty name+    p 0 (UpdateStepSlice idxs) = "." <> brackets (commasep (map pretty idxs))+    p _ (UpdateStepSlice idxs) = brackets (commasep (map pretty idxs)) prettyExp p (Constr n cs t _) =   parensIf (p >= 10) $     "#" <> pretty n <+> sep (map (prettyExp 10) cs) <> prettyInst t@@ -410,6 +409,16 @@         </> "@"         <> parens (pretty t <> "," <+> brackets (commasep $ map prettyName ext))   | otherwise = prettyAppExp i e++prettyUpdate :: (IsName vn, Annot f) => [UpdateStep f vn] -> Doc a+prettyUpdate = mconcat . zipWith pp [0 :: Int ..]+  where+    pp _ (UpdateStepSlice idxs) =+      brackets (commasep (map pretty idxs))+    pp 0 (UpdateStepField f) =+      pretty f+    pp _ (UpdateStepField f) =+      "." <> pretty f  instance (IsName vn, Annot f) => Pretty (ExpBase f vn) where   pretty = prettyExp (-1)
src/Language/Futhark/Primitive.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}  -- | Definitions of primitive types, the values that inhabit these -- types, and operations on these values.  A primitive value can also@@ -138,6 +139,7 @@ import Futhark.Util (convFloat) import Futhark.Util.CMath import Futhark.Util.Pretty+import GHC.Exts (Double (D#), Float (F#), fmaddDouble#, fmaddFloat#) import Numeric (log1p) import Numeric.Half import Prelude hiding (id, (.))@@ -1036,6 +1038,7 @@  -- | Compare any two primtive values for exact equality. doCmpEq :: PrimValue -> PrimValue -> Bool+doCmpEq (FloatValue (Float16Value v1)) (FloatValue (Float16Value v2)) = v1 == v2 doCmpEq (FloatValue (Float32Value v1)) (FloatValue (Float32Value v2)) = v1 == v2 doCmpEq (FloatValue (Float64Value v1)) (FloatValue (Float64Value v2)) = v1 == v2 doCmpEq v1 v2 = v1 == v2@@ -1568,9 +1571,9 @@       f16_3 "mad16" (\a b c -> a * b + c),       f32_3 "mad32" (\a b c -> a * b + c),       f64_3 "mad64" (\a b c -> a * b + c),-      f16_3 "fma16" (\a b c -> a * b + c),-      f32_3 "fma32" (\a b c -> a * b + c),-      f64_3 "fma64" (\a b c -> a * b + c)+      f16_3 "fma16" fma16,+      f32_3 "fma32" (\(F# a) (F# b) (F# c) -> F# (fmaddFloat# a b c)),+      f64_3 "fma64" (\(D# a) (D# b) (D# c) -> D# (fmaddDouble# a b c))     ]       <> [ ( condFun t,              ( [Bool, t, t],@@ -1584,6 +1587,10 @@          | t <- allPrimTypes          ]   where+    fma16 a b c+      | isNaN a || isInfinite a || isNaN b || isInfinite b = a * b + c+      | isNaN c || isInfinite c = c+      | otherwise = fromRational (toRational a * toRational b + toRational c)     i8 s f = (s, ([IntType Int8], IntType Int32, i8PrimFun f))     i16 s f = (s, ([IntType Int16], IntType Int32, i16PrimFun f))     i32 s f = (s, ([IntType Int32], IntType Int32, i32PrimFun f))
src/Language/Futhark/Prop.hs view
@@ -494,8 +494,7 @@ typeOf (Coerce _ _ (Info t) _) = t typeOf (Negate e _) = typeOf e typeOf (Not e _) = typeOf e-typeOf (Update e _ _ _) = typeOf e-typeOf (RecordUpdate _ _ _ (Info t) _) = t+typeOf (Update _ _ _ (Info t) _) = t typeOf (Assert _ e _ _) = typeOf e typeOf (Lambda params _ _ (Info t) _) = funType params t typeOf (OpSection _ (Info t) _) = t@@ -503,8 +502,7 @@   Scalar $ Arrow mempty pn (diet pt2) (toStruct pt2) ret typeOf (OpSectionRight _ _ _ (Info (pn, pt1), _) (Info ret) _) =   Scalar $ Arrow mempty pn (diet pt1) (toStruct pt1) ret-typeOf (ProjectSection _ (Info t) _) = t-typeOf (IndexSection _ (Info t) _) = t+typeOf (UpdateSection _ (Info t) _) = t typeOf (Constr _ _ (Info t) _) = t typeOf (Attr _ e _) = typeOf e typeOf (AppExp _ (Info res)) = appResType res@@ -645,7 +643,7 @@ namesToPrimTypes :: M.Map Name PrimType namesToPrimTypes =   M.fromList-    [ (nameFromString $ prettyString t, t)+    [ (nameFromText $ prettyText t, t)     | t <-         Bool           : map Signed [minBound .. maxBound]@@ -1456,21 +1454,30 @@   | length es1 == length es2,     n1 == n2 =       Just $ zip es1 es2-similarExps (Update e1 slice1 e'1 _) (Update e2 slice2 e'2 _) =-  ([(e1, e2), (e'1, e'2)] ++) <$> similarSlices slice1 slice2-similarExps (RecordUpdate e1 names1 e'1 _ _) (RecordUpdate e2 names2 e'2 _ _)-  | names1 == names2 =-      Just [(e1, e2), (e'1, e'2)]+similarExps (Update e1 steps1 e'1 _ _) (Update e2 steps2 e'2 _ _)+  | length steps1 == length steps2 = do+      step_pairs <- concat <$> zipWithM similarStep steps1 steps2+      pure $ [(e1, e2), (e'1, e'2)] ++ step_pairs+  where+    similarStep (UpdateStepField f1) (UpdateStepField f2)+      | f1 == f2 = Just []+    similarStep (UpdateStepSlice s1) (UpdateStepSlice s2) =+      similarSlices s1 s2+    similarStep _ _ = Nothing similarExps (OpSection op1 _ _) (OpSection op2 _ _)   | op1 == op2 = Just [] similarExps (OpSectionLeft op1 _ x1 _ _ _) (OpSectionLeft op2 _ x2 _ _ _)   | op1 == op2 = Just [(x1, x2)] similarExps (OpSectionRight op1 _ x1 _ _ _) (OpSectionRight op2 _ x2 _ _ _)   | op1 == op2 = Just [(x1, x2)]-similarExps (ProjectSection names1 _ _) (ProjectSection names2 _ _)-  | names1 == names2 = Just []-similarExps (IndexSection slice1 _ _) (IndexSection slice2 _ _) =-  similarSlices slice1 slice2+similarExps (UpdateSection steps1 _ _) (UpdateSection steps2 _ _)+  | length steps1 == length steps2 = concat <$> zipWithM similarStep steps1 steps2+  where+    similarStep (UpdateStepField f1) (UpdateStepField f2)+      | f1 == f2 = Just []+    similarStep (UpdateStepSlice s1) (UpdateStepSlice s2) =+      similarSlices s1 s2+    similarStep _ _ = Nothing similarExps _ _ = Nothing  -- | Are these the same expression as per recursively invoking
src/Language/Futhark/Syntax.hs view
@@ -57,6 +57,7 @@     AppExpBase (..),     AppRes (..),     ExpBase (..),+    UpdateStep (..),     FieldBase (..),     CaseBase (..),     LoopInitBase (..),@@ -739,7 +740,7 @@   | LetWith       (IdentBase f vn StructType)       (IdentBase f vn StructType)-      (SliceBase f vn)+      [UpdateStep f vn]       (ExpBase f vn)       (ExpBase f vn)       SrcLoc@@ -771,6 +772,22 @@   locOf (Loop _ _ _ _ _ loc) = locOf loc   locOf (Match _ _ loc) = locOf loc +data UpdateStep f vn+  = UpdateStepSlice (SliceBase f vn)+  | UpdateStepField Name++deriving instance Show (UpdateStep Info VName)++deriving instance (Show vn) => Show (UpdateStep NoInfo vn)++deriving instance Eq (UpdateStep NoInfo VName)++deriving instance Ord (UpdateStep NoInfo VName)++deriving instance Eq (UpdateStep Info VName)++deriving instance Ord (UpdateStep Info VName)+ -- | An annotation inserted by the type checker on constructs that are -- "function calls" (either literally or conceptually).  This -- annotation encodes the result type, as well as any existential@@ -828,8 +845,7 @@     Assert (ExpBase f vn) (ExpBase f vn) (f T.Text) SrcLoc   | -- | An n-ary value constructor.     Constr Name [ExpBase f vn] (f StructType) SrcLoc-  | Update (ExpBase f vn) (SliceBase f vn) (ExpBase f vn) SrcLoc-  | RecordUpdate (ExpBase f vn) [Name] (ExpBase f vn) (f StructType) SrcLoc+  | Update (ExpBase f vn) [UpdateStep f vn] (ExpBase f vn) (f StructType) SrcLoc   | Lambda       [PatBase f vn ParamType]       (ExpBase f vn)@@ -854,10 +870,8 @@       (f (PName, ParamType), f (PName, ParamType, Maybe VName))       (f ResRetType)       SrcLoc-  | -- | Field projection as a section: @(.x.y.z)@.-    ProjectSection [Name] (f StructType) SrcLoc-  | -- | Array indexing as a section: @(.[i,j])@.-    IndexSection (SliceBase f vn) (f StructType) SrcLoc+  | -- | Field projection and array indexing as a section, e.g. @(.x)@, @(.[i,j])@, @(.[0].x)@.+    UpdateSection [UpdateStep f vn] (f StructType) SrcLoc   | -- | Type ascription: @e : t@.     Ascript (ExpBase f vn) (TypeExp (ExpBase f vn) vn) SrcLoc   | -- | Size coercion: @e :> t@.@@ -893,19 +907,17 @@   locOf (Coerce _ _ _ loc) = locOf loc   locOf (Negate _ pos) = locOf pos   locOf (Not _ pos) = locOf pos-  locOf (Update _ _ _ pos) = locOf pos-  locOf (RecordUpdate _ _ _ _ pos) = locOf pos   locOf (Lambda _ _ _ _ loc) = locOf loc   locOf (Hole _ loc) = locOf loc   locOf (OpSection _ _ loc) = locOf loc   locOf (OpSectionLeft _ _ _ _ _ loc) = locOf loc   locOf (OpSectionRight _ _ _ _ _ loc) = locOf loc-  locOf (ProjectSection _ _ loc) = locOf loc-  locOf (IndexSection _ _ loc) = locOf loc+  locOf (UpdateSection _ _ loc) = locOf loc   locOf (Assert _ _ _ loc) = locOf loc   locOf (Constr _ _ _ loc) = locOf loc   locOf (Attr _ _ loc) = locOf loc   locOf (AppExp e _) = locOf e+  locOf (Update _ _ _ _ pos) = locOf pos  -- | An entry in a record literal. data FieldBase f vn
src/Language/Futhark/Traversals.hs view
@@ -94,14 +94,17 @@           )       <*> mapOnExp tv body       <*> pure loc-  astMap tv (LetWith dest src idxexps vexp body loc) =+  astMap tv (LetWith dest src steps vexp body loc) =     LetWith       <$> astMap tv dest       <*> astMap tv src-      <*> mapM (astMap tv) idxexps+      <*> mapM mapStep steps       <*> mapOnExp tv vexp       <*> mapOnExp tv body       <*> pure loc+    where+      mapStep (UpdateStepSlice slice) = UpdateStepSlice <$> mapM (astMap tv) slice+      mapStep (UpdateStepField f) = pure $ UpdateStepField f   astMap tv (BinOp (fname, fname_loc) t (x, xext) (y, yext) loc) =     BinOp       <$> ((,) <$> mapOnName tv fname <*> pure fname_loc)@@ -158,19 +161,16 @@     Negate <$> mapOnExp tv x <*> pure loc   astMap tv (Not x loc) =     Not <$> mapOnExp tv x <*> pure loc-  astMap tv (Update src slice v loc) =+  astMap tv (Update src steps v (Info t) loc) =     Update       <$> mapOnExp tv src-      <*> mapM (astMap tv) slice-      <*> mapOnExp tv v-      <*> pure loc-  astMap tv (RecordUpdate src fs v (Info t) loc) =-    RecordUpdate-      <$> mapOnExp tv src-      <*> pure fs+      <*> mapM mapStep steps       <*> mapOnExp tv v       <*> (Info <$> mapOnStructType tv t)       <*> pure loc+    where+      mapStep (UpdateStepSlice slice) = UpdateStepSlice <$> mapM (astMap tv) slice+      mapStep (UpdateStepField f) = pure $ UpdateStepField f   astMap tv (Project field e t loc) =     Project field <$> mapOnExp tv e <*> traverse (mapOnStructType tv) t <*> pure loc   astMap tv (Assert e1 e2 desc loc) =@@ -209,13 +209,14 @@           )       <*> traverse (mapOnResRetType tv) t2       <*> pure loc-  astMap tv (ProjectSection fields t loc) =-    ProjectSection fields <$> traverse (mapOnStructType tv) t <*> pure loc-  astMap tv (IndexSection idxs t loc) =-    IndexSection-      <$> mapM (astMap tv) idxs+  astMap tv (UpdateSection steps t loc) =+    UpdateSection+      <$> mapM mapStep steps       <*> traverse (mapOnStructType tv) t       <*> pure loc+    where+      mapStep (UpdateStepField f) = pure $ UpdateStepField f+      mapStep (UpdateStepSlice idxs) = UpdateStepSlice <$> mapM (astMap tv) idxs   astMap tv (Constr name es t loc) =     Constr name <$> traverse (mapOnExp tv) es <*> traverse (mapOnStructType tv) t <*> pure loc   astMap tv (Attr attr e loc) =@@ -438,6 +439,10 @@ bareSizeExp (SizeExp e loc) = SizeExp (bareExp e) loc bareSizeExp (SizeExpAny loc) = SizeExpAny loc +bareUpdateStep :: UpdateStep Info VName -> UpdateStep NoInfo VName+bareUpdateStep (UpdateStepSlice slice) = UpdateStepSlice $ map bareDimIndex slice+bareUpdateStep (UpdateStepField f) = UpdateStepField f+ bareTypeExp :: TypeExp (ExpBase Info VName) VName -> TypeExp (ExpBase NoInfo VName) VName bareTypeExp (TEVar qn loc) = TEVar qn loc bareTypeExp (TEParens te loc) = TEParens (bareTypeExp te) loc@@ -474,10 +479,6 @@ bareExp (Coerce e te _ loc) = Coerce (bareExp e) (bareTypeExp te) NoInfo loc bareExp (Negate x loc) = Negate (bareExp x) loc bareExp (Not x loc) = Not (bareExp x) loc-bareExp (Update src slice v loc) =-  Update (bareExp src) (map bareDimIndex slice) (bareExp v) loc-bareExp (RecordUpdate src fs v _ loc) =-  RecordUpdate (bareExp src) fs (bareExp v) NoInfo loc bareExp (Project field e _ loc) =   Project field (bareExp e) NoInfo loc bareExp (Assert e1 e2 _ loc) = Assert (bareExp e1) (bareExp e2) NoInfo loc@@ -488,9 +489,8 @@   OpSectionLeft name NoInfo (bareExp arg) (NoInfo, NoInfo) (NoInfo, NoInfo) loc bareExp (OpSectionRight name _ arg _ _ loc) =   OpSectionRight name NoInfo (bareExp arg) (NoInfo, NoInfo) NoInfo loc-bareExp (ProjectSection fields _ loc) = ProjectSection fields NoInfo loc-bareExp (IndexSection slice _ loc) =-  IndexSection (map bareDimIndex slice) NoInfo loc+bareExp (UpdateSection steps _ loc) =+  UpdateSection (map bareUpdateStep steps) NoInfo loc bareExp (Constr name es _ loc) =   Constr name (map bareExp es) NoInfo loc bareExp (AppExp appexp _) =@@ -508,11 +508,11 @@             (bareLoopForm form)             (bareExp loopbody)             loc-        LetWith (Ident dest _ destloc) (Ident src _ srcloc) idxexps vexp body loc ->+        LetWith (Ident dest _ destloc) (Ident src _ srcloc) steps vexp body loc ->           LetWith             (Ident dest NoInfo destloc)             (Ident src NoInfo srcloc)-            (map bareDimIndex idxexps)+            (map bareUpdateStep steps)             (bareExp vexp)             (bareExp body)             loc@@ -536,3 +536,10 @@           Index (bareExp arr) (map bareDimIndex slice) loc bareExp (Attr attr e loc) =   Attr attr (bareExp e) loc+bareExp (Update src steps v _ loc) =+  Update+    (bareExp src)+    (map bareUpdateStep steps)+    (bareExp v)+    NoInfo+    loc
src/Language/Futhark/TypeChecker/Consumption.hs view
@@ -76,10 +76,17 @@ aliases :: TypeAliases -> Aliases aliases = bifoldMap (const mempty) id -setFieldAliases :: TypeAliases -> [Name] -> TypeAliases -> TypeAliases-setFieldAliases ve_als (x : xs) (Scalar (Record fs)) =-  Scalar $ Record $ M.adjust (setFieldAliases ve_als xs) x fs-setFieldAliases ve_als _ _ = ve_als+updateAliases :: TypeAliases -> [UpdateStep Info VName] -> TypeAliases -> TypeAliases+updateAliases _ [] ve_als =+  ve_als+updateAliases src_als (UpdateStepField f : rest) ve_als =+  case src_als of+    Scalar (Record fs)+      | Just sub <- M.lookup f fs ->+          Scalar $ Record $ M.insert f (updateAliases sub rest ve_als) fs+    _ ->+      src_als+updateAliases src_als (UpdateStepSlice _ : _) _ = second (const mempty) src_als  data Entry a   = Consumable {entryAliases :: a}@@ -340,10 +347,6 @@   where     als' = M.fromList $ map ((,loc) . aliasVar) $ S.toList als -consume :: Loc -> VName -> StructType -> CheckM ()-consume loc v t =-  consumeAliases loc . aliases =<< observeVar loc v t- -- | Observe the given name here and return its aliases. observeVar :: Loc -> VName -> StructType -> CheckM TypeAliases observeVar loc v t = do@@ -860,23 +863,43 @@       )  ---checkExp (AppExp (LetWith dst src slice ve body loc) appres) = do-  src_als <- observeVar (locOf dst) (identName src) (unInfo $ identType src)-  slice' <- checkSubExps slice+checkExp (AppExp (LetWith dst src steps ve body loc) appres) = do+  steps' <- mapM checkStep steps   (ve', ve_als) <- checkExp ve-  consume (locOf src) (identName src) (unInfo (identType src))-  overlapCheck (locOf ve) (src, src_als) (ve', ve_als)-  (body', body_als) <- bindingIdent Consume dst $ checkExp body-  pure (AppExp (LetWith dst src slice' ve' body' loc) appres, body_als)+  src_als <- observeVar (locOf src) (identName src) (unInfo $ identType src) +  let hasIndex = any isIndex steps++  when hasIndex $ do+    overlapCheck (locOf ve) (src, src_als) (ve', ve_als)+    consumeAliases (locOf loc) $ aliases src_als++  (body', body_als) <- bindingIdent Consume dst $ checkExp body+  pure (AppExp (LetWith dst src steps' ve' body' loc) appres, body_als)+  where+    isIndex UpdateStepSlice {} = True+    isIndex _ = False+    checkStep (UpdateStepSlice slice) = UpdateStepSlice <$> checkSubExps slice+    checkStep (UpdateStepField f) = pure $ UpdateStepField f ---checkExp (Update src slice ve loc) = do-  slice' <- checkSubExps slice+checkExp (Update src steps ve t loc) = do+  steps' <- mapM checkStep steps   (ve', ve_als) <- checkExp ve   (src', src_als) <- checkExp src-  overlapCheck (locOf ve) (src', src_als) (ve', ve_als)-  consumeAliases (locOf loc) $ aliases src_als-  pure (Update src' slice' ve' loc, second (const mempty) src_als)+  let hasIndex = any isIndex steps+  res_als <-+    if hasIndex+      then do+        overlapCheck (locOf ve) (src', src_als) (ve', ve_als)+        consumeAliases (locOf loc) $ aliases src_als+        pure $ second (const mempty) src_als+      else pure $ updateAliases src_als steps ve_als+  pure (Update src' steps' ve' t loc, res_als)+  where+    isIndex UpdateStepSlice {} = True+    isIndex _ = False+    checkStep (UpdateStepSlice slice) = UpdateStepSlice <$> checkSubExps slice+    checkStep (UpdateStepField f) = pure $ UpdateStepField f  -- Cases that simply propagate aliases directly. checkExp (Var v (Info t) loc) = do@@ -905,11 +928,12 @@     ( OpSectionRight op ftype arg' arginfo retinfo loc,       Scalar $ Arrow (aliases arg_als <> aliases als) pn (diet pt2) (toStruct pt2) ret     )-checkExp (IndexSection slice t loc) = do-  slice' <- checkSubExps slice-  pure (IndexSection slice' t loc, unInfo t `setAliases` mempty)-checkExp (ProjectSection fs t loc) = do-  pure (ProjectSection fs t loc, unInfo t `setAliases` mempty)+checkExp (UpdateSection steps t loc) = do+  steps' <- mapM checkStep steps+  pure (UpdateSection steps' t loc, unInfo t `setAliases` mempty)+  where+    checkStep (UpdateStepField f) = pure $ UpdateStepField f+    checkStep (UpdateStepSlice slice) = UpdateStepSlice <$> checkSubExps slice checkExp (Coerce e te t loc) = do   (e', e_als) <- checkExp e   pure (Coerce e' te t loc, e_als)@@ -957,13 +981,6 @@           Scalar . Sum . M.insert name es_als $             M.map (map (`setAliases` mempty)) cs         t' -> error $ "checkExp Constr: bad type " <> prettyString t'-    )-checkExp (RecordUpdate src fields ve t loc) = do-  (src', src_als) <- checkExp src-  (ve', ve_als) <- checkExp ve-  pure-    ( RecordUpdate src' fields ve' t loc,-      setFieldAliases ve_als fields src_als     ) checkExp (RecordLit fs loc) = do   (fs', fs_als) <- mapAndUnzipM checkField fs
src/Language/Futhark/TypeChecker/Names.hs view
@@ -269,10 +269,11 @@   Project k <$> resolveExp e <*> pure NoInfo <*> pure loc resolveExp (Constr k es NoInfo loc) =   Constr k <$> mapM resolveExp es <*> pure NoInfo <*> pure loc-resolveExp (Update e1 slice e2 loc) =-  Update <$> resolveExp e1 <*> resolveSlice slice <*> resolveExp e2 <*> pure loc-resolveExp (RecordUpdate e1 fs e2 NoInfo loc) =-  RecordUpdate <$> resolveExp e1 <*> pure fs <*> resolveExp e2 <*> pure NoInfo <*> pure loc+resolveExp (Update e1 steps e2 NoInfo loc) =+  Update <$> resolveExp e1 <*> mapM resolveStep steps <*> resolveExp e2 <*> pure NoInfo <*> pure loc+  where+    resolveStep (UpdateStepSlice slice) = UpdateStepSlice <$> resolveSlice slice+    resolveStep (UpdateStepField f) = pure $ UpdateStepField f resolveExp (OpSection v NoInfo loc) =   OpSection <$> resolveQualName v loc <*> pure NoInfo <*> pure loc resolveExp (OpSectionLeft v info1 e info2 info3 loc) =@@ -291,10 +292,11 @@     <*> pure info2     <*> pure info3     <*> pure loc-resolveExp (ProjectSection ks info loc) =-  pure $ ProjectSection ks info loc-resolveExp (IndexSection slice info loc) =-  IndexSection <$> resolveSlice slice <*> pure info <*> pure loc+resolveExp (UpdateSection steps info loc) =+  UpdateSection <$> mapM resolveStep steps <*> pure info <*> pure loc+  where+    resolveStep (UpdateStepField f) = pure $ UpdateStepField f+    resolveStep (UpdateStepSlice slice) = UpdateStepSlice <$> resolveSlice slice resolveExp (Ascript e te loc) =   Ascript <$> resolveExp e <*> resolveTypeExp te <*> pure loc resolveExp (Coerce e te info loc) =@@ -354,14 +356,14 @@   bindSpaced1 Term fname fnameloc $ \fname' -> do     body' <- resolveExp body     pure $ LetFun (fname', fnameloc) (tparams', params', ret', NoInfo, fbody') body' loc-resolveAppExp (LetWith (Ident dst _ dstloc) (Ident src _ srcloc) slice e1 e2 loc) = do+resolveAppExp (LetWith (Ident dst _ dstloc) (Ident src _ srcloc) steps e1 e2 loc) = do   src' <- Ident <$> resolveName src srcloc <*> pure NoInfo <*> pure srcloc   e1' <- resolveExp e1-  slice' <- resolveSlice slice+  steps' <- mapM resolveUpdateStep steps   bindSpaced1 Term dst loc $ \dstv -> do     let dst' = Ident dstv NoInfo dstloc     e2' <- resolveExp e2-    pure $ LetWith dst' src' slice' e1' e2' loc+    pure $ LetWith dst' src' steps' e1' e2' loc resolveAppExp (BinOp (f, floc) finfo (e1, info1) (e2, info2) loc) = do   f' <- resolveQualName f floc   e1' <- resolveExp e1@@ -390,6 +392,14 @@       cond' <- resolveExp cond       body' <- resolveExp body       pure $ Loop sizes pat' e' (While cond') body' loc++resolveUpdateStep ::+  UpdateStep NoInfo Name ->+  TypeM (UpdateStep NoInfo VName)+resolveUpdateStep (UpdateStepSlice slice) =+  UpdateStepSlice <$> resolveSlice slice+resolveUpdateStep (UpdateStepField f) =+  pure $ UpdateStepField f  resolveSlice :: SliceBase NoInfo Name -> TypeM (SliceBase NoInfo VName) resolveSlice = mapM onDimIndex
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -538,57 +538,68 @@           loc       )       (Info $ AppRes body_t ext)-checkExp (AppExp (LetWith dest src slice ve body loc) _) = do+checkExp (AppExp (LetWith dest src steps ve body loc) _) = do   src' <- checkIdent src-  slice' <- checkSlice slice-  (t, _) <- newArrayType (mkUsage src "type of source array") "src" $ sliceDims slice'-  unify (mkUsage loc "type of target array") t $ unInfo $ identType src'+  src_t <- normTypeFully $ unInfo $ identType src' -  (elemt, _) <- sliceShape (Just (loc, Nonrigid)) slice' =<< normTypeFully t+  let onlyFields = all isField steps -  ve' <- unifies "type of target array" elemt =<< checkExp ve+  if onlyFields+    then do+      ve' <- checkExp ve+      ve_t <- expType ve'+      updated_t <- updateFieldPath src (fieldNames steps) ve_t src_t+      steps' <- mapM checkFieldStep steps -  bindingIdent dest (unInfo (identType src')) $ \dest' -> do-    body' <- checkExp body-    (body_t, ext) <- unscopeType loc [identName dest'] =<< expTypeFully body'-    pure $ AppExp (LetWith dest' src' slice' ve' body' loc) (Info $ AppRes body_t ext)-checkExp (Update src slice ve loc) = do-  slice' <- checkSlice slice-  (t, _) <- newArrayType (mkUsage' src) "src" $ sliceDims slice'-  (elemt, _) <- sliceShape (Just (loc, Nonrigid)) slice' =<< normTypeFully t-  ve' <- unifies "type of target array" elemt =<< checkExp ve-  src' <- unifies "type of target array" t =<< checkExp src-  pure $ Update src' slice' ve' loc+      bindingIdent dest updated_t $ \dest' -> do+        body' <- checkExp body+        (body_t, ext) <- unscopeType loc [identName dest'] =<< expTypeFully body'+        pure $ AppExp (LetWith dest' src' steps' ve' body' loc) (Info $ AppRes body_t ext)+    else do+      (steps', target_t) <- checkUpdateSteps loc src_t steps+      ve' <- unifies "type of update target" target_t =<< checkExp ve +      src_t' <- normTypeFully $ unInfo $ identType src'+      bindingIdent dest src_t' $ \dest' -> do+        body' <- checkExp body+        (body_t, ext) <- unscopeType loc [identName dest'] =<< expTypeFully body'+        pure $ AppExp (LetWith dest' src' steps' ve' body' loc) (Info $ AppRes body_t ext)+  where+    isField UpdateStepField {} = True+    isField _ = False++    fieldNames = map (\(UpdateStepField f) -> f)++    checkFieldStep (UpdateStepField f) = pure $ UpdateStepField f+    checkFieldStep _ = error "impossible"+ -- Record updates are a bit hacky, because we do not have row typing -- (yet?).  For now, we only permit record updates where we know the -- full type up to the field we are updating.-checkExp (RecordUpdate src fields ve NoInfo loc) = do+checkExp (Update src steps ve NoInfo loc) = do   src' <- checkExp src-  ve' <- checkExp ve-  a <- expTypeFully src'-  foldM_ (flip $ mustHaveField usage) a fields-  ve_t <- expType ve'-  updated_t <- updateField fields ve_t =<< expTypeFully src'-  pure $ RecordUpdate src' fields ve' (Info updated_t) loc+  src_t <- expTypeFully src'+  let onlyFields = all isField steps+  if onlyFields+    then do+      ve' <- checkExp ve+      ve_t <- expType ve'+      updated_t <- updateFieldPath src (fieldNames steps) ve_t src_t+      steps' <- mapM checkFieldStep steps+      pure $ Update src' steps' ve' (Info updated_t) loc+    else do+      (steps', target_t) <- checkUpdateSteps loc src_t steps+      ve' <- unifies "type of update target" target_t =<< checkExp ve+      src_t' <- expTypeFully src'+      pure $ Update src' steps' ve' (Info src_t') loc   where-    usage = mkUsage loc "record update"-    updateField [] ve_t src_t = do-      (src_t', _) <- allDimsFreshInType usage Nonrigid "any" src_t-      onFailure (CheckingRecordUpdate fields src_t' ve_t) $-        unify usage src_t' ve_t-      pure ve_t-    updateField (f : fs) ve_t (Scalar (Record m))-      | Just f_t <- M.lookup f m = do-          f_t' <- updateField fs ve_t f_t-          pure $ Scalar $ Record $ M.insert f f_t' m-    updateField _ _ _ =-      typeError loc mempty . withIndexLink "record-type-not-known" $-        "Full type of"-          </> indent 2 (pretty src)-          </> textwrap " is not known at this point.  Add a type annotation to the original record to disambiguate."+    isField UpdateStepField {} = True+    isField _ = False ---+    fieldNames = map (\(UpdateStepField f) -> f)++    checkFieldStep (UpdateStepField f) = pure $ UpdateStepField f+    checkFieldStep _ = error "impossible" checkExp (AppExp (Index e slice loc) _) = do   slice' <- checkSlice slice   (t, _) <- newArrayType (mkUsage' loc) "e" $ sliceDims slice'@@ -700,18 +711,27 @@     _ ->       typeError loc mempty $         "Operator section with invalid operator of type" <+> pretty ftype-checkExp (ProjectSection fields NoInfo loc) = do+checkExp (UpdateSection steps NoInfo loc) = do   a <- newTypeVar loc "a"-  let usage = mkUsage loc "projection at"-  b <- foldM (flip $ mustHaveField usage) a fields-  let ft = Scalar $ Arrow mempty Unnamed Observe a $ RetType [] $ toRes Nonunique b-  pure $ ProjectSection fields (Info ft) loc-checkExp (IndexSection slice NoInfo loc) = do-  slice' <- checkSlice slice-  (t, _) <- newArrayType (mkUsage' loc) "e" $ sliceDims slice'-  (t', retext) <- sliceShape Nothing slice' t-  let ft = Scalar $ Arrow mempty Unnamed Observe t $ RetType retext $ toRes Nonunique t'-  pure $ IndexSection slice' (Info ft) loc+  (steps', b, retext) <- checkSectionSteps a steps+  let ft = Scalar $ Arrow mempty Unnamed Observe a $ RetType retext $ toRes Nonunique b+  pure $ UpdateSection steps' (Info ft) loc+  where+    checkSectionSteps t [] =+      pure ([], t, [])+    checkSectionSteps t (step : rest) =+      case step of+        UpdateStepField f -> do+          t' <- mustHaveField (mkUsage loc "projection at") f t+          (rest', target_t, retext) <- checkSectionSteps t' rest+          pure (UpdateStepField f : rest', target_t, retext)+        UpdateStepSlice slice -> do+          slice' <- checkSlice slice+          (arr_t, _) <- newArrayType (mkUsage' loc) "e" $ sliceDims slice'+          unify (mkUsage loc "type of section indexing") arr_t t+          (t', retext) <- sliceShape Nothing slice' =<< normTypeFully arr_t+          (rest', target_t, retext_rest) <- checkSectionSteps t' rest+          pure (UpdateStepSlice slice' : rest', target_t, retext <> retext_rest) checkExp (AppExp (Loop _ mergepat loopinit form loopbody loc) _) = do   ((sparams, mergepat', loopinit', form', loopbody'), appres) <-     checkLoop checkExp (mergepat, loopinit, form, loopbody) loc@@ -737,6 +757,52 @@ checkExp (Attr info e loc) =   Attr <$> checkAttr info <*> checkExp e <*> pure loc +updateFieldPath ::+  (Pretty a, Located a) =>+  a ->+  [Name] ->+  StructType ->+  StructType ->+  TermTypeM StructType+updateFieldPath src [] ve_t src_leaf_t = do+  (src_leaf_t', _) <- allDimsFreshInType usage Nonrigid "any" src_leaf_t+  onFailure (CheckingRecordUpdate [] src_leaf_t' ve_t) $+    unify usage src_leaf_t' ve_t+  pure ve_t+  where+    usage = mkUsage (locOf src) "record update"+updateFieldPath src (f : fs) ve_t (Scalar (Record m))+  | Just f_t <- M.lookup f m = do+      f_t' <- updateFieldPath src fs ve_t f_t+      pure $ Scalar $ Record $ M.insert f f_t' m+updateFieldPath src _ _ _ =+  typeError (locOf src) mempty . withIndexLink "record-type-not-known" $+    "Full type of"+      </> indent 2 (pretty src)+      </> textwrap " is not known at this point.  Add a type annotation to the original record to disambiguate."++checkUpdateSteps ::+  SrcLoc ->+  StructType ->+  [UpdateStep NoInfo VName] ->+  TermTypeM ([UpdateStep Info VName], StructType)+checkUpdateSteps _ t [] =+  pure ([], t)+checkUpdateSteps loc t (step : rest) =+  case step of+    UpdateStepSlice slice -> do+      slice' <- checkSlice slice+      (arr_t, _) <- newArrayType (mkUsage' loc) "update_path_src" $ sliceDims slice'+      unify (mkUsage loc "type of update path indexing") arr_t t+      (elem_t, _) <- sliceShape (Just (loc, Nonrigid)) slice' =<< normTypeFully arr_t+      (rest', target_t) <- checkUpdateSteps loc elem_t rest+      pure (UpdateStepSlice slice' : rest', target_t)+    UpdateStepField f -> do+      t' <- normTypeFully t+      f_t <- mustHaveField (mkUsage loc "record update path") f t'+      (rest', target_t) <- checkUpdateSteps loc f_t rest+      pure (UpdateStepField f : rest', target_t)+ checkCases ::   StructType ->   NE.NonEmpty (CaseBase NoInfo VName) ->@@ -1008,10 +1074,7 @@       onExp known (Var v (Info t) loc)         | Just bad <- checkCausality (dquotes (pretty v)) known t loc =             bad-      onExp known (ProjectSection _ (Info t) loc)-        | Just bad <- checkCausality "projection section" known t loc =-            bad-      onExp known (IndexSection _ (Info t) loc)+      onExp known (UpdateSection _ (Info t) loc)         | Just bad <- checkCausality "projection section" known t loc =             bad       onExp known (OpSectionRight _ (Info t) _ _ _ loc)