packages feed

futhark 0.27.1 → 0.28.1

raw patch · 228 files changed

+10155/−6583 lines, 228 filesdep +splitdep ~futhark-manifestdep ~futhark-server

Dependencies added: split

Dependency ranges changed: futhark-manifest, futhark-server

Files

CHANGELOG.md view
@@ -5,9 +5,97 @@ 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.28.1]++### Added++* Attributes may now also reference variables in scope, by prefixing a name with+  `$`. There is no builtin use for this feature.++* The "uniqueness" terminology for in-place updates has now been completely+  replaced with the notions of "consumption" and "freshness".++* `futhark bench`: JSON files now contain metadata about the configuration and+  execution environment (#2381). Work by Yifan Chen.++* New attribute: `cpu_function`.++* Support for ISPC 1.31 (and that is now also the minimum version). (#2557)++* `futhark repl` and `futhark eval` can now run code available via a compiled+  server executable.++* `futhark test`: `auto output` now works with `script input`.++### Removed++* The `futhark script` command has been removed.++### Changed++* FutharkScript has been replaced by ordinary Futhark. The magical builtins have+  been replaced by magical functions, e.g., `$loadbytes` is now `io.loadbytes`.+  Obviously only works in interpreted code. Futhark is not an exact+  functionality match for FutharkScript, but most things should be able to work.++* `futhark literate` no longer implicitly marks functions used in directives as+  entry points. Use ``entry`` when you actually want compiled entry points.++* The consumption/aliasing system has been reimplemented. The main change is+  that annotated freshness on functions now takes precedence even if a more+  fresh type is inferred - some existing programs may need `*` added to their+  return type. Beyond that, the system should generally just be more flexible.++### Fixed++* Python input reading no longer hangs on an unsuffixed `0`, an unsuffixed+  hexadecimal integer, or a line comment at EOF.++* File names are now always encoded as UTF-8. Non-UTF-8 locales are not+  supported.++* Propagation of flattening attributes in some cases.++* GPU code generation now supports reductions with more than 25 operators.++* `reduce` and `reduce_comm` now produce alias-free results.++* AD is now supported for scans with array operators (#2208). Work by Yifan Chen.++* AD operators now return alias-free results.++* Shared memory histograms no longer occasionally exceed the shared memory+  limit when chunking the buckets.++* Tiling would produce invalid code in some cases.++* Mishandling of abstract types could lead to compiler crash. (#2538)++* Conversion of floating-point numbers to integers would trigger UB whenever the+  number was too large to fit in the integer. (#2543)++* Horizontal fusion of multi-dimensional histograms. (#2555)++* OpenCL profiling reports on macOS no longer undercount event durations by+  about 42x: Apple's OpenCL reports Mach time units, not nanoseconds.++* Internalisation of reduce_by_index_3d with array-valued elements. (#2554)++* A compiler crash caused by size-polymorphic recursive functions. (#2569)++* Overzealous copy removal in conjunction with AD could result in a compiler+  crash. (#2567)++* Short-circuiting of function parameters failed to take layout into account.+  (#2568)++* `futhark literate` now handles indented comments. (#2521)++* Various holes in alias analysis (#1675, #2531).+ ## [0.27.1] -## Added+### Added  * Rewrote partition to be a single kernel. @@ -26,12 +114,12 @@  * A simplification rule for branches that return common results (#2526). -## Changed+### Changed  * Local functions are no longer let-generalised (i.e., made polymorphic).   Explicitly polymorphic local functions are still supported. -## Fixed+### Fixed  * Filter now uses the predicate once per element instead of twice. @@ -491,6 +579,14 @@   abbreviations and arrays (#2253).  * Reverse mode AD now handles sequential streams. (#2256)++* Invalid simplification in conjunction with array updates, which could crash+  the compiler. (#2566)++* Invalid short-circuiting could result in compiler crashes and memory errors.+  (#2565)++* Invalid copy removal could crash the compiler. (#2564)  ## [0.25.29]
docs/c-api.rst view
@@ -297,6 +297,18 @@    retrieve the entire array with the ``values`` function,    particularly when using a GPU backend. +.. c:function:: int futhark_set_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr, int32_t v, int64_t i0);++   Update a single element in the array. Returns a nonzero value if the index is+   out of bounds or data movement fails for other reasons. **Note:** if you want+   to write many elements, it is much faster to retrieve the entire array with+   the ``values`` function, update it using normal code, then construct a new+   array.++   **Warning:** this operation mutates the underlying memory, which means it+   will also affect other arrays aliasing it, possibly including asynchronously+   running code.+ .. c:function:: const int64_t *futhark_shape_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr)     Return a pointer to the shape of the array, with one element per@@ -401,11 +413,11 @@    be manually freed, independently of the records from which they are    projected, or the fields they are constructed from. -2. The objects are however in an *aliasing* relationship with the-   fields or original record.  This means you must be careful when-   passing them to entry points that consume their arguments.  As-   always, you don't have to worry about this if you never write entry-   points that consume their arguments.+2. The objects are however in an *aliasing* relationship with the fields or+   original record. This means you must be careful when passing them to entry+   points that consume their arguments. As always, you don't have to worry about+   this if you never write entry points that consume their arguments, or use the+   ``set`` functions on arrays.  3. You must synchronise before using any scalar results. @@ -511,8 +523,13 @@ .. 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.+   nonzero value if the index is out of bounds or the element has the wrong+   shape. +   **Warning:** this operation mutates the underlying memory, which means it+   will also affect other arrays aliasing it, possibly including asynchronously+   running code.+ .. 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@@ -784,10 +801,9 @@ for caching GPU kernels in some cases.  This is beyond Futhark's control. -Violation the restrictions of consumption (see :ref:`api-consumption`)-can result in undefined behaviour.  This does not matter for programs-whose entry points do not have unique parameter types-(:ref:`in-place-updates`).+Violating the restrictions of consumption (see :ref:`api-consumption`) can+result in undefined behaviour. This does not matter for programs whose entry+points do not consume their input (:ref:`in-place-updates`).  .. _manifest: @@ -803,10 +819,10 @@   * The C function name of the entry point.    * A list of all *inputs*, including their type (as a name) and-    *whether they are unique* (consuming).+    *whether they are consuming*. -  * A list of all *outputs*, including their type (as a name) and-    *whether they are unique*.+  * A list of all *outputs*, including their type (as a name) and whether they+    *are fresh*.    * A list of all *tuning parameters* that can influence the execution     of this entry point.  These are not necessarily unique to the
docs/conf.py view
@@ -549,13 +549,6 @@         1,     ),     (-        "man/futhark-script",-        "futhark-script",-        "execute FutharkScript expression",-        [],-        1,-    ),-    (         "man/futhark-profile",         "futhark-profile",         "profile Futhark programs",
docs/error-index.rst view
@@ -6,30 +6,29 @@ Elaboration on type errors produced by the compiler.  Many error messages contain links to the sections below. -Uniqueness errors------------------+Consumption errors+------------------  .. _use-after-consume:  "Using *x*, but this was consumed at *y*." ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A core principle of uniqueness typing (see :ref:`in-place-updates`) is-that after a variable is "consumed", it must not be used again.  For-example, this is invalid, and will result in the error above:+A core principle of type-checking in-place updates (see :ref:`in-place-updates`)+is that after a variable is *consumed*, it must not be used again. For example,+this is invalid, and will result in the error above:  .. code-block:: futhark    let y = x with [0] = 0   in x -Several operations can *consume* a variable: array update expressions,-calling a function with unique-typed parameters, or passing it as the-initial value of a unique-typed loop parameter.  When a variable is-consumed, its *aliases* are also considered consumed.  Aliasing is the-possibility of two variables occupying the same memory at run-time.-For example, this will fail as above, because ``y`` and ``x`` are-aliased:+Several operations can *consume* a variable: array update expressions, calling a+function with consumed parameters, or passing it as the initial value of a+consuming loop parameter. When a variable is consumed, its *aliases* are also+considered consumed. Aliasing is the possibility of two variables occupying the+same memory at run-time. For example, this will fail as above, because ``y`` and+``x`` are aliased:  .. code-block:: futhark @@ -60,9 +59,9 @@     let a[0] = a[0]+1     in a -Only arrays with a a *unique array type* can be consumed.  Such a type-is written by prefixing the array type with an asterisk.  The program-could be fixed by writing it like this:+Only parameters marked as *consumable* can be consumed. This is designated in+the type by prefixing it with an asterisk. The program could be fixed by writing+it like this:  .. code-block:: futhark @@ -74,8 +73,7 @@ function, since it now *consumes* its argument.  See :ref:`in-place-updates` for the full details. -You can always obtain a unique copy of an array by using-``copy``:+You can always obtain a *fresh* copy of an array by using ``copy``:  .. code-block:: futhark @@ -89,8 +87,8 @@  .. _return-aliased: -"Unique-typed return value of *x* is aliased to *y*, which is not consumable"-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+"Fresh-declared return value of *x* is aliased to *y*, which is not consumable"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  This can be caused by a function like this: @@ -98,13 +96,12 @@    def f (xs: []i32) : *[]i32 = xs -We are saying that ``f`` returns a *unique* array - meaning it has no-aliases - but at the same time, it aliases the parameter *xs*, which-is not marked as being unique (see :ref:`in-place-updates`).  This-violates one of the core guarantees provided by uniqueness types,-namely that a unique return value does not alias any value that might-be used in the future.  Imagine if this was permitted, and we had a-program that used ``f``:+We are saying that ``f`` returns a *fresh* array - meaning it has no aliases -+but at the same time, it aliases the parameter *xs*, which is not marked as+being consumable (see :ref:`in-place-updates`). This violates one of the core+safety guarantees for in-place updates, namely that a fresh return value does+not alias any value that might be used in the future. Imagine if this was+permitted, and we had a program that used ``f``:  .. code-block:: futhark @@ -116,9 +113,8 @@ (hence occupying the same memory), then we would be modifying ``a`` as well, which is a violation of referential transparency. -As with most uniqueness errors, it can be fixed by using ``copy xs``-to break the aliasing.  We can also change the type of ``f`` to take a-unique array as input:+As with most alias-related errors, it can be fixed by using ``copy xs`` to break+the aliasing. We can also change the type of ``f`` to consume its parameter:  .. code-block:: futhark @@ -126,10 +122,10 @@  This makes ``xs`` "consumable", in the sense used by the error message. -.. _unique-return-aliased:+.. _fresh-return-aliased: -"A unique-typed component of the return value of *x* is aliased to some other component"-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+"A fresh-declared component of the return value of *x* is aliased to some other component"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  Caused by programs like the following: @@ -137,13 +133,12 @@    def main (xs: *[]i32) : (*[]i32, *[]i32) = (xs, xs) -While we are allowed to "consume" ``xs``, as it is a unique parameter,-this function is trying to return two unique values that alias each-other.  This violates one of the core guarantees provided by-uniqueness types, namely that a unique return value does not alias any-value that might be used in the future (see :ref:`in-place-updates`) --and in this case, the two values alias each other.  We can fix this by-inserting copies to break the aliasing:+While we are allowed to "consume" ``xs``, as it is a consumed parameter, this+function is trying to return two fresh values that alias each other. This+violates one of the core safety guarantees for in-place updates, namely that a+fresh return value does not alias any value that might be used in the future+(see :ref:`in-place-updates`) - and in this case, the two values alias each+other. We can fix this by inserting copies to break the aliasing:  .. code-block:: futhark @@ -215,27 +210,6 @@    def apply 'a 'b (f: *a -> b) (x: *a) = f x -.. _alias-free-variable:--"Function result aliases the free variable *x*"-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Caused by definitions such as the following:--.. code-block:: futhark--  def x = [1,2,3]--  def f () = x--To simplify the tracking of aliases, the Futhark type system requires-that the result of a function may only alias the function parameters,-not any free variables.  Use ``copy`` to fix this:--.. code-block:: futhark--  def f () = copy x- .. _size-expression-bind:  "Size expression with binding is replaced by unknown size."@@ -323,41 +297,29 @@  This occurs for expressions like the following:: -    loop (xs: []i32, ys: *[]i32) = (replicate n 0, replicate n 0)-    for i < 10 do-      (xs, xs)+    loop xs for i < 10 do+      -- Consume xs...+      let xs[i] = 0+      -- ys is some variable bound outside the loop+      in ys  -This is not allowed, as creates aliasing between a consumeable parameter-(``ys``) and non-consumable parameter (``xs``) in the next iteration of the-loop, during which consumption ``ys`` would also affect ``xs``. You can solve-this by copying one of the return values of the loop.--.. _loop-parameter-aliases-other:--"Return value for loop parameter *x* aliases other consumed loop parameter"-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--This occurs for expressions like the following::--    loop (xs: *[]i32, ys: *[]i32) = (replicate n 0, replicate n 0)-    for i < 10 do-      (xs, xs)+This is not allowed, as the loop parameter ``xs`` is consumed, in this case+implicitly due to the in-place update, but the loop body returns something that+is not consumable, in this case ``ys``, which is bound outside the loop. -This is not allowed for the same reason that we are not allowed to consume an-array multiple times. You can solve this by copying one of the return values of-the loop.+You can solve this by copying one of the return values of the loop.  .. _aliases-previously-returned: -"Return value for consuming loop parameter *x* aliases previously returned value"-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+"Return value for consuming loop parameter *x* aliases another returned value"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  This error occurs when you have a loop with multiple loop parameters, at least one of which is consuming, and the values returned by the loop body alias each other. This would result in the consuming loop parameter aliasing another loop parameter, which is not allowed. It is-essentially :ref:`unique-return-aliased` from a loop perspective.+essentially :ref:`fresh-return-aliased` from a loop perspective.  A (contrived) example of this error is the following: @@ -374,9 +336,9 @@ "Let-bound expression of higher-order type *t* contains consumption" ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This occurs when ``let``-binding an expression that contains consumption and-returns a function. The most common case is partial application of a consuming-function::+This occurs when ``let``, ``def``, or ``case``-binding an expression that+contains consumption and returns a function. The most common case is partial+application of a consuming function::    def update (xs: *[]i32) (i: i32) (y: i32) =     xs with [i] = y@@ -389,7 +351,7 @@  The reason for this restriction is rooted in efficiency concerns. Defunctionalisation causes the two applications of ``f`` to both consume ``xs``,-which is a violation of uniqueness properties.+which is a violation of the safety requirements for :ref:`in-place updates`.  Size errors -----------
docs/glossary.rst view
@@ -64,6 +64,12 @@      principle the pipeline could be configurable, but in practice      each backend is coupled with a specific pipeline. +   Compound type++     A :term:`tuple`, :term:`record`, or :term:`sum type`. Values of these types+     do not have their own identity where :term:`aliasing` is concerned; aliases+     are only tracked at the level of their individual components.+    Constructive use       A variable ``n`` is used *constructively* in a type if it is used@@ -129,6 +135,13 @@      such a function is applied, each existential size is instantiated      as an :term:`unknown size`. +   Fresh++     A value returned by a function that is guaranteed not to :term:`alias+     <aliases>` its parameters. In function types, this is denoted by putting an+     asterisk (``*``) in the return type. The prelude function ``copy`` always+     returns a fresh value, and is the easiest way of obtaining one.+    Functor       The Standard ML term for what Futhark calls a :term:`parametric@@ -302,6 +315,12 @@      consituent parts. Patterns are used in function parameters,      ``let``-bindings, and ``match``. See :ref:`patterns`. +   Record++     In Futhark, a record is a :term:`compound type` that associated field names+     with field types. ``{x:i32,y:bool}`` is an example of a record with two+     fields.+    Recursion       A function that calls itself.  Currently not supported in@@ -368,12 +387,24 @@      on.  They are *second order* because they accept a functional      argument, and so permit :term:`nested data parallelism`. +   Sum type++     A type that comprises one or more constructors, each of which has a+     payload. For example, ``#foo | #bar i32`` is a sum type, where ``#foo`` has+     no payload, and ``#bar`` has an ``i32`` payload.+    Symbol       A lexical token that consts of symbolic (non-alphabetic      characters), and can be bound to a value.  Infix operators such      as ``+`` and ``/`` are symbols.  See also :term:`name`. +   Tuple++     A special case of a :term:`record` where the fields are contiguously named+     integers starting at zero. ``(i32,bool)`` is a tuple that is completely+     equivalent with the record ``{0=i32,1=bool}``.+    Type       A classification of values.  ``i32`` and ``[10]i32`` are examples@@ -429,15 +460,6 @@      An instance of :term:`nested data parallelism` that is not      :term:`nonuniform`. This is much more efficient than :term:`nonuniform      nested data parallelism`.--   Uniqueness types--     A somewhat misleading term that describes Futhark's system of-     allowing :term:`consumption` of values, in the interest of-     allowing :term:`in-place updates`.  The only place where-     *uniqueness* truly occurs is in return types, where e.g. the-     return type of ``copy`` is *unique* to indicate that the result-     does not :term:`alias<aliasing>` the argument.     Unknown size
docs/index.rst view
@@ -57,7 +57,6 @@    man/futhark-ispc.rst    man/futhark-literate.rst    man/futhark-lsp.rst-   man/futhark-script.rst    man/futhark-multicore.rst    man/futhark-opencl.rst    man/futhark-pkg.rst
docs/language-reference.rst view
@@ -317,10 +317,6 @@  The application ``pair [1] [2,3]`` is ill-typed. -To simplify the handling of in-place updates (see-:ref:`in-place-updates`), the value returned by a function may not-alias any global variables.- User-Defined Operators ~~~~~~~~~~~~~~~~~~~~~~ @@ -1469,9 +1465,9 @@ Generally, most language constructs produce new arrays, but some (slicing) create arrays that alias their input arrays. -When defining a function parameter we can mark it as *consuming* by-prefixing it with an asterisk.  For a return type, we can mark it as-*alias-free* by prefixing it with an asterisk.  For example::+When defining a function parameter we can mark it as *consuming* by prefixing it+with an asterisk. For a return type, we can mark it as *fresh* by prefixing it+with an asterisk. For example::    def modify (a: *[]i32) (i: i32) (x: i32): *[]i32 =     a with [i] = a[i] + x@@ -1499,16 +1495,23 @@ function from the `prelude <https://futhark-lang.org/docs/prelude/doc/prelude/soacs.html>`_. -Alias Analysis-~~~~~~~~~~~~~~+Alias Propagation+~~~~~~~~~~~~~~~~~ -The rules used by the Futhark compiler to determine aliasing are-intuitive in the intra-procedural case.  Aliases are associated with-entire arrays.  Aliases of a record are tuple are tracked for each-element, not for the record or tuple itself.  Most constructs produce-fresh arrays, with no aliases.  The main exceptions are ``if``,-``loop``, function calls, and variable literals.+The key safety property behind in-place updates is that once an object has been+consumed, it is never accessed again. To guarantee this property, the compiler+must also be aware of the potential for *aliasing*: whether two different+variables share underlying storage. +The rules used by the Futhark compiler to determine aliasing are somewhat+intricate, but the intuition is easy: the result of an expression aliases its+subexpressions, except for expressions that explicitly construct fresh results.++Aliases are tracked at the level of arrays and abstract types. Aliases of a+record or tuple are tracked for each element, not for the record or tuple+itself. Most constructs produce fresh arrays, with no aliases. The main+exceptions are ``if``, ``loop``, function calls, and variable literals.+ * After a binding ``let a = b``, that simply assigns a new name to an   existing variable, the variable ``a`` aliases ``b``.  Similarly for   record projections and patterns.@@ -1520,29 +1523,42 @@   aliases that the merge parameters may assume at the end of an   iteration, computed to a fixed point. -* The aliases of a value returned from a function is the most-  interesting case, and depends on whether the return value is-  declared *alias-free* (with an asterisk ``*``) or not.  If it is-  declared alias-free, then it has no aliases.  Otherwise, it aliases-  all arguments passed for *non-consumed* parameters.+* The aliases of a value returned from a function is the most interesting case,+  and depends on whether the return value is declared *fresh* (with an asterisk+  ``*``) or not. If it is declared alias-free, then it has no aliases.+  Otherwise, it aliases all arguments passed for *non-consumed* parameters.  In-place Updates and Higher-Order Functions ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consumption generally interacts inflexibly with higher-order-functions.  The issue is that we cannot control how many times a-function argument is applied, or to what, so it is not safe to pass a-function that consumes its argument.  The following two conservative-rules govern the interaction between consumption and higher-order-functions:+Consumption generally interacts inflexibly with higher-order functions. The+issue is that we cannot control how many times a function argument is applied,+or to what, so it is not safe to pass a function that consumes its argument. The+following two conservative rules govern the interaction between consumption and+higher-order functions:  1. In the expression ``let p = e1 in ...``, if *any* in-place update    takes place in the expression ``e1``, the value bound by ``p`` must    not be or contain a function. -2. A function that consumes one of its arguments may not be passed as-   a higher-order argument to another function.+2. A function that consumes one of its arguments may not be passed as a+   higher-order argument to another function, unless that other function+   explicitly expects a consuming function. +3. It is not possible to quantify over the freshness of a functional argument,+   so the fact that a function result is fresh is usually lost when it is passed+   as a functional argument.++   a. A major exception is that the type checker performs parametricity-based+      analysis for *polymorphic* higher-order functions of certain types. For+      example, when using the pipeline operator as ``x |> f``, the compiler is+      able to infer that the result can only possibly come from the function+      ``f``, and hence that the result of the entire expression is as fresh as+      is declared for ``f``.++      This works only for direct references to polymorphic functions, and they+      must be fully applied.+ .. _module-system:  Modules@@ -1741,19 +1757,20 @@  .. productionlist::    attr:   `name`+       : | "$" `name`        : | `decimal`        : | `name` "(" [`attr` ("," `attr`)* [","]] ")" -An expression, declaration, pattern, or module type spec can be-prefixed with an attribute, written as ``#[attr]``.  This may affect-how it is treated by the compiler or other tools.  In no case will-attributes affect or change the *semantics* of a program, but it may-affect how well it compiles and runs (or in some cases, whether it-compiles or runs at all).  Unknown attributes are silently ignored.-Most have no effect in the interpreter.  An attribute can be either an-*atom*, written as an identifier or number, or *compound*, consisting-of an identifier and a comma-separated sequence of attributes.  The-latter is used for grouping and encoding of more complex information.+An expression, declaration, pattern, or module type spec can be prefixed with an+attribute, written as ``#[attr]``. This may affect how it is treated by the+compiler or other tools. In no case will attributes affect or change the+*semantics* of a program, but it may affect how well it compiles and runs (or in+some cases, whether it compiles or runs at all). Unknown attributes are silently+ignored. Most have no effect in the interpreter. An attribute can be either an+*atom*, written as an identifier or number, or *compound*, consisting of an+identifier and a comma-separated sequence of attributes. The latter is used for+grouping and encoding of more complex information. An identifier prefixed with a+``$`` must be the name of a term variable in scope.  Expression attributes ~~~~~~~~~~~~~~~~~~~~~@@ -1924,6 +1941,17 @@ ..........  Always inline calls to this function.++``cpu_function``+................++Compile the body of this function to sequential (CPU) code. Store the parameters+and results in CPU memory, even when using a GPU backend for the rest of the+program. This is useful when you have a costly sequential top-level function in+an otherwise parallel program.++You almost always want to combine this with ``#[noinline]``, as+``#[cpu_function]`` only takes effect when the function is not inlined.  Pattern attributes ~~~~~~~~~~~~~~~~~~
docs/man/futhark-bench.rst view
@@ -99,7 +99,11 @@  --json=file -  Write raw results in JSON format to the specified file.+  Write raw results in JSON format to the specified file.  Each benchmark+  includes metadata describing when and where it ran, the compiler version and+  backend, and options explicitly forwarded to the compiler or runtime.  This+  makes it possible to identify the environment and invocation that produced a+  result file.  --no-tuning
docs/man/futhark-literate.rst view
@@ -31,9 +31,13 @@  **Warning:** Do not run untrusted programs.  See SAFETY below. -Image directives and builtin functions shell out to ``convert`` (from-ImageMagick).  Video and audio generation uses ``ffmpeg``.+Top level functions declared as ``entry`` will run as compiled code, functions+declared with ``def`` will run in the interpreter. Make sure any significant+computation happens inside ``entry`` functions. +Image directives and IO functions shell out to ``convert`` (from ImageMagick).+Video and audio directives and functions use ``ffmpeg``.+ For an input file ``foo.fut``, all generated files will be in a directory named ``foo-img``.  A ``file`` parameter passed to a directive may not contain a directory component or spaces.@@ -96,10 +100,10 @@ place them in the directory ``foo-img/``.  If this directory already exists, it will be deleted. -A directive is a line starting with ``-- >``, which must follow an-empty line.  Arguments to the directive follow on the remainder of the-line.  Any expression arguments are given in a very restricted subset-of Futhark called *FutharkScript* (see below).+A directive is a line starting with ``-- >``, which must follow an empty line.+Arguments to the directive follow on the remainder of the line. Any expression+arguments are evaluated using the Futhark interpreter. Entry points are run as+compiled code, while everything else is interpreted.  Some directives take mandatory or optional parameters.  These are entered after a semicolon *and a linebreak*.@@ -108,8 +112,7 @@  * ``> e`` -  Shows the result of executing the FutharkScript expression ``e``,-  which can have any (transparent) type.+  Shows the result of executing the Futhark expression ``e``.  * ``> :video e[; parameters...]`` @@ -178,8 +181,7 @@   The two arrays must have the same length and are interpreted as   ``x`` and ``y`` values, respectively. -  The expression may also be a record expression (*not* merely the-  name of a Futhark variable of record type), where each field will be+  The expression may also be a record expression, where each field will be   plotted separately and must have the type mentioned above.  * ``> :gnuplot e; script...``@@ -235,77 +237,22 @@   amerge filter from ffmpeg, so consult the documentation there for additional   information. -FUTHARKSCRIPT-=============--Only an extremely limited subset of Futhark is supported:--.. productionlist::-   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` )+ ")"-              : | "[" `script_exp` ( "," `script_exp` )+ "]"-              : | "empty" "(" ("[" `decimal` "]" )+ `script_type` ")"-              : | "{" "}"-              : | "{" (`id` = `script_exp`) ("," `id` = `script_exp`)* "}"-   script_pat:  `id` | "(" `id` ("," `id`)* ")"-   script_fun:  `id` | "$" `id`-   script_type: `int_type` | `float_type` | "bool"--Note that empty arrays must be written using the ``empty(t)``-notation, e.g. ``empty([0]i32)``.--Function applications are either of Futhark functions or *builtin-functions*.  The latter are prefixed with ``$`` and are magical-(usually impure) functions that could not possibly be implemented in-Futhark.  The following builtins are supported:--* ``$loadimg "file"`` reads an image from the given file and returns-  it as a row-major ``[][]u32`` array with each pixel encoded as ARGB.--* ``$loaddata "file"`` reads a dataset from the given file. When the file-  contains a singular value, it is returned as value. Otherwise, a tuple-  of values is returned, which should be destructured before use. For example:-  ``let (a, b) = $loaddata "foo.in" in bar a b``.--* ``$loadbytes "file"`` reads the contents of the given file as an-  array of type ``[]u8``.--* ``$loadaudio "file"`` reads audio from the given file and returns it as a-  ``[][]f64``, where each row corresponds to a channel of the original-  soundfile. Most common audio-formats are supported, including mp3, ogg, wav,-  flac and opus.--* ``$restore "type" "file"`` loads a serialised value of type ``type`` from-  ``file``. The usual caveats apply regarding the stability of the value-  serialisation format.--FutharkScript supports a form of automatic uncurrying. If a function-taking *n* parameters is applied to a single argument that is an-*n*-element tuple, the function is applied to the elements of the-tuple as individual arguments.- SAFETY ====== -Some directives (e.g. ``:gnuplot``) can run arbitrary shell commands.-Other directives or builtin functions can read or write arbitrary-files.  Running an untrusted literate Futhark program is as dangerous-as running a shell script you downloaded off the Internet.  Before-running a program from an unknown source, you should always give it a-quick read to see if anything looks fishy.+Some directives (e.g. ``:gnuplot``) can run arbitrary shell commands. Other+directives or IO functions can read arbitrary files. Running an untrusted+literate Futhark program is as dangerous as running a shell script you+downloaded off the Internet. Before running a program from an unknown source,+you should always give it a quick read to see if anything looks fishy.  BUGS ==== -FutharkScript expressions can only refer to names defined in the file-passed to ``futhark literate``, not any names in imported files.+The caching machinery does not notice when an external file referenced by an IO+function changes.  SEE ALSO ======== -:ref:`futhark-script(1)`, :ref:`futhark-test(1)`, :ref:`futhark-bench(1)`+:ref:`futhark-test(1)`, :ref:`futhark-bench(1)`
docs/man/futhark-profile.rst view
@@ -39,10 +39,16 @@ created for each benchmark dataset. If the original invocation of ``futhark bench`` included multiple programs, then ``futhark profile`` will create subdirectories for each program (although all inside the same top level-directory). If the source files passed to ``futhark bench`` are accessible via-the original paths, then the directory will also contain HTML files with-annotated source code.+directory). The dataset HTML reports include the log and timeline even when+the source files are unavailable. If the source files passed to ``futhark+bench`` are accessible via the original paths, the reports also link to HTML+files with annotated source code. +Open ``prog.prof/index.html`` to browse the program indexes. Each program+index links to the dataset indexes that were generated successfully.+Failed datasets and datasets with neither a log nor profiling information do+not have an HTML index.+ You can pass multiple JSON files to ``futhark profile``. Each will produce a distinct top level directory. @@ -64,9 +70,18 @@   most importantly the source locations.  * ``foo-index.html``: overview file and guide to the other html files.-  Contains explanations for the concepts, links to other pages.-  This is the entry file for profile exploration.+  Contains the log and timeline as preformatted text, with links to jump to+  either section, and navigation to the source and cost centre pages.+  This is the entry file for profile exploration. Missing logs or profiling+  information are indicated explicitly; a recorded empty log or timeline is+  shown as empty. A dataset with only a log still gets an HTML report. Failed+  datasets and datasets with neither a log nor a profile do not. +The HTML sections contain the same text as the log and timeline files, which+remain available separately. Event order, durations, and provenance are+preserved; backend-specific event details remain in the input JSON. No+allocation/deallocation events or start times are inferred from the log.+ The log file is often too verbose to be useful, but the summary and timeline should be inspected, even if the latter is sometimes fairly large. @@ -89,7 +104,9 @@ Alternatively, the JSON file passed to ``futhark profile`` may also be a raw profiling report as produced by the C API function ``futhark_context_report()``. A directory is still created, but it will only contain a single set of files,-and it will not contain a log.+and it will not contain a log. Open ``index.html`` in this directory to read+the timeline and browse the source information. The text files are named+``summary`` and ``timeline``.  EXAMPLES ========
docs/man/futhark-repl.rst view
@@ -9,31 +9,57 @@ SYNOPSIS ======== -futhark repl [program.fut]+futhark repl [options...] [program.fut]  DESCRIPTION =========== -Start an interactive Futhark session.  This will let you interactively-enter expressions and declarations which are then immediately-interpreted.  If the entered line can be either a declaration or an-expression, it is assumed to be a declaration.  The input msut fit on-a single line.+Start an interactive Futhark session. This will let you interactively enter+expressions and declarations which are then immediately interpreted. If the+entered line can be either a declaration or an expression, it is assumed to be a+declaration. The input must fit on a single line. Evaluation uses the Futhark+interpreter, which is somewhat slow, but allows use of the ``#[break]``+attribute.  Futhark source files can be loaded using the ``:load`` command.  This will erase any interactively entered definitions.  Use the ``:help`` command to see a list of commands.  All commands are prefixed with a colon. -``futhark repl`` uses the Futhark interpreter, which grants access to-the ``#[trace]`` and ``#[break]`` attributes.  See-:ref:`futhark-run(1)` for a description.+If ``--backend`` is passed, the entry points of the loaded program are not+interpreted, but are instead compiled and run by a server-mode executable.+Everything else - including any definitions entered interactively - is still+interpreted. This lets you inspect the results of compiled code interactively,+at the cost of the entry points no longer being subject to interpreter+facilities such as ``#[break]``. Values produced by an entry point are fetched+from the server only when needed, so indexing a large result does not require+transferring all of it.  OPTIONS ======= +--backend=name++  Run the entry points of the loaded program with this backend+  (without leading ``futhark``, e.g. just ``opencl``), rather than+  interpreting them.+ -h   Print help text to standard output and exit.++--pass-compiler-option=opt++  Pass an extra option to the compiler when compiling the program.++-p, --pass-option=opt++  Pass an option to the server-mode executable that is being run.++--skip-compilation++  Do not run the compiler, and instead assume that the program has+  already been compiled into a server-mode executable.  Use with+  caution.  -V   Print version information on standard output and exit.
− docs/man/futhark-script.rst 
@@ -1,106 +0,0 @@-.. role:: ref(emphasis)--.. _futhark-script(1):--================-futhark-script-================--SYNOPSIS-========--futhark script [options...] program [expression]--DESCRIPTION-===========--The command ``futhark script foo.fut expr`` will compile ``foo.fut``,-run the provided FutharkScript expression ``expr``, and finally print-the result to stdout. It is essentially a simpler way to access the-evaluation facilities of :ref:`futhark-literate(1)`, and provides the-same FutharkScript facilities, with a few additional built-in-procedures documented below.--If the provided program does not have a ``.fut`` extension, it is-assumed to be a previously compiled server-mode program, and simply-run directly.--When ``-e`` and ``-f`` are used, the expressions are run in the order-provided, and only the value of the last expression is printed. This-implies multiple uses of these options is only useful when they invoke-procedures with side effects.--OPTIONS-=======----backend=name--  The backend used when compiling Futhark programs (without leading-  ``futhark``, e.g. just ``opencl``).  Defaults to ``c``.---b, --binary--  Produce output in the binary data format. Fails if the value is not-  a primitive or array of primitives.---D, --debug--  Pass ``-D`` to the executable and show debug prints.---e, --expression=EXP--  Evaluate this FutharkScript expression. Expressions are run in the-  order provided.----futhark=program--  The program used to perform operations (eg. compilation). Defaults-  to the binary running ``futhark script`` itself.---f, --file=FILe--  Read and evaluate FutharkScript expression from this file.-  Expressions are run in the order provided.---L, --log--  Pass ``-L`` to the executable and show debug prints.----pass-option=opt--  Pass an option to benchmark programs that are being run.----pass-compiler-option=opt--  Pass an extra option to the compiler when compiling the programs.----skip-compilation--  Do not run the compiler, and instead assume that the program has-  already been compiled.  Use with caution.---v, --verbose--  Print verbose information on stderr about directives as they are-  executing.  This is also needed to see ``#[trace]`` output.--ADDITIONAL BUILTINS-===================--* ``$store "file" v`` store the value *v* as a binary value in the given file.-  It can be restored again with ``$restore``.--BUGS-====--FutharkScript expressions can only refer to names defined in the file-passed to ``futhark script``, not any names in imported files.--If the result of the expression does not have an external-representation (e.g. is an array of tuples), the value that is printed-is misleading and somewhat nonsensical.--SEE ALSO-========--:ref:`futhark-test(1)`, :ref:`futhark-bench(1)`, :ref:`futhark-literate(1)`
docs/man/futhark-test.rst view
@@ -59,20 +59,15 @@ Apart from sizes, integer constants (with or without type suffix), and floating-point constants (always with type suffix) are also permitted. -If ``input`` is preceded by ``script``, the text between the curly-braces is interpreted as a FutharkScript expression (see-:ref:`futhark-literate(1)`), which is executed to generate the input.-It must use only functions explicitly declared as entry points. If the-expression produces an *n*-element tuple, it will be unpacked and its-components passed as *n* distinct arguments to the test function. The-only builtin functions supported are ``$loaddata`` and ``$loadbytes``.+If ``input`` is preceded by ``script``, the text between the curly braces is a+Futhark expression, which is executed via the interpreter to generate the input.+Caveats apply, below. -If ``input`` is followed by an ``@`` and a file name (which must not-contain any whitespace) instead of curly braces, values will be read-from the indicated file.  This is recommended for large data sets.-This notation cannot be used with ``random`` input.  With ``script-input``, the file contents will be interpreted as a FutharkScript-expression.+If ``input`` is followed by an ``@`` and a file name (which must not contain any+whitespace) instead of curly braces, values will be read from the indicated+file. This is recommended for large data sets. This notation cannot be used with+``random`` input. With ``script input``, the file contents will be interpreted+as a Futhark expression.  After the ``input`` block, the expected result of the test case is written as either ``output`` followed by another block of values, or@@ -80,13 +75,11 @@ If neither ``output`` nor ``error`` is given, the program will be expected to execute succesfully, but its output will not be validated. -If ``output`` is preceded by ``auto`` (as in ``auto output``), the-expected values are automatically generated by compiling the program-with ``futhark c`` and recording its result for the given input (which-must not fail).  This is usually only useful for testing or-benchmarking alternative compilers, and not for testing the-correctness of Futhark programs.  This currently does not work for-``script`` inputs.+If ``output`` is preceded by ``auto`` (as in ``auto output``), the expected+values are automatically generated by compiling the program with ``futhark c``+and recording its result for the given input (which must not fail). This is+usually only useful for testing or benchmarking alternative compilers, and not+for testing the correctness of Futhark programs.  Alternatively, instead of input-output pairs, the test cases can simply be a description of an expected compile time type error::@@ -134,6 +127,23 @@ of the array. You therefore only need to provide a type suffix on the first element. If no suffix is provided, integer arrays have element type ``i32`` and decimal arrays have type ``f64``.++SCRIPT INPUT+------------++When using ``script input``, the input block provides a Futhark expression that+is interpreted to produce input for the entry point. If the expression produces+an *n*-element tuple and the entry point has *n* parameters, the tuple is+unpacked and its components passed as distinct arguments to the entry point.++Although the expression can use any functions available in the file, only those+that have been declared ``entry`` will be run as compiled code. Since the+Futhark interpreter is very slow, you should make sure that any large values are+produced with entry points.++You should not pass abstract types produced by interpreted code to compiled+entry points. A good rule of thumb is to do all nontrivial work inside entry+points.  PROPERTY-BASED TESTING ----------------------
docs/man/futhark.rst view
@@ -74,11 +74,14 @@ intended for use in developing the Futhark compiler, not for programmers writing in Futhark. -futhark eval [-f FILE] [-w] <exprs...>---------------------------------------+futhark eval [options...] <exprs...>+------------------------------------  Evaluates expressions given as command-line arguments. Optionally allows a file import using ``-f``.++If ``--backend`` is passed, the entry points of the file loaded with ``-f`` are+compiled, as for :ref:`futhark-repl(1)`.  futhark hash PROGRAM --------------------
docs/server-protocol.rst view
@@ -50,8 +50,9 @@ 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 ``output`` commands (see below).+``[][]i32``). Freshness and consumption is not part of the types, but is+indicated with an asterisk in the ``inputs`` and ``output`` commands (see+below).  Consumption and aliasing ------------------------@@ -116,7 +117,7 @@ ..................  Print the type of the output produced by the given entry point, on a single-line. If the output is guaranteed to be unique (does not alias any inputs), the+line. If the output is guaranteed to be fresh (does not alias any inputs), the type is prefixed by `*`.  ``clear``
docs/usage.rst view
@@ -369,27 +369,27 @@ generated API.  Unfortunately, The type system of most languages (e.g. C) is not rich enough to express the rules, so they are not statically (or currently even dynamically checked).  Since Futhark-will never infer a unique/consuming type for an entry point parameter,-this section can be ignored unless uniqueness annotations have been+will never infer a consuming type for an entry point parameter,+this section can be ignored unless annotations have been manually added to the entry points parameter types.  The rules are essentially the same as in the language itself: -1. Each entry point input parameter is either *consuming* or-   *nonconsuming* (the default).  This corresponds to unique and-   nonunique types in the original Futhark program.  A value passed-   for a consuming parameter is considered *consumed*, now has an-   unspecified value, and may never be used again.  It must still be-   manually freed, if applicable.-   Further, any *aliases* of that value are also considered consumed-   and may not be used.+1. Each entry point input parameter is either *consuming* or *observing* (the+   default). A value passed for a consuming parameter is considered *consumed*,+   now has an unspecified value, and may never be used again. It must still be+   manually freed, if applicable. Further, any *aliases* of that value are also+   considered consumed and may not be used. -2. The entry point output iseither *unique* or *nonunique*. A unique output has-   no aliases. A nonunique output aliases *every* nonconsuming input parameter.+2. The entry point output is either *fresh* or *nonfresh*. A fresh output has no+   aliases. A nonfresh output aliases *every* nonconsumed input parameter. If+   the nonfresh output is a compound value (e.g. a tuple), the components may+   also alias each other. -Note that these distinctions are currently usually not visible in the-generated API, and so correct usage requires knowledge of the original-types in the Futhark function.  The safest strategy is to not expose-unique types in entry points.+Note that these distinctions are currently usually not visible in the generated+API, and so correct usage requires knowledge of the original types in the+Futhark function. The safest strategy is to not consume inputs in entry points,+or to ensure that any value passed for a consuming input came from a fresh+output.  Generating C ^^^^^^^^^^^^
docs/versus-other-languages.rst view
@@ -6,20 +6,19 @@ This guide is intended for programmers who are familiar with other functional languages and want to start working with Futhark. -Futhark is a simple language with a complex compiler.  Functional-programming is fundamentally well suited to data parallelism, so-Futhark's syntax and underlying concepts are taken directly from-established functional languages such as Haskell and the ML family.-While Futhark does add a few small conveniences (built-in array types)-and one complicated and unusual feature (in-place updates via-uniqueness types, see :ref:`in-place-updates`), a programmer familiar-with a common functional language should be able to understand the-meaning of a Futhark program and quickly begin writing their own-programs.  To speed up this process, we describe here some of the-various quirks and unexpected limitations imposed by Futhark. We also-recommended reading some of the `example programs`_ along with this-guide.  The guide does *not* cover all Futhark features worth knowing,-so do also skim :ref:`language-reference` and the :ref:`glossary`.+Futhark is a simple language with a complex compiler. Functional programming is+fundamentally well suited to data parallelism, so Futhark's syntax and+underlying concepts are taken directly from established functional languages+such as Haskell and the ML family. While Futhark does add a few small+conveniences (built-in array types) and one complicated and unusual feature+(in-place updates via effects and aliases, see :ref:`in-place-updates`), a+programmer familiar with a common functional language should be able to+understand the meaning of a Futhark program and quickly begin writing their own+programs. To speed up this process, we describe here some of the various quirks+and unexpected limitations imposed by Futhark. We also recommended reading some+of the `example programs`_ along with this guide. The guide does *not* cover all+Futhark features worth knowing, so do also skim :ref:`language-reference` and+the :ref:`glossary`.  .. _`example programs`: https://futhark-lang.org/examples.html
futhark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name:           futhark-version:        0.27.1+version:        0.28.1 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -110,6 +110,13 @@  library   import: common+  -- These cause specialisation of class-heavy code, which speeds up compilation+  -- a lot. Only overloaded functions are exposed, as those are the only ones+  -- specialisation needs, and exposing everything makes almost any change+  -- recompile most of the compiler. Futhark.Passes and Futhark.Actions also set+  -- -fomit-interface-pragmas, as otherwise any change to a pass or backend+  -- recompiles every CLI module.+  ghc-options: -fexpose-overloaded-unfoldings -fspecialise-aggressively   hs-source-dirs: src   exposed-modules:       Futhark@@ -177,7 +184,6 @@       Futhark.CLI.Query       Futhark.CLI.REPL       Futhark.CLI.Run-      Futhark.CLI.Script       Futhark.CLI.Test       Futhark.CLI.WASM       Futhark.CodeGen.Backends.CCUDA@@ -397,8 +403,8 @@       Futhark.Profile.EventSummary       Futhark.Profile.Html       Futhark.Profile.SourceRange-      Futhark.Script       Futhark.Test+      Futhark.Test.Compile       Futhark.Test.Property       Futhark.Test.Spec       Futhark.Test.Values@@ -424,6 +430,10 @@       Language.Futhark.Core       Language.Futhark.Interpreter       Language.Futhark.Interpreter.AD+      Language.Futhark.Interpreter.FFI.AtomicList+      Language.Futhark.Interpreter.FFI.Push+      Language.Futhark.Interpreter.FFI.ServerM+      Language.Futhark.Interpreter.IO       Language.Futhark.Interpreter.Values       Language.Futhark.FreeVars       Language.Futhark.Parser@@ -493,8 +503,8 @@     , filepath >=1.4.1.1     , free >=5.1.10     , futhark-data >= 1.1.4.0-    , futhark-server >= 1.4.1.0-    , futhark-manifest == 1.9.0.0+    , futhark-server >= 1.5.0.0+    , futhark-manifest == 1.11.0.0     , githash >=0.1.6.1     , half >= 0.3     , haskeline@@ -512,6 +522,7 @@     , random >= 1.2.0     , process-extras >=0.7.2     , regex-tdfa >=1.2+    , split >= 0.2     , srcloc >=0.4     , template-haskell >=2.11.1     , temporary@@ -531,7 +542,7 @@ executable futhark   import: common   main-is: src/main.hs-  ghc-options: -threaded -rtsopts "-with-rtsopts=-maxN16 -qg1 -A16M"+  ghc-options: -threaded -rtsopts "-with-rtsopts=-maxN16 -qg1 -A32M"   build-depends: base, futhark  library futhark-testing
prelude/ad.fut view
@@ -141,44 +141,44 @@  -- | Jacobian-Vector Product ("forward mode"), producing also the -- primal result as the first element of the result tuple.-def jvp2 'a 'b (f: a -> b) (x: a) (x': a) : (b, b) =+def jvp2 'a 'b (f: a -> b) (x: a) (x': a) : (*b, *b) =   intrinsics.jvp2 f x x'  -- | Vector-Jacobian Product ("reverse mode"), producing also the -- primal result as the first element of the result tuple.-def vjp2 'a 'b (f: a -> b) (x: a) (y': b) : (b, a) =+def vjp2 'a 'b (f: a -> b) (x: a) (y': b) : (*b, *a) =   intrinsics.vjp2 f x y'  -- | Jacobian-Matrix Product, returning also the primal result. As `jvp2`, but -- accepts an array of seed vectors (hence "matrix", although transposed). -- Semantically equivalent to mapping, but may be more efficient. If used with -- `#[unroll]`, tangent calculations are unrolled when possible.-def jmp2 'a 'b [n] (f: a -> b) (x: a) (x': [n]a) : (b, [n]b) =+def jmp2 'a 'b [n] (f: a -> b) (x: a) (x': [n]a) : (*b, *[n]b) =   intrinsics.jmp2 f x x'  -- | Matrix-Jacobian Product, returning also the primal result. As `vjp2`, but -- accepts an array of seed vectors (hence "matrix"). Semantically equivalent to -- mapping, but may be more efficient. If used with `#[unroll]`, adjoint -- calculations are unrolled when possible.-def mjp2 'a 'b [n] (f: a -> b) (x: a) (y': [n]b) : (b, [n]a) =+def mjp2 'a 'b [n] (f: a -> b) (x: a) (y': [n]b) : (*b, *[n]a) =   intrinsics.mjp2 f x y'  -- | Jacobian-Vector Product ("forward mode").-def jvp 'a 'b (f: a -> b) (x: a) (x': a) : b =+def jvp 'a 'b (f: a -> b) (x: a) (x': a) : *b =   (jvp2 f x x').1  -- | Vector-Jacobian Product ("reverse mode").-def vjp 'a 'b (f: a -> b) (x: a) (y': b) : a =+def vjp 'a 'b (f: a -> b) (x: a) (y': b) : *a =   (vjp2 f x y').1  -- | Jacobian-Matrix Product. As `jvp`, but accepts a vector of seed values. -- Semantically equivalent to mapping, but may be more efficient.-def jmp 'a 'b [n] (f: a -> b) (x: a) (x': [n]a) : [n]b =+def jmp 'a 'b [n] (f: a -> b) (x: a) (x': [n]a) : *[n]b =   (jmp2 f x x').1  -- | Matrix-Jacobian product. As `vjp`, but accepts a vector of seed values. -- Semantically equivalent to mapping, but may be more efficient.-def mjp 'a 'b [n] (f: a -> b) (x: a) (y': [n]b) : [n]a =+def mjp 'a 'b [n] (f: a -> b) (x: a) (y': [n]b) : *[n]a =   (mjp2 f x y').1  -- | Provide custom reverse-mode adjoint code for a given function. This is
prelude/math.fut view
@@ -22,9 +22,9 @@ --   extension. -- -- * Creating an integer from a floating point number is by numerical---   truncation. If the floating-point number is infinity or NaN, then the---   integer value is not meaningful. Use `to_bits` if you want to inspect the---   bitwise representation of a float.+--   truncation. If the floating-point number is infinity, NaN, or too large to+--   be represented as an integer, then the integer value is not meaningful. Use+--   `to_bits` if you want to inspect the bitwise representation of a float. -- -- * Creating a floating-point number from an integer is by numerical conversion --   (which may introduce roundoff error). Use `from_bits` if you want to@@ -32,21 +32,21 @@ module type from_prim = {   type t -  val i8 : i8 -> t-  val i16 : i16 -> t-  val i32 : i32 -> t-  val i64 : i64 -> t+  val i8 : i8 -> *t+  val i16 : i16 -> *t+  val i32 : i32 -> *t+  val i64 : i64 -> *t -  val u8 : u8 -> t-  val u16 : u16 -> t-  val u32 : u32 -> t-  val u64 : u64 -> t+  val u8 : u8 -> *t+  val u16 : u16 -> *t+  val u32 : u32 -> *t+  val u64 : u64 -> *t -  val f16 : f16 -> t-  val f32 : f32 -> t-  val f64 : f64 -> t+  val f16 : f16 -> *t+  val f32 : f32 -> *t+  val f64 : f64 -> *t -  val bool : bool -> t+  val bool : bool -> *t }  -- | A basic numeric module type that can be implemented for both@@ -54,12 +54,12 @@ module type numeric = {   include from_prim -  val (+) : t -> t -> t-  val (-) : t -> t -> t-  val (*) : t -> t -> t-  val (/) : t -> t -> t-  val (%) : t -> t -> t-  val (**) : t -> t -> t+  val (+) : t -> t -> *t+  val (-) : t -> t -> *t+  val (*) : t -> t -> *t+  val (/) : t -> t -> *t+  val (%) : t -> t -> *t+  val (**) : t -> t -> *t    val to_i64 : t -> i64 @@ -71,15 +71,15 @@   val (!=) : t -> t -> bool    -- | Arithmetic negation (use `!` for bitwise negation).-  val neg : t -> t-  val max : t -> t -> t-  val min : t -> t -> t+  val neg : t -> *t+  val max : t -> t -> *t+  val min : t -> t -> *t -  val abs : t -> t+  val abs : t -> *t    -- | Sign function.  Produces -1, 0, or 1 if the argument is   -- respectively less than, equal to, or greater than zero.-  val sgn : t -> t+  val sgn : t -> *t    -- | The most positive representable number.   val highest : t@@ -89,16 +89,16 @@   val lowest : t    -- | Returns zero on empty input.-  val sum [n] : [n]t -> t+  val sum [n] : [n]t -> *t    -- | Returns one on empty input.-  val product [n] : [n]t -> t+  val product [n] : [n]t -> *t    -- | Returns `lowest` on empty input.-  val maximum [n] : [n]t -> t+  val maximum [n] : [n]t -> *t    -- | Returns `highest` on empty input.-  val minimum [n] : [n]t -> t+  val minimum [n] : [n]t -> *t }  -- | An extension of `numeric`@mtype that provides facilities that are@@ -108,47 +108,47 @@    -- | Like `/`, but rounds towards zero. This only matters when one of the   -- operands is negative. May be more efficient.-  val (//) : t -> t -> t+  val (//) : t -> t -> *t    -- | Like `%`, but rounds towards zero. This only matters when one of the   -- operands is negative. May be more efficient.-  val (%%) : t -> t -> t+  val (%%) : t -> t -> *t    -- | Bitwise and.-  val (&) : t -> t -> t+  val (&) : t -> t -> *t    -- | Bitwise or.-  val (|) : t -> t -> t+  val (|) : t -> t -> *t    -- | Bitwise xor.-  val (^) : t -> t -> t+  val (^) : t -> t -> *t    -- | Bitwise negation.-  val not : t -> t+  val not : t -> *t    -- | Left shift; inserting zeroes.-  val (<<) : t -> t -> t+  val (<<) : t -> t -> *t    -- | Arithmetic right shift, using sign extension for the leftmost bits.-  val (>>) : t -> t -> t+  val (>>) : t -> t -> *t    -- | Logical right shift, inserting zeroes for the leftmost bits.-  val (>>>) : t -> t -> t+  val (>>>) : t -> t -> *t    val num_bits : i32   val get_bit : i32 -> t -> i32-  val set_bit : i32 -> t -> i32 -> t+  val set_bit : i32 -> t -> i32 -> *t    -- | Count number of one bits.   val popc : t -> i32    -- | Computes `x * y` and returns the high half of the product of x   -- and y.-  val mul_hi : (x: t) -> (y: t) -> t+  val mul_hi : (x: t) -> (y: t) -> *t    -- | Computes `mul_hi a b + c`, but perhaps in a more efficient way,   -- depending on the target platform.-  val mad_hi : (a: t) -> (b: t) -> (c: t) -> t+  val mad_hi : (a: t) -> (b: t) -> (c: t) -> *t    -- | Count number of zero bits preceding the most significant set   -- bit.  Returns the number of bits in the type if the argument is@@ -166,57 +166,57 @@   include numeric    -- | Multiplicative inverse.-  val recip : t -> t+  val recip : t -> *t -  val from_fraction : i64 -> i64 -> t+  val from_fraction : i64 -> i64 -> *t   val to_i64 : t -> i64   val to_f64 : t -> f64    -- | Square root.-  val sqrt : t -> t+  val sqrt : t -> *t    -- | Inverse square root. Depending on the backend, this may be   -- faster than `1/sqrt(x)`.-  val rsqrt : t -> t+  val rsqrt : t -> *t    -- | Cube root.-  val cbrt : t -> t-  val exp : t -> t+  val cbrt : t -> *t+  val exp : t -> *t -  val sin : t -> t-  val cos : t -> t-  val tan : t -> t+  val sin : t -> *t+  val cos : t -> *t+  val tan : t -> *t    -- | `sin(pi*x)` - depending on backing, may be faster or more   -- accurate.-  val sinpi : t -> t+  val sinpi : t -> *t    -- | `cos(pi*x)` - depending on backing, may be faster or more   -- accurate.-  val cospi : t -> t+  val cospi : t -> *t    -- | `tan(pi*x)` - depending on backing, may be faster or more   -- accurate.-  val tanpi : t -> t+  val tanpi : t -> *t -  val asin : t -> t-  val acos : t -> t-  val atan : t -> t+  val asin : t -> *t+  val acos : t -> *t+  val atan : t -> *t -  val asinpi : t -> t-  val acospi : t -> t-  val atanpi : t -> t+  val asinpi : t -> *t+  val acospi : t -> *t+  val atanpi : t -> *t -  val sinh : t -> t-  val cosh : t -> t-  val tanh : t -> t+  val sinh : t -> *t+  val cosh : t -> *t+  val tanh : t -> *t -  val asinh : t -> t-  val acosh : t -> t-  val atanh : t -> t+  val asinh : t -> *t+  val acosh : t -> *t+  val atanh : t -> *t -  val atan2 : t -> t -> t-  val atan2pi : t -> t -> t+  val atan2 : t -> t -> *t+  val atan2pi : t -> t -> *t    -- | Compute the length of the hypotenuse of a right-angled   -- triangle.  That is, `hypot x y` computes *√(x²+y²)*.  Put another@@ -224,59 +224,59 @@   -- The calculation is performed without undue overflow or underflow   -- during intermediate steps (specific accuracy depends on the   -- backend).-  val hypot : t -> t -> t+  val hypot : t -> t -> *t    -- | The true Gamma function.-  val gamma : t -> t+  val gamma : t -> *t    -- | The natural logarithm of the absolute value of `gamma`.-  val lgamma : t -> t+  val lgamma : t -> *t    -- | The error function.-  val erf : t -> t+  val erf : t -> *t    -- | The complementary error function.-  val erfc : t -> t+  val erfc : t -> *t    -- | Linear interpolation.  The third argument must be in the range   -- `[0,1]` or the results are unspecified.-  val lerp : t -> t -> t -> t+  val lerp : t -> t -> t -> *t    -- | Natural logarithm.-  val log : t -> t+  val log : t -> *t    -- | Base-2 logarithm.-  val log2 : t -> t+  val log2 : t -> *t    -- | Base-10 logarithm.-  val log10 : t -> t+  val log10 : t -> *t    -- | Compute `log (1 + x)` accurately even when `x` is very small.-  val log1p : t -> t+  val log1p : t -> *t    -- | Round towards infinity.-  val ceil : t -> t+  val ceil : t -> *t    -- | Round towards negative infinity.-  val floor : t -> t+  val floor : t -> *t    -- | Round towards zero.-  val trunc : t -> t+  val trunc : t -> *t    -- | Round to the nearest integer, with halfway cases rounded to the   -- nearest even integer.  Note that this differs from `round()` in   -- C, but matches more modern languages.-  val round : t -> t+  val round : t -> *t    -- | Computes `a*b+c`.  Depending on the compiler backend, this may   -- be fused into a single operation that is faster but less   -- accurate.  Do not confuse it with `fma`.-  val mad : (a: t) -> (b: t) -> (c: t) -> t+  val mad : (a: t) -> (b: t) -> (c: t) -> *t    -- | Computes `a*b+c`, with `a*b` being rounded with infinite   -- precision.  Rounding of intermediate products shall not   -- occur. Edge case behavior is per the IEEE 754-2008 standard.-  val fma : (a: t) -> (b: t) -> (c: t) -> t+  val fma : (a: t) -> (b: t) -> (c: t) -> *t    val isinf : t -> bool   val isnan : t -> bool@@ -301,12 +301,12 @@   -- 't'.   type int_t -  val from_bits : int_t -> t+  val from_bits : int_t -> *t   val to_bits : t -> int_t    val num_bits : i32   val get_bit : i32 -> t -> i32-  val set_bit : i32 -> t -> i32 -> t+  val set_bit : i32 -> t -> i32 -> *t    -- | The difference between 1.0 and the next larger representable   -- number.@@ -314,13 +314,13 @@    -- | Produces the next representable number from `x` in the   -- direction of `y`.-  val nextafter : (x: t) -> (y: t) -> t+  val nextafter : (x: t) -> (y: t) -> *t    -- | Multiplies floating-point value by 2 raised to an integer power.-  val ldexp : t -> i32 -> t+  val ldexp : t -> i32 -> *t    -- | Compose a floating-point value with the magnitude of `x` and the sign of `y`.-  val copysign : (x: t) -> (y: t) -> t+  val copysign : (x: t) -> (y: t) -> *t }  -- | Boolean numbers.  When converting from a number to `bool`, 0 is
prelude/prelude.fut view
@@ -40,3 +40,32 @@ -- `futhark repl`.  Deprecated: use `#[break]` attribute instead. def break 't (x: t) : t =   #[break] x++-- | These operations only work in interpreted code. Trying to use them in a+-- compiled program will cause the compiler to halt. All of these terminate+-- execution in uncatchable ways on failure - they are intended for use in+-- `futhark literate`, test input generation, etc.+module io+  : {+      -- | Return the contents of the given file as a byte array.+      val loadbytes [k] : [k]u8 -> ?[n].*[n]u8++      -- | Reads an image from the given file and returns it as a row-major+      -- array, with each pixel encoded as ARGB.+      val loadimg [k] : [k]u8 -> ?[n][m].*[n][m]u32++      -- | Read audio from the given file and returns it as a ``[][]f64``, where+      -- each row corresponds to a channel of the original soundfile. Most common+      -- audio-formats are supported, including mp3, ogg, wav, flac and opus.+      val loadaudio [k] : [k]u8 -> ?[n][m].*[n][m]f64++      -- | Load a Futhark value of known type (including size!) from the given+      -- file. Only supports primitives, arrays of primitives, and tuples. If+      -- the type is a tuple, the file must contain one value for each element.+      val loadvalue 'a [k] : [k]u8 -> *a+    } = {+  def loadbytes = intrinsics.io_loadbytes+  def loadimg = intrinsics.io_loadimg+  def loadaudio = intrinsics.io_loadaudio+  def loadvalue = intrinsics.io_loadvalue+}
prelude/soacs.fut view
@@ -103,7 +103,7 @@ -- -- Note that the complexity implies that parallelism in the combining -- operator will *not* be exploited.-def reduce [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a) : a =+def reduce [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a) : *a =   intrinsics.reduce op ne as  -- | As `reduce`, but the operator must also be commutative.  This is@@ -114,7 +114,7 @@ -- **Work:** *O(n ✕ W(op))* -- -- **Span:** *O(log(n) ✕ W(op))*-def reduce_comm [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a) : a =+def reduce_comm [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a) : *a =   intrinsics.reduce_comm op ne as  -- | `h = hist op ne k is as` computes a generalised `k`-bin histogram
prelude/zip.fut view
@@ -34,27 +34,27 @@   internal_map (\(a, (b, c, d, e)) -> (a, b, c, d, e)) (zip as (zip4 bs cs ds es))  -- | Turn an array of pairs into two arrays.-def unzip [n] 'a 'b (xs: [n](a, b)) : ([n]a, [n]b) =+def unzip [n] 'a 'b (xs: [n](a, b)) : *([n]a, [n]b) =   intrinsics.unzip xs  -- | Turn an array of pairs into two arrays.-def unzip2 [n] 'a 'b (xs: [n](a, b)) : ([n]a, [n]b) =+def unzip2 [n] 'a 'b (xs: [n](a, b)) : *([n]a, [n]b) =   unzip xs  -- | As `unzip2`@term, but with one more array.-def unzip3 [n] 'a 'b 'c (xs: [n](a, b, c)) : ([n]a, [n]b, [n]c) =+def unzip3 [n] 'a 'b 'c (xs: [n](a, b, c)) : *([n]a, [n]b, [n]c) =   let (as, bcs) = unzip (internal_map (\(a, b, c) -> (a, (b, c))) xs)   let (bs, cs) = unzip bcs   in (as, bs, cs)  -- | As `unzip3`@term, but with one more array.-def unzip4 [n] 'a 'b 'c 'd (xs: [n](a, b, c, d)) : ([n]a, [n]b, [n]c, [n]d) =+def unzip4 [n] 'a 'b 'c 'd (xs: [n](a, b, c, d)) : *([n]a, [n]b, [n]c, [n]d) =   let (as, bs, cds) = unzip3 (internal_map (\(a, b, c, d) -> (a, b, (c, d))) xs)   let (cs, ds) = unzip cds   in (as, bs, cs, ds)  -- | As `unzip4`@term, but with one more array.-def unzip5 [n] 'a 'b 'c 'd 'e (xs: [n](a, b, c, d, e)) : ([n]a, [n]b, [n]c, [n]d, [n]e) =+def unzip5 [n] 'a 'b 'c 'd 'e (xs: [n](a, b, c, d, e)) : *([n]a, [n]b, [n]c, [n]d, [n]e) =   let (as, bs, cs, des) = unzip4 (internal_map (\(a, b, c, d, e) -> (a, b, c, (d, e))) xs)   let (ds, es) = unzip des   in (as, bs, cs, ds, es)
rts/c/backends/cuda.h view
@@ -91,6 +91,7 @@   int preferred_device_num;    int unified_memory;+  int use_primary_context;    char* dump_ptx_to;   char* load_ptx_from;@@ -112,6 +113,7 @@   cfg->load_ptx_from = NULL;    cfg->unified_memory = 2;+  cfg->use_primary_context = 0;    cfg->gpu = gpu_config_initial;   cfg->gpu.default_block_size = 256;@@ -178,6 +180,10 @@   cfg->unified_memory = flag; } +void futhark_context_config_set_use_primary_context(struct futhark_context_config* cfg, int flag) {+  cfg->use_primary_context = flag;+}+ // A record of something that happened. struct profiling_record {   cudaEvent_t *events; // Points to two events.@@ -768,12 +774,20 @@   if (cuda_device_setup(ctx) != 0) {     futhark_panic(-1, "No suitable CUDA device found.\n");   }-  // cuCtxCreate grew a new parameter in CUDA 13.+  if (ctx->cfg->use_primary_context) {+    // Retain the device's primary context instead of creating a new+    // one.  This makes raw device pointers alias with other libraries+    // (e.g. XLA) that also use the primary context.+    CUDA_SUCCEED_FATAL(cuDevicePrimaryCtxRetain(&ctx->cu_ctx, ctx->dev));+    CUDA_SUCCEED_FATAL(cuCtxSetCurrent(ctx->cu_ctx));+  } else {+    // cuCtxCreate grew a new parameter in CUDA 13. #if (CUDART_VERSION >= 13000)-  CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, NULL, 0, ctx->dev));+    CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, NULL, 0, ctx->dev)); #else-  CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev));+    CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev)); #endif+  }    free_list_init(&ctx->gpu_free_list); @@ -855,7 +869,11 @@     CUDA_SUCCEED_FATAL(gpu_free_all(ctx));     CUDA_SUCCEED_FATAL(cuStreamDestroy(ctx->stream));     CUDA_SUCCEED_FATAL(cuModuleUnload(ctx->module));-    CUDA_SUCCEED_FATAL(cuCtxDestroy(ctx->cu_ctx));+    if (ctx->cfg->use_primary_context) {+      CUDA_SUCCEED_FATAL(cuDevicePrimaryCtxRelease(ctx->dev));+    } else {+      CUDA_SUCCEED_FATAL(cuCtxDestroy(ctx->cu_ctx));+    }   }   free_list_destroy(&ctx->gpu_free_list); }
rts/c/backends/opencl.h view
@@ -13,6 +13,10 @@ // simply optimise the 64-bit version to make this distinction // unnecessary.  Fortunately these kernels are quite small. +#ifdef __APPLE__+#include <mach/mach_time.h>+#endif+ // Forward declarations. struct opencl_device_option; // Invoked by setup_opencl() after the platform and device has been@@ -504,6 +508,21 @@   return build_status; } +// Whether the device supports OpenCL C 2.0, which is how we obtain a+// device-wide memory fence; see mk_compile_opts().  Note that an OpenCL+// 3.0 device may report only 1.2 here, as the 2.0 features are optional+// in 3.0, in which case we conservatively stay on 1.2.+static bool device_supports_opencl_c_2(cl_device_id device) {+  char *version = opencl_device_info(device, CL_DEVICE_OPENCL_C_VERSION);+  int major = 0, minor = 0;+  // The string has the form "OpenCL C <major>.<minor> <vendor-specific>".+  bool supported =+    sscanf(version, "OpenCL C %d.%d", &major, &minor) == 2 && major >= 2;++  free(version);+  return supported;+}+ static char* mk_compile_opts(struct futhark_context *ctx,                              const char *extra_build_opts[],                              struct opencl_device_option device_option) {@@ -533,10 +552,20 @@                    "-DLOCKSTEP_WIDTH=%d ",                    (int)ctx->lockstep_width); +  // mem_fence_global() is a device-wide fence only when the program is+  // compiled as OpenCL C 2.0, which provides atomic_work_item_fence()+  // with device scope.  Under OpenCL C 1.2 it degrades to mem_fence(),+  // which orders memory only within a thread block, and then the+  // device-wide synchronisation we generate - notably the lock-based+  // reduce_by_index - can silently lose updates.  NVIDIA does not+  // support OpenCL C 2.0 at all, and is instead handled with inline+  // assembly in the prelude.   bool is_rusticl_asahi =     strcmp(device_option.platform_name, "rusticl") == 0 &&     strncmp(device_option.device_name, "Apple M", 7) == 0;-  if (is_rusticl_asahi && !cl_std_was_set) {+  if (!cl_std_was_set &&+      (is_rusticl_asahi ||+       device_supports_opencl_c_2(device_option.device))) {     w += snprintf(compile_opts+w, compile_opts_size-w,                   "-cl-std=CL2.0 ");   }@@ -572,7 +601,7 @@    for (int i = 0; i < num_macros; i++) {     w += snprintf(compile_opts+w, compile_opts_size-w,-                  "-D%s=%zu ", macro_names[i], macro_vals[i]);+                  "-D%s=%lld ", macro_names[i], (long long)macro_vals[i]);   }    w += snprintf(compile_opts+w, compile_opts_size-w,@@ -621,8 +650,18 @@                                                &end_t,                                                NULL)); +  double ticks = (double)(end_t - start_t);+#ifdef __APPLE__+  // Apple's OpenCL reports Mach absolute time units rather than+  // nanoseconds; on Apple silicon a unit is 125/3 ns.+  mach_timebase_info_data_t timebase;+  if (mach_timebase_info(&timebase) == KERN_SUCCESS && timebase.denom != 0) {+    ticks = ticks * timebase.numer / timebase.denom;+  }+#endif+   // OpenCL provides nanosecond resolution, but we want microseconds.-  str_builder(sb, ",\"duration\":%f", (end_t - start_t)/1000.0);+  str_builder(sb, ",\"duration\":%f", ticks/1000.0);    OPENCL_SUCCEED_FATAL(clReleaseEvent(*e));
rts/c/gpu.h view
@@ -304,6 +304,11 @@     error = gpu_alloc_actual(ctx, min_size, mem_out);   } +  if (error == FUTHARK_OUT_OF_MEMORY) {+    set_error(ctx, msgprintf("Failed to allocate %lld bytes of GPU memory.\n",+                             (long long)min_size));+  }+   return error; }
rts/c/scalar.h view
@@ -69,25 +69,25 @@   return x / ys; } -SCALAR_FUN_ATTR uint8_t udiv_up8(uint8_t x, uint8_t y) {+SCALAR_FUN_ATTR uint8_t uceil_div8(uint8_t x, uint8_t y) {   uint8_t ys = 1;   foreach_active(i) { ys = y; }   return (x + y - 1) / ys; } -SCALAR_FUN_ATTR uint16_t udiv_up16(uint16_t x, uint16_t y) {+SCALAR_FUN_ATTR uint16_t uceil_div16(uint16_t x, uint16_t y) {   uint16_t ys = 1;   foreach_active(i) { ys = y; }   return (x + y - 1) / ys; } -SCALAR_FUN_ATTR uint32_t udiv_up32(uint32_t x, uint32_t y) {+SCALAR_FUN_ATTR uint32_t uceil_div32(uint32_t x, uint32_t y) {   uint32_t ys = 1;   foreach_active(i) { ys = y; }   return (x + y - 1) / ys; } -SCALAR_FUN_ATTR uint64_t udiv_up64(uint64_t x, uint64_t y) {+SCALAR_FUN_ATTR uint64_t uceil_div64(uint64_t x, uint64_t y) {   uint64_t ys = 1;   foreach_active(i) { ys = y; }   return (x + y - 1) / ys;@@ -141,25 +141,25 @@   return y == 0 ? 0 : x / ys; } -SCALAR_FUN_ATTR uint8_t udiv_up_safe8(uint8_t x, uint8_t y) {+SCALAR_FUN_ATTR uint8_t uceil_div_safe8(uint8_t x, uint8_t y) {   uint8_t ys = 1;   foreach_active(i) { ys = y; }   return y == 0 ? 0 : (x + y - 1) / ys; } -SCALAR_FUN_ATTR uint16_t udiv_up_safe16(uint16_t x, uint16_t y) {+SCALAR_FUN_ATTR uint16_t uceil_div_safe16(uint16_t x, uint16_t y) {   uint16_t ys = 1;   foreach_active(i) { ys = y; }   return y == 0 ? 0 : (x + y - 1) / ys; } -SCALAR_FUN_ATTR uint32_t udiv_up_safe32(uint32_t x, uint32_t y) {+SCALAR_FUN_ATTR uint32_t uceil_div_safe32(uint32_t x, uint32_t y) {   uint32_t ys = 1;   foreach_active(i) { ys = y; }   return y == 0 ? 0 : (x + y - 1) / ys; } -SCALAR_FUN_ATTR uint64_t udiv_up_safe64(uint64_t x, uint64_t y) {+SCALAR_FUN_ATTR uint64_t uceil_div_safe64(uint64_t x, uint64_t y) {   uint64_t ys = 1;   foreach_active(i) { ys = y; }   return y == 0 ? 0 : (x + y - 1) / ys;@@ -221,10 +221,10 @@   return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); } -SCALAR_FUN_ATTR int8_t sdiv_up8(int8_t x, int8_t y) { return sdiv8(x + y - 1, y); }-SCALAR_FUN_ATTR int16_t sdiv_up16(int16_t x, int16_t y) { return sdiv16(x + y - 1, y); }-SCALAR_FUN_ATTR int32_t sdiv_up32(int32_t x, int32_t y) { return sdiv32(x + y - 1, y); }-SCALAR_FUN_ATTR int64_t sdiv_up64(int64_t x, int64_t y) { return sdiv64(x + y - 1, y); }+SCALAR_FUN_ATTR int8_t sceil_div8(int8_t x, int8_t y) { return sdiv8(x + y - 1, y); }+SCALAR_FUN_ATTR int16_t sceil_div16(int16_t x, int16_t y) { return sdiv16(x + y - 1, y); }+SCALAR_FUN_ATTR int32_t sceil_div32(int32_t x, int32_t y) { return sdiv32(x + y - 1, y); }+SCALAR_FUN_ATTR int64_t sceil_div64(int64_t x, int64_t y) { return sdiv64(x + y - 1, y); }  SCALAR_FUN_ATTR int8_t smod8(int8_t x, int8_t y) {   int8_t ys = 1;@@ -259,10 +259,10 @@ SCALAR_FUN_ATTR int32_t sdiv_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : sdiv32(x, y); } SCALAR_FUN_ATTR int64_t sdiv_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : sdiv64(x, y); } -SCALAR_FUN_ATTR int8_t sdiv_up_safe8(int8_t x, int8_t y)     { return sdiv_safe8(x + y - 1, y); }-SCALAR_FUN_ATTR int16_t sdiv_up_safe16(int16_t x, int16_t y) { return sdiv_safe16(x + y - 1, y); }-SCALAR_FUN_ATTR int32_t sdiv_up_safe32(int32_t x, int32_t y) { return sdiv_safe32(x + y - 1, y); }-SCALAR_FUN_ATTR int64_t sdiv_up_safe64(int64_t x, int64_t y) { return sdiv_safe64(x + y - 1, y); }+SCALAR_FUN_ATTR int8_t sceil_div_safe8(int8_t x, int8_t y)     { return sdiv_safe8(x + y - 1, y); }+SCALAR_FUN_ATTR int16_t sceil_div_safe16(int16_t x, int16_t y) { return sdiv_safe16(x + y - 1, y); }+SCALAR_FUN_ATTR int32_t sceil_div_safe32(int32_t x, int32_t y) { return sdiv_safe32(x + y - 1, y); }+SCALAR_FUN_ATTR int64_t sceil_div_safe64(int64_t x, int64_t y) { return sdiv_safe64(x + y - 1, y); }  SCALAR_FUN_ATTR int8_t   smod_safe8(int8_t x, int8_t y)   { return y == 0 ? 0 : smod8(x, y); } SCALAR_FUN_ATTR int16_t smod_safe16(int16_t x, int16_t y) { return y == 0 ? 0 : smod16(x, y); }@@ -372,10 +372,10 @@ SCALAR_FUN_ATTR uint32_t udiv32(uint32_t x, uint32_t y) { return x / y; } SCALAR_FUN_ATTR uint64_t udiv64(uint64_t x, uint64_t y) { return x / y; } -SCALAR_FUN_ATTR uint8_t   udiv_up8(uint8_t x, uint8_t y)   { return (x + y - 1) / y; }-SCALAR_FUN_ATTR uint16_t udiv_up16(uint16_t x, uint16_t y) { return (x + y - 1) / y; }-SCALAR_FUN_ATTR uint32_t udiv_up32(uint32_t x, uint32_t y) { return (x + y - 1) / y; }-SCALAR_FUN_ATTR uint64_t udiv_up64(uint64_t x, uint64_t y) { return (x + y - 1) / y; }+SCALAR_FUN_ATTR uint8_t   uceil_div8(uint8_t x, uint8_t y)   { return (x + y - 1) / y; }+SCALAR_FUN_ATTR uint16_t uceil_div16(uint16_t x, uint16_t y) { return (x + y - 1) / y; }+SCALAR_FUN_ATTR uint32_t uceil_div32(uint32_t x, uint32_t y) { return (x + y - 1) / y; }+SCALAR_FUN_ATTR uint64_t uceil_div64(uint64_t x, uint64_t y) { return (x + y - 1) / y; }  SCALAR_FUN_ATTR uint8_t   umod8(uint8_t x, uint8_t y)   { return x % y; } SCALAR_FUN_ATTR uint16_t umod16(uint16_t x, uint16_t y) { return x % y; }@@ -387,10 +387,10 @@ SCALAR_FUN_ATTR uint32_t udiv_safe32(uint32_t x, uint32_t y) { return y == 0 ? 0 : x / y; } SCALAR_FUN_ATTR uint64_t udiv_safe64(uint64_t x, uint64_t y) { return y == 0 ? 0 : x / y; } -SCALAR_FUN_ATTR uint8_t   udiv_up_safe8(uint8_t x, uint8_t y)   { return y == 0 ? 0 : (x + y - 1) / y; }-SCALAR_FUN_ATTR uint16_t udiv_up_safe16(uint16_t x, uint16_t y) { return y == 0 ? 0 : (x + y - 1) / y; }-SCALAR_FUN_ATTR uint32_t udiv_up_safe32(uint32_t x, uint32_t y) { return y == 0 ? 0 : (x + y - 1) / y; }-SCALAR_FUN_ATTR uint64_t udiv_up_safe64(uint64_t x, uint64_t y) { return y == 0 ? 0 : (x + y - 1) / y; }+SCALAR_FUN_ATTR uint8_t   uceil_div_safe8(uint8_t x, uint8_t y)   { return y == 0 ? 0 : (x + y - 1) / y; }+SCALAR_FUN_ATTR uint16_t uceil_div_safe16(uint16_t x, uint16_t y) { return y == 0 ? 0 : (x + y - 1) / y; }+SCALAR_FUN_ATTR uint32_t uceil_div_safe32(uint32_t x, uint32_t y) { return y == 0 ? 0 : (x + y - 1) / y; }+SCALAR_FUN_ATTR uint64_t uceil_div_safe64(uint64_t x, uint64_t y) { return y == 0 ? 0 : (x + y - 1) / y; }  SCALAR_FUN_ATTR uint8_t   umod_safe8(uint8_t x, uint8_t y)   { return y == 0 ? 0 : x % y; } SCALAR_FUN_ATTR uint16_t umod_safe16(uint16_t x, uint16_t y) { return y == 0 ? 0 : x % y; }@@ -421,10 +421,10 @@   return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); } -SCALAR_FUN_ATTR int8_t   sdiv_up8(int8_t x, int8_t y)   { return sdiv8(x + y - 1, y); }-SCALAR_FUN_ATTR int16_t sdiv_up16(int16_t x, int16_t y) { return sdiv16(x + y - 1, y); }-SCALAR_FUN_ATTR int32_t sdiv_up32(int32_t x, int32_t y) { return sdiv32(x + y - 1, y); }-SCALAR_FUN_ATTR int64_t sdiv_up64(int64_t x, int64_t y) { return sdiv64(x + y - 1, y); }+SCALAR_FUN_ATTR int8_t   sceil_div8(int8_t x, int8_t y)   { return sdiv8(x + y - 1, y); }+SCALAR_FUN_ATTR int16_t sceil_div16(int16_t x, int16_t y) { return sdiv16(x + y - 1, y); }+SCALAR_FUN_ATTR int32_t sceil_div32(int32_t x, int32_t y) { return sdiv32(x + y - 1, y); }+SCALAR_FUN_ATTR int64_t sceil_div64(int64_t x, int64_t y) { return sdiv64(x + y - 1, y); }  SCALAR_FUN_ATTR int8_t smod8(int8_t x, int8_t y) {   int8_t r = x % y;@@ -451,10 +451,10 @@ SCALAR_FUN_ATTR int32_t sdiv_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : sdiv32(x, y); } SCALAR_FUN_ATTR int64_t sdiv_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : sdiv64(x, y); } -SCALAR_FUN_ATTR int8_t   sdiv_up_safe8(int8_t x, int8_t y)   { return sdiv_safe8(x + y - 1, y);}-SCALAR_FUN_ATTR int16_t sdiv_up_safe16(int16_t x, int16_t y) { return sdiv_safe16(x + y - 1, y); }-SCALAR_FUN_ATTR int32_t sdiv_up_safe32(int32_t x, int32_t y) { return sdiv_safe32(x + y - 1, y); }-SCALAR_FUN_ATTR int64_t sdiv_up_safe64(int64_t x, int64_t y) { return sdiv_safe64(x + y - 1, y); }+SCALAR_FUN_ATTR int8_t   sceil_div_safe8(int8_t x, int8_t y)   { return sdiv_safe8(x + y - 1, y);}+SCALAR_FUN_ATTR int16_t sceil_div_safe16(int16_t x, int16_t y) { return sdiv_safe16(x + y - 1, y); }+SCALAR_FUN_ATTR int32_t sceil_div_safe32(int32_t x, int32_t y) { return sdiv_safe32(x + y - 1, y); }+SCALAR_FUN_ATTR int64_t sceil_div_safe64(int64_t x, int64_t y) { return sdiv_safe64(x + y - 1, y); }  SCALAR_FUN_ATTR int8_t   smod_safe8(int8_t x, int8_t y)   { return y == 0 ? 0 : smod8(x, y); } SCALAR_FUN_ATTR int16_t smod_safe16(int16_t x, int16_t y) { return y == 0 ? 0 : smod16(x, y); }@@ -949,7 +949,7 @@ #endif  SCALAR_FUN_ATTR int8_t fptosi_f32_i8(float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < -0x1p7f || x >= 0x1p7f) {     return 0;   } else {     return (int8_t) x;@@ -957,7 +957,7 @@ }  SCALAR_FUN_ATTR int16_t fptosi_f32_i16(float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < -0x1p15f || x >= 0x1p15f) {     return 0;   } else {     return (int16_t) x;@@ -965,7 +965,7 @@ }  SCALAR_FUN_ATTR int32_t fptosi_f32_i32(float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < -0x1p31f || x >= 0x1p31f) {     return 0;   } else {     return (int32_t) x;@@ -973,42 +973,42 @@ }  SCALAR_FUN_ATTR int64_t fptosi_f32_i64(float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < -0x1p63f || x >= 0x1p63f) {     return 0;   } else {     return (int64_t) x;-  };+  } }  SCALAR_FUN_ATTR uint8_t fptoui_f32_i8(float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < 0x0p0f || x >= 0x1p8f) {     return 0;   } else {-    return (uint8_t) (int8_t) x;+    return (uint8_t) x;   } }  SCALAR_FUN_ATTR uint16_t fptoui_f32_i16(float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < 0x0p0f || x >= 0x1p16f) {     return 0;   } else {-    return (uint16_t) (int16_t) x;+    return (uint16_t) x;   } }  SCALAR_FUN_ATTR uint32_t fptoui_f32_i32(float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < 0x0p0f || x >= 0x1p32f) {     return 0;   } else {-    return (uint32_t) (int32_t) x;+    return (uint32_t) x;   } }  SCALAR_FUN_ATTR uint64_t fptoui_f32_i64(float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < 0x0p0f || x >= 0x1p64f) {     return 0;   } else {-    return (uint64_t) (int64_t) x;+    return (uint64_t) x;   } } @@ -1457,7 +1457,6 @@   return res; } -extern "C" unmasked uniform double erf(uniform double x); SCALAR_FUN_ATTR double futrts_erf64(double x) {   double res;   foreach_active (i) {@@ -1467,7 +1466,6 @@   return res; } -extern "C" unmasked uniform double erfc(uniform double x); SCALAR_FUN_ATTR double futrts_erfc64(double x) {   double res;   foreach_active (i) {@@ -1495,7 +1493,7 @@ SCALAR_FUN_ATTR bool futrts_isnan64(double x) { return isnan(x); }  SCALAR_FUN_ATTR int8_t fptosi_f64_i8(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p7 || x >= 0x1p7) {     return 0;   } else {     return (int8_t) x;@@ -1503,7 +1501,7 @@ }  SCALAR_FUN_ATTR int16_t fptosi_f64_i16(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p15 || x >= 0x1p15) {     return 0;   } else {     return (int16_t) x;@@ -1511,7 +1509,7 @@ }  SCALAR_FUN_ATTR int32_t fptosi_f64_i32(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p31 || x >= 0x1p31) {     return 0;   } else {     return (int32_t) x;@@ -1519,7 +1517,7 @@ }  SCALAR_FUN_ATTR int64_t fptosi_f64_i64(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p63 || x >= 0x1p63) {     return 0;   } else {     return (int64_t) x;@@ -1527,34 +1525,34 @@ }  SCALAR_FUN_ATTR uint8_t fptoui_f64_i8(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p8) {     return 0;   } else {-    return (uint8_t) (int8_t) x;+    return (uint8_t) x;   } }  SCALAR_FUN_ATTR uint16_t fptoui_f64_i16(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p16) {     return 0;   } else {-    return (uint16_t) (int16_t) x;+    return (uint16_t) x;   } }  SCALAR_FUN_ATTR uint32_t fptoui_f64_i32(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p32) {     return 0;   } else {-    return (uint32_t) (int32_t) x;+    return (uint32_t) x;   } }  SCALAR_FUN_ATTR uint64_t fptoui_f64_i64(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p64) {     return 0;   } else {-    return (uint64_t) (int64_t) x;+    return (uint64_t) x;   } } @@ -1749,7 +1747,7 @@ SCALAR_FUN_ATTR bool futrts_isinf64(double x) { return isinf(x); }  SCALAR_FUN_ATTR int8_t fptosi_f64_i8(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p7 || x >= 0x1p7) {     return 0;   } else {     return (int8_t) x;@@ -1757,7 +1755,7 @@ }  SCALAR_FUN_ATTR int16_t fptosi_f64_i16(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p15 || x >= 0x1p15) {     return 0;   } else {     return (int16_t) x;@@ -1765,7 +1763,7 @@ }  SCALAR_FUN_ATTR int32_t fptosi_f64_i32(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p31 || x >= 0x1p31) {     return 0;   } else {     return (int32_t) x;@@ -1773,7 +1771,7 @@ }  SCALAR_FUN_ATTR int64_t fptosi_f64_i64(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p63 || x >= 0x1p63) {     return 0;   } else {     return (int64_t) x;@@ -1781,34 +1779,34 @@ }  SCALAR_FUN_ATTR uint8_t fptoui_f64_i8(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p8) {     return 0;   } else {-    return (uint8_t) (int8_t) x;+    return (uint8_t) x;   } }  SCALAR_FUN_ATTR uint16_t fptoui_f64_i16(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p16) {     return 0;   } else {-    return (uint16_t) (int16_t) x;+    return (uint16_t) x;   } }  SCALAR_FUN_ATTR uint32_t fptoui_f64_i32(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p32) {     return 0;   } else {-    return (uint32_t) (int32_t) x;+    return (uint32_t) x;   } }  SCALAR_FUN_ATTR uint64_t fptoui_f64_i64(double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p64) {     return 0;   } else {-    return (uint64_t) (int64_t) x;+    return (uint64_t) x;   } }
rts/c/scalar_f16.h view
@@ -54,11 +54,11 @@ SCALAR_FUN_ATTR f16 uitofp_i16_f16(uint16_t x) { return (f16) x; } SCALAR_FUN_ATTR f16 uitofp_i32_f16(uint32_t x) { return (f16) x; } SCALAR_FUN_ATTR f16 uitofp_i64_f16(uint64_t x) { return (f16) x; }-SCALAR_FUN_ATTR int8_t fptosi_f16_i8(f16 x) { return (int8_t) (float) x; }+SCALAR_FUN_ATTR int8_t fptosi_f16_i8(f16 x) { return fptosi_f32_i8((float) x); } SCALAR_FUN_ATTR int16_t fptosi_f16_i16(f16 x) { return (int16_t) x; } SCALAR_FUN_ATTR int32_t fptosi_f16_i32(f16 x) { return (int32_t) x; } SCALAR_FUN_ATTR int64_t fptosi_f16_i64(f16 x) { return (int64_t) x; }-SCALAR_FUN_ATTR uint8_t fptoui_f16_i8(f16 x) { return (uint8_t) (float) x; }+SCALAR_FUN_ATTR uint8_t fptoui_f16_i8(f16 x) { return fptoui_f32_i8((float) x); } SCALAR_FUN_ATTR uint16_t fptoui_f16_i16(f16 x) { return (uint16_t) x; } SCALAR_FUN_ATTR uint32_t fptoui_f16_i32(f16 x) { return (uint32_t) x; } SCALAR_FUN_ATTR uint64_t fptoui_f16_i64(f16 x) { return (uint64_t) x; }
rts/c/server.h view
@@ -194,10 +194,12 @@   return &v->value.v_ptr; } +// Variables are kept in a doubly linked list. struct variable {-  // NULL name indicates free slot.  Name is owned by this struct.+  // Name is owned by this struct.   char *name;   struct value value;+  struct variable *prev, *next; };  typedef int (*entry_point_fn)(struct futhark_context*, void*, void**);@@ -208,9 +210,9 @@   const char** tuning_params;   const char** attrs;   const struct type *out_type;-  bool out_unique;+  bool out_fresh;   const struct type **in_types;-  bool *in_unique;+  bool *in_consumed; };  int entry_num_ins(struct entry_point *e) {@@ -232,16 +234,28 @@   struct futhark_prog prog;   struct futhark_context_config *cfg;   struct futhark_context *ctx;-  int variables_capacity;+  // Head of the list of variables; NULL when there are none.   struct variable *variables; }; +// Print the command-done marker, indicating that we are ready for+// more input.+void ok(void) {+  printf("%%%%%% OK\n");+  fflush(stdout);+}++// Print the failure marker.  Output is now an error message until the+// next ok().+void failure(void) {+  printf("%%%%%% FAILURE\n");+}+ struct variable* get_variable(struct server_state *s,                               const char *name) {-  for (int i = 0; i < s->variables_capacity; i++) {-    if (s->variables[i].name != NULL &&-        strcmp(s->variables[i].name, name) == 0) {-      return &s->variables[i];+  for (struct variable *v = s->variables; v != NULL; v = v->next) {+    if (strcmp(v->name, name) == 0) {+      return v;     }   } @@ -251,42 +265,37 @@ struct variable* create_variable(struct server_state *s,                                  const char *name,                                  const struct type *type) {-  int found = -1;-  for (int i = 0; i < s->variables_capacity; i++) {-    if (found == -1 && s->variables[i].name == NULL) {-      found = i;-    } else if (s->variables[i].name != NULL &&-               strcmp(s->variables[i].name, name) == 0) {-      return NULL;-    }+  if (get_variable(s, name) != NULL) {+    return NULL;   } -  if (found != -1) {-    // Found a free spot.-    s->variables[found].name = strdup(name);-    s->variables[found].value.type = type;-    return &s->variables[found];-  }+  struct variable *v = malloc(sizeof(struct variable));+  v->name = strdup(name);+  v->value.type = type;+  v->prev = NULL;+  v->next = s->variables; -  // Need to grow the buffer.-  found = s->variables_capacity;-  s->variables_capacity *= 2;-  s->variables = realloc(s->variables,-                         s->variables_capacity * sizeof(struct variable));+  if (s->variables != NULL) {+    s->variables->prev = v;+  }+  s->variables = v; -  s->variables[found].name = strdup(name);-  s->variables[found].value.type = type;+  return v;+} -  for (int i = found+1; i < s->variables_capacity; i++) {-    s->variables[i].name = NULL;+void drop_variable(struct server_state *s, struct variable *v) {+  if (v->prev != NULL) {+    v->prev->next = v->next;+  } else {+    s->variables = v->next;   } -  return &s->variables[found];-}+  if (v->next != NULL) {+    v->next->prev = v->prev;+  } -void drop_variable(struct variable *v) {   free(v->name);-  v->name = NULL;+  free(v); }  int arg_exists(const char *args[], int i) {@@ -300,6 +309,8 @@   return args[i]; } +// Look up a type by name. If there is no such type, a failure is reported and+// NULL is returned. const struct type* get_type(struct server_state *s, const char *name) {   for (int i = 0; s->prog.types[i]; i++) {     if (strcmp(s->prog.types[i]->name, name) == 0) {@@ -307,7 +318,8 @@     }   } -  futhark_panic(1, "Unknown type %s\n", name);+  failure();+  printf("Unknown type: %s\n", name);   return NULL; } @@ -321,19 +333,6 @@   return NULL; } -// Print the command-done marker, indicating that we are ready for-// more input.-void ok(void) {-  printf("%%%%%% OK\n");-  fflush(stdout);-}--// Print the failure marker.  Output is now an error message until the-// next ok().-void failure(void) {-  printf("%%%%%% FAILURE\n");-}- void error_check(struct server_state *s, int err) {   if (err != 0) {     failure();@@ -401,7 +400,7 @@     const char *out_name = get_arg(args, 1);     struct variable *v = get_variable(s, out_name);     if (v) {-      drop_variable(v);+      drop_variable(s, v);     }   } }@@ -423,6 +422,10 @@     const char *type = get_arg(args, i+1);      const struct type *t = get_type(s, type);+    if (t == NULL) {+      bad = 1;+      break;+    }     struct variable *v = create_variable(s, vname, t);      if (v == NULL) {@@ -439,7 +442,7 @@       printf("Failed to restore variable %s.\n"              "Possibly malformed data in %s (errno: %s)\n",              vname, fname, strerror(errno));-      drop_variable(v);+      drop_variable(s, v);       break;     }   }@@ -498,7 +501,7 @@      int err = t->free(t->aux, s->ctx, value_ptr(&v->value));     error_check(s, err);-    drop_variable(v);+    drop_variable(s, v);   } } @@ -536,7 +539,7 @@    int num_ins = entry_num_ins(e);   for (int i = 0; i < num_ins; i++) {-    if (e->in_unique[i]) {+    if (e->in_consumed[i]) {       putchar('*');     }     puts(e->in_types[i]->name);@@ -553,7 +556,7 @@     return;   } -  if (e->out_unique) {+  if (e->out_fresh) {     putchar('*');   }   puts(e->out_type->name);@@ -562,12 +565,13 @@ void cmd_clear(struct server_state *s, const char *args[]) {   (void)args;   int err = 0;-  for (int i = 0; i < s->variables_capacity; i++) {-    struct variable *v = &s->variables[i];-    if (v->name != NULL) {-      err |= v->value.type->free(v->value.type->aux, s->ctx, value_ptr(&v->value));-      drop_variable(v);-    }+  struct variable *v = s->variables;+  while (v != NULL) {+    // Dropping v frees it, so remember the successor first.+    struct variable *next = v->next;+    err |= v->value.type->free(v->value.type->aux, s->ctx, value_ptr(&v->value));+    drop_variable(s, v);+    v = next;   }   err |= futhark_context_clear_caches(s->ctx);   error_check(s, err);@@ -665,6 +669,9 @@ 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);+  if (t == NULL) {+    return;+  }    switch (t->kind) {     case PRIMITIVE: printf("primitive\n"); return;@@ -716,6 +723,9 @@ 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 == NULL) {+    return;+  }    if (t->kind != ARRAY) {     failure();@@ -731,6 +741,9 @@ void cmd_rank(struct server_state *s, const char *args[]) {   const char *type = get_arg(args, 0);   const struct type *t = get_type(s, type);+  if (t == NULL) {+    return;+  }    if (t->kind != ARRAY) {     failure();@@ -746,6 +759,9 @@   const char *to_name = get_arg(args, 0);   const char *type_name = get_arg(args, 1);   const struct type *type = get_type(s, type_name);+  if (type == NULL) {+    return;+  }   struct variable *to = create_variable(s, to_name, type);    if (to == NULL) {@@ -852,9 +868,13 @@     }   } -  a->new(s->ctx, value_ptr(&to->value), a->info != NULL ? (void*)values : value_ptrs, dims);+  // The copy from 'values' may be asynchronous, so we must synchronise+  // before freeing it.+  int err = a->new(s->ctx, value_ptr(&to->value), a->info != NULL ? (void*)values : value_ptrs, dims);+  err |= futhark_context_sync(s->ctx);   free(value_ptrs);   free(values);+  error_check(s, err); }  void cmd_set(struct server_state *s, const char *args[]) {@@ -918,7 +938,9 @@     indices[i] = idx;   } -  a->set(s->ctx, arr->value.value.v_ptr, value_ptr(&val->value), indices);+  int err = a->set(s->ctx, arr->value.value.v_ptr, value_ptr(&val->value), indices);+  err |= futhark_context_sync(s->ctx);+  error_check(s, err); }  void cmd_index(struct server_state *s, const char *args[]) {@@ -984,6 +1006,9 @@   const char *to_name = get_arg(args, 0);   const char *type_name = get_arg(args, 1);   const struct type *type = get_type(s, type_name);+  if (type == NULL) {+    return;+  }    if (type->kind != ARRAY) {     failure();@@ -1042,7 +1067,7 @@   err |= futhark_context_sync(s->ctx);   error_check(s, err);   if (err != 0) {-    drop_variable(to);+    drop_variable(s, to);   } } @@ -1088,7 +1113,7 @@       failure();       printf("Variable already exists: %s\n", to_name);       for (int j = 0; j < i; j++) {-        drop_variable(outs[j]);+        drop_variable(s, outs[j]);       }       return;     }@@ -1103,7 +1128,7 @@   error_check(s, err);   if (err != 0) {     for (int i = 0; i < num_args; i++) {-      drop_variable(outs[i]);+      drop_variable(s, outs[i]);     }   } }@@ -1111,6 +1136,9 @@ 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);+  if (t == NULL) {+    return;+  }    if (t->kind != RECORD) {     failure();@@ -1129,6 +1157,9 @@ 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 == NULL) {+    return;+  }    if (t->kind != SUM) {     failure();@@ -1224,6 +1255,9 @@   const char *to_name = get_arg(args, 0);   const char *type_name = get_arg(args, 1);   const struct type *type = get_type(s, type_name);+  if (type == NULL) {+    return;+  }   struct variable *to = create_variable(s, to_name, type);    if (to == NULL) {@@ -1280,6 +1314,9 @@   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);+  if (type == NULL) {+    return;+  }   struct variable *to = create_variable(s, to_name, type);    if (to == NULL) {@@ -1448,7 +1485,7 @@ }  void process_line(struct server_state *s, char *line) {-  int max_num_tokens = 1000;+  int max_num_tokens = 10000;   const char* tokens[max_num_tokens];   int num_tokens = 0; @@ -1547,23 +1584,19 @@   struct server_state s = {     .cfg = cfg,     .ctx = ctx,-    .variables_capacity = 100,+    .variables = NULL,     .prog = *prog   }; -  s.variables = malloc(s.variables_capacity * sizeof(struct variable));--  for (int i = 0; i < s.variables_capacity; i++) {-    s.variables[i].name = NULL;-  }-   ok();   while ((linelen = getline(&line, &buflen, stdin)) > 0) {     process_line(&s, line);     ok();   } -  free(s.variables);+  while (s.variables != NULL) {+    drop_variable(&s, s.variables);+  }   free(line); }
rts/c/uniform.h view
@@ -69,19 +69,19 @@   return x / y; } -static inline uniform uint8_t udiv_up8(uniform uint8_t x, uniform uint8_t y) {+static inline uniform uint8_t uceil_div8(uniform uint8_t x, uniform uint8_t y) {   return (x + y - 1) / y; } -static inline uniform uint16_t udiv_up16(uniform uint16_t x, uniform uint16_t y) {+static inline uniform uint16_t uceil_div16(uniform uint16_t x, uniform uint16_t y) {   return (x + y - 1) / y; } -static inline uniform uint32_t udiv_up32(uniform uint32_t x, uniform uint32_t y) {+static inline uniform uint32_t uceil_div32(uniform uint32_t x, uniform uint32_t y) {   return (x + y - 1) / y; } -static inline uniform uint64_t udiv_up64(uniform uint64_t x, uniform uint64_t y) {+static inline uniform uint64_t uceil_div64(uniform uint64_t x, uniform uint64_t y) {   return (x + y - 1) / y; } @@ -117,19 +117,19 @@   return y == 0 ? 0 : x / y; } -static inline uniform uint8_t udiv_up_safe8(uniform uint8_t x, uniform uint8_t y) {+static inline uniform uint8_t uceil_div_safe8(uniform uint8_t x, uniform uint8_t y) {   return y == 0 ? 0 : (x + y - 1) / y; } -static inline uniform uint16_t udiv_up_safe16(uniform uint16_t x, uniform uint16_t y) {+static inline uniform uint16_t uceil_div_safe16(uniform uint16_t x, uniform uint16_t y) {   return y == 0 ? 0 : (x + y - 1) / y; } -static inline uniform uint32_t udiv_up_safe32(uniform uint32_t x, uniform uint32_t y) {+static inline uniform uint32_t uceil_div_safe32(uniform uint32_t x, uniform uint32_t y) {   return y == 0 ? 0 : (x + y - 1) / y; } -static inline uniform uint64_t udiv_up_safe64(uniform uint64_t x, uniform uint64_t y) {+static inline uniform uint64_t uceil_div_safe64(uniform uint64_t x, uniform uint64_t y) {   return y == 0 ? 0 : (x + y - 1) / y; } @@ -177,19 +177,19 @@   return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); } -static inline uniform int8_t sdiv_up8(uniform int8_t x, uniform int8_t y) {+static inline uniform int8_t sceil_div8(uniform int8_t x, uniform int8_t y) {   return sdiv8(x + y - 1, y); } -static inline uniform int16_t sdiv_up16(uniform int16_t x, uniform int16_t y) {+static inline uniform int16_t sceil_div16(uniform int16_t x, uniform int16_t y) {   return sdiv16(x + y - 1, y); } -static inline uniform int32_t sdiv_up32(uniform int32_t x, uniform int32_t y) {+static inline uniform int32_t sceil_div32(uniform int32_t x, uniform int32_t y) {   return sdiv32(x + y - 1, y); } -static inline uniform int64_t sdiv_up64(uniform int64_t x, uniform int64_t y) {+static inline uniform int64_t sceil_div64(uniform int64_t x, uniform int64_t y) {   return sdiv64(x + y - 1, y); } @@ -233,19 +233,19 @@   return y == 0 ? 0 : sdiv64(x, y); } -static inline uniform int8_t sdiv_up_safe8(uniform int8_t x, uniform int8_t y) {+static inline uniform int8_t sceil_div_safe8(uniform int8_t x, uniform int8_t y) {   return sdiv_safe8(x + y - 1, y); } -static inline uniform int16_t sdiv_up_safe16(uniform int16_t x, uniform int16_t y) {+static inline uniform int16_t sceil_div_safe16(uniform int16_t x, uniform int16_t y) {   return sdiv_safe16(x + y - 1, y); } -static inline uniform int32_t sdiv_up_safe32(uniform int32_t x, uniform int32_t y) {+static inline uniform int32_t sceil_div_safe32(uniform int32_t x, uniform int32_t y) {   return sdiv_safe32(x + y - 1, y); } -static inline uniform int64_t sdiv_up_safe64(uniform int64_t x, uniform int64_t y) {+static inline uniform int64_t sceil_div_safe64(uniform int64_t x, uniform int64_t y) {   return sdiv_safe64(x + y - 1, y); } @@ -854,7 +854,7 @@   static inline uniform int8_t fptosi_f32_i8(uniform float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < -0x1p7f || x >= 0x1p7f) {     return 0;   } else {     return (uniform int8_t) x;@@ -862,7 +862,7 @@ }  static inline uniform int16_t fptosi_f32_i16(uniform float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < -0x1p15f || x >= 0x1p15f) {     return 0;   } else {     return (uniform int16_t) x;@@ -870,7 +870,7 @@ }  static inline uniform int32_t fptosi_f32_i32(uniform float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < -0x1p31f || x >= 0x1p31f) {     return 0;   } else {     return (uniform int32_t) x;@@ -878,46 +878,45 @@ }  static inline uniform int64_t fptosi_f32_i64(uniform float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < -0x1p63f || x >= 0x1p63f) {     return 0;   } else {     return (uniform int64_t) x;-  };+  } }  static inline uniform uint8_t fptoui_f32_i8(uniform float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < 0x0p0f || x >= 0x1p8f) {     return 0;   } else {-    return (uniform uint8_t) (uniform int8_t) x;+    return (uniform uint8_t) x;   } }  static inline uniform uint16_t fptoui_f32_i16(uniform float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < 0x0p0f || x >= 0x1p16f) {     return 0;   } else {-    return (uniform uint16_t) (uniform int16_t) x;+    return (uniform uint16_t) x;   } }  static inline uniform uint32_t fptoui_f32_i32(uniform float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < 0x0p0f || x >= 0x1p32f) {     return 0;   } else {-    return (uniform uint32_t) (uniform int32_t) x;+    return (uniform uint32_t) x;   } }  static inline uniform uint64_t fptoui_f32_i64(uniform float x) {-  if (futrts_isnan32(x) || futrts_isinf32(x)) {+  if (futrts_isnan32(x) || x < 0x0p0f || x >= 0x1p64f) {     return 0;   } else {-    return (uniform uint64_t) (uniform int64_t) x;+    return (uniform uint64_t) x;   } } - static inline uniform float futrts_log32(uniform float x) {   return futrts_isfinite32(x) || (futrts_isinf32(x) && x < 0)? log(x) : x; }@@ -1288,12 +1287,10 @@   return lgamma(x); } -extern "C" unmasked uniform double erf(uniform double); static inline uniform double futrts_erf64(uniform double x) {   return erf(x); } -extern "C" unmasked uniform double erfc(uniform double); static inline uniform double futrts_erfc64(uniform double x) {   return erfc(x); }@@ -1319,7 +1316,7 @@ }  static inline uniform int8_t fptosi_f64_i8(uniform double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p7 || x >= 0x1p7) {     return 0;   } else {     return (uniform int8_t) x;@@ -1327,7 +1324,7 @@ }  static inline uniform int16_t fptosi_f64_i16(uniform double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p15 || x >= 0x1p15) {     return 0;   } else {     return (uniform int16_t) x;@@ -1335,7 +1332,7 @@ }  static inline uniform int32_t fptosi_f64_i32(uniform double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p31 || x >= 0x1p31) {     return 0;   } else {     return (uniform int32_t) x;@@ -1343,7 +1340,7 @@ }  static inline uniform int64_t fptosi_f64_i64(uniform double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < -0x1p63 || x >= 0x1p63) {     return 0;   } else {     return (uniform int64_t) x;@@ -1351,34 +1348,34 @@ }  static inline uniform uint8_t fptoui_f64_i8(uniform double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p8) {     return 0;   } else {-    return (uniform uint8_t) (uniform int8_t) x;+    return (uniform uint8_t) x;   } }  static inline uniform uint16_t fptoui_f64_i16(uniform double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p16) {     return 0;   } else {-    return (uniform uint16_t) (uniform int16_t) x;+    return (uniform uint16_t) x;   } }  static inline uniform uint32_t fptoui_f64_i32(uniform double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p32) {     return 0;   } else {-    return (uniform uint32_t) (uniform int32_t) x;+    return (uniform uint32_t) x;   } }  static inline uniform uint64_t fptoui_f64_i64(uniform double x) {-  if (futrts_isnan64(x) || futrts_isinf64(x)) {+  if (futrts_isnan64(x) || x < 0x0p0 || x >= 0x1p64) {     return 0;   } else {-    return (uniform uint64_t) (uniform int64_t) x;+    return (uniform uint64_t) x;   } } @@ -1502,35 +1499,67 @@ }  static inline uniform int8_t fptosi_f16_i8(uniform f16 x) {-  return (uniform int8_t) (uniform float) x;+  if (futrts_isnan16(x) || x < -0x1p7 || x >= 0x1p7) {+    return 0;+  } else {+    return (uniform int8_t) x;+  } }  static inline uniform int16_t fptosi_f16_i16(uniform f16 x) {-  return (uniform int16_t) x;+  if (futrts_isnan16(x) || x < -0x1p15 || x >= 0x1p15) {+    return 0;+  } else {+    return (uniform int16_t) x;+  } }  static inline uniform int32_t fptosi_f16_i32(uniform f16 x) {-  return (uniform int32_t) x;+  if (futrts_isnan16(x) || x < -0x1p31 || x >= 0x1p31) {+    return 0;+  } else {+    return (uniform int32_t) x;+  } }  static inline uniform int64_t fptosi_f16_i64(uniform f16 x) {-  return (uniform int64_t) x;+  if (futrts_isnan16(x) || x < -0x1p63 || x >= 0x1p63) {+    return 0;+  } else {+    return (uniform int64_t) x;+  } }  static inline uniform uint8_t fptoui_f16_i8(uniform f16 x) {-  return (uniform uint8_t) (uniform float) x;+  if (futrts_isnan16(x) || x < 0x0p0 || x >= 0x1p8) {+    return 0;+  } else {+    return (uniform uint8_t) x;+  } }  static inline uniform uint16_t fptoui_f16_i16(uniform f16 x) {-  return (uniform uint16_t) x;+  if (futrts_isnan16(x) || x < 0x0p0 || x >= 0x1p16) {+    return 0;+  } else {+    return (uniform uint16_t) x;+  } }  static inline uniform uint32_t fptoui_f16_i32(uniform f16 x) {-  return (uniform uint32_t) x;+  if (futrts_isnan16(x) || x < 0x0p0 || x >= 0x1p32) {+    return 0;+  } else {+    return (uniform uint32_t) x;+  } }  static inline uniform uint64_t fptoui_f16_i64(uniform f16 x) {-  return (uniform uint64_t) x;+  if (futrts_isnan16(x) || x < 0x0p0 || x >= 0x1p64) {+    return 0;+  } else {+    return (uniform uint64_t) x;+  } }  static inline uniform f16 fabs16(uniform f16 x) {
rts/c/values.h view
@@ -395,36 +395,36 @@   } } -static int write_str_i8(FILE *out, const int8_t *src) {-  return fprintf(out, "%hhdi8", *src);+static int write_str_i8(FILE *out, const void *src) {+  return fprintf(out, "%hhdi8", *(const int8_t*)src); } -static int write_str_u8(FILE *out, const uint8_t *src) {-  return fprintf(out, "%hhuu8", *src);+static int write_str_u8(FILE *out, const void *src) {+  return fprintf(out, "%hhuu8", *(const uint8_t*)src); } -static int write_str_i16(FILE *out, const int16_t *src) {-  return fprintf(out, "%hdi16", *src);+static int write_str_i16(FILE *out, const void *src) {+  return fprintf(out, "%hdi16", *(const int16_t*)src); } -static int write_str_u16(FILE *out, const uint16_t *src) {-  return fprintf(out, "%huu16", *src);+static int write_str_u16(FILE *out, const void *src) {+  return fprintf(out, "%huu16", *(const uint16_t*)src); }  static int write_str_i32(FILE *out, const int32_t *src) {-  return fprintf(out, "%di32", *src);+  return fprintf(out, "%di32", *(const int32_t*)src); } -static int write_str_u32(FILE *out, const uint32_t *src) {-  return fprintf(out, "%uu32", *src);+static int write_str_u32(FILE *out, const void *src) {+  return fprintf(out, "%uu32", *(const uint32_t*)src); } -static int write_str_i64(FILE *out, const int64_t *src) {-  return fprintf(out, "%"PRIi64"i64", *src);+static int write_str_i64(FILE *out, const void *src) {+  return fprintf(out, "%"PRIi64"i64", *(const int64_t*)src); } -static int write_str_u64(FILE *out, const uint64_t *src) {-  return fprintf(out, "%"PRIu64"u64", *src);+static int write_str_u64(FILE *out, const void *src) {+  return fprintf(out, "%"PRIu64"u64", *(const uint64_t*)src); }  // FLT_DECIMAL_DIG and DBL_DECIMAL_DIG are defined in C11.@@ -445,8 +445,8 @@   #endif #endif -static int write_str_f16(FILE *out, const uint16_t *src) {-  float x = halfbits2float(*src);+static int write_str_f16(FILE *out, const void *src) {+  float x = halfbits2float(*(const uint16_t*)src);   if (isnan(x)) {     return fprintf(out, "f16.nan");   } else if (isinf(x) && x >= 0) {@@ -458,8 +458,8 @@   } } -static int write_str_f32(FILE *out, const float *src) {-  float x = *src;+static int write_str_f32(FILE *out, const void *src) {+  float x = *(const float*)src;   if (isnan(x)) {     return fprintf(out, "f32.nan");   } else if (isinf(x) && x >= 0) {@@ -471,8 +471,8 @@   } } -static int write_str_f64(FILE *out, const double *src) {-  double x = *src;+static int write_str_f64(FILE *out, const void *src) {+  double x = *(const double*)src;   if (isnan(x)) {     return fprintf(out, "f64.nan");   } else if (isinf(x) && x >= 0) {
rts/javascript/server.js view
@@ -1,11 +1,43 @@ // Start of server.js +// The server is implemented directly on top of the C API exported by the+// WebAssembly module, much like the C server.  The manifest describes the+// types and entry points, and names the C functions that operate on them.+//+// A variable is a pair of a type name and a value.  A value of primitive type+// is a JavaScript number, or a BigInt for 64-bit integers.  Booleans are 0 or+// 1, and f16 values are their bit patterns.  A value of any other type is a+// pointer to the C object.++var serverPrimtypes = {+  'i8':   { size: 1, get: (dv, p) => dv.getInt8(p),           set: (dv, p, x) => dv.setInt8(p, x) },+  'i16':  { size: 2, get: (dv, p) => dv.getInt16(p, true),    set: (dv, p, x) => dv.setInt16(p, x, true) },+  'i32':  { size: 4, get: (dv, p) => dv.getInt32(p, true),    set: (dv, p, x) => dv.setInt32(p, x, true) },+  'i64':  { size: 8, get: (dv, p) => dv.getBigInt64(p, true), set: (dv, p, x) => dv.setBigInt64(p, x, true) },+  'u8':   { size: 1, get: (dv, p) => dv.getUint8(p),          set: (dv, p, x) => dv.setUint8(p, x) },+  'u16':  { size: 2, get: (dv, p) => dv.getUint16(p, true),   set: (dv, p, x) => dv.setUint16(p, x, true) },+  'u32':  { size: 4, get: (dv, p) => dv.getUint32(p, true),   set: (dv, p, x) => dv.setUint32(p, x, true) },+  'u64':  { size: 8, get: (dv, p) => dv.getBigUint64(p, true), set: (dv, p, x) => dv.setBigUint64(p, x, true) },+  'f16':  { size: 2, get: (dv, p) => dv.getUint16(p, true),   set: (dv, p, x) => dv.setUint16(p, x, true) },+  'f32':  { size: 4, get: (dv, p) => dv.getFloat32(p, true),  set: (dv, p, x) => dv.setFloat32(p, x, true) },+  'f64':  { size: 8, get: (dv, p) => dv.getFloat64(p, true),  set: (dv, p, x) => dv.setFloat64(p, x, true) },+  'bool': { size: 1, get: (dv, p) => dv.getUint8(p),          set: (dv, p, x) => dv.setUint8(p, x ? 1 : 0) }+};++// Pointers and size_t are 32 bits in WebAssembly.+var serverPointer = {+  size: 4,+  get: (dv, p) => dv.getUint32(p, true),+  set: (dv, p, x) => dv.setUint32(p, x, true)+};+ class Server { -  constructor(ctx) {+  constructor(ctx, manifest) {     this.ctx = ctx;+    this.wasm = ctx.wasm;+    this.manifest = manifest;     this._vars = {};-    this._types = {};   }    _get_arg(args, i) {@@ -17,10 +49,10 @@   }    _get_entry_point(entry) {-    if (entry in this.ctx.get_entry_points()) {-      return this.ctx.get_entry_points()[entry];+    if (entry in this.manifest.entry_points) {+      return this.manifest.entry_points[entry];     } else {-      throw "Unkown entry point: " + entry;+      throw "Unknown entry point: " + entry;     }   } @@ -30,14 +62,10 @@     }   } -  _set_var(vname, v, t) {-    this._vars[vname] = v;-    this._types[vname] = t;-  }--  _get_type(vname) {-    this._check_var(vname);-    return this._types[vname];+  _check_new_var(vname) {+    if (vname in this._vars) {+      throw 'Variable already exists: ' + vname;+    }   }    _get_var(vname) {@@ -45,186 +73,352 @@     return this._vars[vname];   } -  _cmd_inputs(args) {-    var entry = this._get_arg(args, 0);-    var inputs = this._get_entry_point(entry)[1];-    for (var i = 0; i < inputs.length; i++) {-      console.log(inputs[i]);+  _get_typed_var(vname, tname) {+    var v = this._get_var(vname);+    if (v.type !== tname) {+      throw "Variable " + vname + " has type " + v.type + ", expected " + tname;     }+    return v.value;   } -  _cmd_output(args) {-    var entry = this._get_arg(args, 0);-    console.log(this._get_entry_point(entry)[2]);+  _set_var(vname, tname, value) {+    this._vars[vname] = { type: tname, value: value };   } -  _cmd_dummy(args) {-    // pass+  _parse_ints(args, n) {+    if (args.length != n) {+      throw n + " integers expected but " + args.length + " provided.";+    }+    return args.map((x) => {+      if (!/^[0-9]+$/.test(x)) {+        throw "Invalid integer: " + x;+      }+      return BigInt(x);+    });   } -  _cmd_free(args) {-    for (var i = 0; i < args.length; i++) {-      var vname = args[i];-      this._check_var(vname);-      delete this._vars[vname];+  // Calling into the C API.++  _c(fname, ...args) {+    return this.wasm['_' + fname](this.ctx.ctx, ...args);+  }++  _check(err) {+    if (err != 0) {+      throw this.ctx.get_error();     }   } -  _cmd_rename(args) {-    var oldname = this._get_arg(args, 0)-    var newname = this._get_arg(args, 1)-    if (newname in this._vars) {-      throw "Variable already exists: " + newname;+  _sync() {+    this._check(this.wasm._futhark_context_sync(this.ctx.ctx));+  }++  _malloc(n) {+    // Avoid zero-sized allocations, which may return NULL.+    return this.wasm._malloc(Math.max(n, 1));+  }++  _view() {+    // Must be recreated on every use, as the memory may have grown.+    return new DataView(this.wasm.HEAPU8.buffer);+  }++  _repr(tname) {+    return tname in serverPrimtypes ? serverPrimtypes[tname] : serverPointer;+  }++  _sizeof(tname) {+    return this._repr(tname).size;+  }++  _load(tname, p) {+    return this._repr(tname).get(this._view(), p);+  }++  _poke(tname, p, x) {+    this._repr(tname).set(this._view(), p, x);+  }++  // Call 'f' with a pointer to space for one value of the given type, and+  // return the value that it stores there.+  _with_out(tname, f) {+    var p = this._malloc(this._sizeof(tname));+    try {+      f(p);+      return this._load(tname, p);+    } finally {+      this.wasm._free(p);     }-    this._vars[newname] = this._vars[oldname];-    this._types[newname] = this._types[oldname];-    delete this._vars[oldname];-    delete this._types[oldname];   } -  _cmd_types(args) {-    var types = this.ctx.get_types();-    for (var t in types) {-      console.log(t);+  _bytes(p, n) {+    return Buffer.from(this.wasm.HEAPU8.slice(p, p + n));+  }++  // Types.++  _type(tname) {+    if (tname in this.manifest.types) {+      return this.manifest.types[tname];+    } else if (tname in serverPrimtypes) {+      return null;+    } else {+      throw "Unknown type: " + tname;     }   } -  _cmd_fields(args) {-    var type_name = this._get_arg(args, 0);-    var types = this.ctx.get_types();-    var type_info = types[type_name];-    if (!type_info || type_info[0] !== "record") {-      throw "Not a record type: " + type_name;+  _kind(tname) {+    var t = this._type(tname);+    if (t === null) {+      return "primitive";+    } else if (t.kind == "array" || t.opaque_array || t.record_array) {+      return "array";+    } else if (t.record) {+      return "record";+    } else if (t.sum) {+      return "sum";+    } else {+      return "opaque";     }-    var fields = type_info[1];-    for (var i = 0; i < fields.length; i++) {-      console.log(fields[i][0] + " " + fields[i][1]);+  }++  // Information about an array type.  Transparent arrays have 'ops', and+  // opaque arrays have the functions directly.+  _array_type(tname) {+    if (this._kind(tname) != "array") {+      throw "Not an array type";     }+    var t = this._type(tname);+    if (t.kind == "array") {+      return { rank: t.rank, elemtype: t.elemtype, ops: t.ops };+    } else {+      return t.opaque_array || t.record_array;+    }   } -  _cmd_project(args) {-    var to_name = this._get_arg(args, 0);-    var from_name = this._get_arg(args, 1);-    var field_name = this._get_arg(args, 2);+  _record_type(tname) {+    if (this._kind(tname) != "record") {+      throw "Not a record type";+    }+    return this._type(tname).record;+  } -    if (to_name in this._vars) {-      throw "Variable already exists: " + to_name;+  _sum_type(tname) {+    if (this._kind(tname) != "sum") {+      throw "Not a sum type";     }+    return this._type(tname).sum;+  } -    var from_val = this._get_var(from_name);-    var from_type = this._get_type(from_name);+  _free_value(tname, value) {+    var t = this._type(tname);+    if (t !== null) {+      this._check(this._c(t.ops.free, value));+    }+  } -    var types = this.ctx.get_types();-    var type_info = types[from_type];-    if (!type_info || type_info[0] !== "record") {-      throw "Not a record type: " + from_type;+  _shape(a, arr) {+    var fshape = a.ops ? a.ops.shape : a.shape;+    var p = this._c(fshape, arr);+    var shape = [];+    for (var i = 0; i < a.rank; i++) {+      shape.push(this._load('i64', p + i * 8));     }+    return shape;+  } -    var fields = type_info[1];-    var field_info = null;-    for (var i = 0; i < fields.length; i++) {-      if (fields[i][0] === field_name) {-        field_info = fields[i];-        break;+  _check_bounds(shape, is) {+    for (var i = 0; i < shape.length; i++) {+      if (is[i] >= shape[i]) {+        throw "Index " + is.join(",") + " out of bounds for shape " + shape.join(",");       }     }+  } -    if (field_info === null) {-      throw "No such field: " + field_name;+  // Values.++  _restore_value(reader, tname) {+    var t = this._type(tname);+    if (t === null) {+      return read_value(tname, reader);+    } else if (t.kind == "array") {+      var [shape, data] = read_value(tname, reader);+      var bytes = new Uint8Array(data.buffer, data.byteOffset, data.byteLength);+      var p = this._malloc(bytes.length);+      try {+        this.wasm.HEAPU8.set(bytes, p);+        var arr = this._c(t.ops.new, p, ...shape);+        if (arr == 0) {+          throw this.ctx.get_error();+        }+        this._sync();+        return arr;+      } finally {+        this.wasm._free(p);+      }+    } else {+      // As in the C server, we pass all the remaining input to the restore+      // function, then ask how large the object is in serialised form.+      var buff = reader.get_buff();+      var p = this._malloc(buff.length);+      try {+        this.wasm.HEAPU8.set(buff, p);+        var obj = this._c(t.ops.restore, p);+        if (obj == 0) {+          throw this.ctx.get_error();+        }+      } finally {+        this.wasm._free(p);+      }+      var n = this._with_out('size', (np) => {+        this._check(this._c(t.ops.store, obj, 0, np));+      });+      reader.buff = buff.slice(n);+      return obj;     }+  } -    var field_type = field_info[1];-    var project_fn = field_info[2];-    var result = this.ctx[project_fn](from_val);-    this._set_var(to_name, result, field_type);+  _store_value(tname, value) {+    var t = this._type(tname);+    if (t === null) {+      var p = this._malloc(this._sizeof(tname));+      try {+        this._poke(tname, p, value);+        return binary_value(tname, [], this._bytes(p, this._sizeof(tname)));+      } finally {+        this.wasm._free(p);+      }+    } else if (t.kind == "array") {+      var shape = this._shape(this._array_type(tname), value);+      var n = shape.reduce((x, y) => x * y, 1n) * BigInt(this._sizeof(t.elemtype));+      var p = this._malloc(Number(n));+      try {+        this._check(this._c(t.ops.values, value, p));+        this._sync();+        return binary_value(t.elemtype, shape, this._bytes(p, Number(n)));+      } finally {+        this.wasm._free(p);+      }+    } else {+      var pp = this._malloc(serverPointer.size * 2);+      var np = pp + serverPointer.size;+      try {+        this._poke('ptr', pp, 0);+        this._check(this._c(t.ops.store, value, pp, np));+        this._sync();+        var p = this._load('ptr', pp);+        var bytes = this._bytes(p, this._load('size', np));+        this.wasm._free(p);+        return bytes;+      } finally {+        this.wasm._free(pp);+      }+    }   } -  _cmd_call(args) {+  // Commands.++  _cmd_inputs(args) {     var entry = this._get_entry_point(this._get_arg(args, 0));-    var num_ins = entry[1].length;-    var num_outs = 1;-    var expected_len = 1 + num_outs + num_ins+    for (var input of entry.inputs) {+      console.log((input.consumed ? "*" : "") + input.type);+    }+  } -    if (args.length != expected_len) {-      throw "Invalid argument count, expected " + expected_len+  _cmd_output(args) {+    var entry = this._get_entry_point(this._get_arg(args, 0));+    console.log((entry.output.fresh ? "*" : "") + entry.output.type);+  }++  _cmd_dummy(args) {+    // pass+  }++  _cmd_free(args) {+    for (var vname of args) {+      var v = this._get_var(vname);+      this._free_value(v.type, v.value);+      delete this._vars[vname];     }+  } -    var out_vname = args[1];-    if (out_vname in this._vars) {-      throw "Variable already exists: " + out_vname;+  _cmd_rename(args) {+    var oldname = this._get_arg(args, 0);+    var newname = this._get_arg(args, 1);+    var v = this._get_var(oldname);+    this._check_new_var(newname);+    this._vars[newname] = v;+    delete this._vars[oldname];+  }++  _cmd_types(args) {+    for (var t in serverPrimtypes) {+      console.log(t);     }-    var in_vnames = args.slice(1+num_outs);-    var ins = [];-    for (var i = 0; i < in_vnames.length; i++) {-      ins.push(this._get_var(in_vnames[i]));+    for (var t in this.manifest.types) {+      console.log(t);     }-    // Call entry point function from string name-    var bef = performance.now()*1000;-    var vals = this.ctx[entry[0]].apply(this.ctx, ins);-    var aft = performance.now()*1000;-    this._set_var(out_vname, vals, entry[2]);-    console.log("runtime: " + Math.round(aft-bef));   } -  _cmd_store(args) {-    var fname = this._get_arg(args, 0);-    for (var i = 1; i < args.length; i++) {-      var vname = args[i];-      var value = this._get_var(vname);-      var typ = this._get_type(vname);-      var fs = require("fs");-      var bin_val = construct_binary_value(value, typ);-      fs.appendFileSync(fname, bin_val, 'binary')+  _cmd_entry_points(args) {+    for (var e in this.manifest.entry_points) {+      console.log(e);     }   } -  fut_to_dim_typ(typ) {-    var type = typ;-    var count = 0;-    while (type.substr(0, 2) == '[]') {-      count = count + 1;-      type = type.slice(2);+  _cmd_attributes(args) {+    var entry = this._get_entry_point(this._get_arg(args, 0));+    for (var attr of entry.attributes) {+      console.log(attr);     }-    return [count, type];   } +  _cmd_call(args) {+    var entry = this._get_entry_point(this._get_arg(args, 0));+    var out_vname = this._get_arg(args, 1);+    var in_vnames = args.slice(2);+    if (in_vnames.length != entry.inputs.length) {+      throw "Invalid argument count, expected " + entry.inputs.length;+    }+    var ins = in_vnames.map((v, i) => this._get_typed_var(v, entry.inputs[i].type));+    this._check_new_var(out_vname);++    var bef = performance.now() * 1000;+    var out = this._with_out(entry.output.type, (p) => {+      this._check(this._c(entry.cfun, p, ...ins));+      this._sync();+    });+    var aft = performance.now() * 1000;+    console.log("runtime: " + Math.round(aft - bef));+    this._set_var(out_vname, entry.output.type, out);+  }++  _cmd_store(args) {+    var fname = this._get_arg(args, 0);+    var bufs = [];+    for (var vname of args.slice(1)) {+      var v = this._get_var(vname);+      bufs.push(this._store_value(v.type, v.value));+    }+    require("fs").writeFileSync(fname, Buffer.concat(bufs));+  }+   _cmd_restore(args) {+    var fname = this._get_arg(args, 0);     if (args.length % 2 == 0) {       throw "Invalid argument count";     } -    var fname = args[0];-    var args = args.slice(1);--    var as = args;     var reader = new Reader(fname);-    while (as.length != 0) {-      var vname = as[0];-      var typename = as[1];-      as = as.slice(2);--      if (vname in this._vars) {-        throw "Variable already exists: " + vname;-      }+    for (var i = 1; i < args.length; i += 2) {+      var vname = args[i];+      var tname = args[i + 1];+      this._check_new_var(vname);+      this._type(tname);       try {-        var value = read_value(typename, reader);-        if (typeof value == 'number' || typeof value == 'bigint') {-          this._set_var(vname, value, typename);-        } else {-          // We are working with an array and need to create to convert [shape, arr] to futhark ptr-          var shape= value[0];-          var arr = value[1];-          var dimtyp = this.fut_to_dim_typ(typename);-          var dim = dimtyp[0];-          var typ = dimtyp[1];-          var arg_list = [arr, ...shape];-          var fnam = "new_" + typ + "_" + dim + "d";-          var ptr = this.ctx[fnam].apply(this.ctx, arg_list);-          this._set_var(vname, ptr, typename);-        }+        this._set_var(vname, tname, this._restore_value(reader, tname));       } catch (err) {-        var err_msg = "Failed to restore variable " + vname + ".\nPossibly malformed data in " + fname + ".\n" + err.toString();-        throw err_msg;+        throw "Failed to restore variable " + vname + ".\nPossibly malformed data in " + fname + ".\n" + err.toString();       }     }     skip_spaces(reader);@@ -233,32 +427,261 @@     }   } +  _cmd_kind(args) {+    console.log(this._kind(this._get_arg(args, 0)));+  }++  _cmd_type(args) {+    console.log(this._get_var(this._get_arg(args, 0)).type);+  }++  _cmd_rank(args) {+    console.log(this._array_type(this._get_arg(args, 0)).rank);+  }++  _cmd_elemtype(args) {+    console.log(this._array_type(this._get_arg(args, 0)).elemtype);+  }++  _cmd_shape(args) {+    var v = this._get_var(this._get_arg(args, 0));+    for (var d of this._shape(this._array_type(v.type), v.value)) {+      console.log(d.toString());+    }+  }++  _cmd_new_array(args) {+    var dst = this._get_arg(args, 0);+    var tname = this._get_arg(args, 1);+    this._check_new_var(dst);+    var a = this._array_type(tname);+    var dims = this._parse_ints(args.slice(2, 2 + a.rank), a.rank);+    var vnames = args.slice(2 + a.rank);+    var n = dims.reduce((x, y) => x * y, 1n);+    if (BigInt(vnames.length) != n) {+      throw "Expected " + n + " values, but got " + vnames.length + ".";+    }+    var vs = vnames.map((v) => this._get_typed_var(v, a.elemtype));++    var size = this._sizeof(a.elemtype);+    var p = this._malloc(vs.length * size);+    try {+      vs.forEach((v, i) => this._poke(a.elemtype, p + i * size, v));+      var arr;+      if (a.ops) {+        arr = this._c(a.ops.new, p, ...dims);+        if (arr == 0) {+          throw this.ctx.get_error();+        }+      } else {+        arr = this._with_out(tname, (out) => {+          this._check(this._c(a.new, out, p, ...dims));+        });+      }+      this._sync();+      this._set_var(dst, tname, arr);+    } finally {+      this.wasm._free(p);+    }+  }++  _cmd_set(args) {+    var arr = this._get_var(this._get_arg(args, 0));+    var a = this._array_type(arr.type);+    var val = this._get_typed_var(this._get_arg(args, 1), a.elemtype);+    var is = this._parse_ints(args.slice(2), a.rank);+    this._check_bounds(this._shape(a, arr.value), is);+    var fset = a.ops ? a.ops.set : a.set;+    this._check(this._c(fset, arr.value, val, ...is));+    this._sync();+  }++  _cmd_index(args) {+    var dst = this._get_arg(args, 0);+    var arr = this._get_var(this._get_arg(args, 1));+    this._check_new_var(dst);+    var a = this._array_type(arr.type);+    var is = this._parse_ints(args.slice(2), a.rank);+    this._check_bounds(this._shape(a, arr.value), is);+    var findex = a.ops ? a.ops.index : a.index;+    var v = this._with_out(a.elemtype, (p) => {+      this._check(this._c(findex, p, arr.value, ...is));+      this._sync();+    });+    this._set_var(dst, a.elemtype, v);+  }++  _cmd_zip(args) {+    var dst = this._get_arg(args, 0);+    var tname = this._get_arg(args, 1);+    this._check_new_var(dst);+    var a = this._array_type(tname);+    if (!a.fields) {+      throw "Cannot zip this array type";+    }+    var vnames = args.slice(2);+    if (vnames.length != a.fields.length) {+      throw a.fields.length + " arrays expected but " + vnames.length + " values provided.";+    }+    var vs = vnames.map((v, i) => this._get_typed_var(v, a.fields[i].type));+    var arr = this._with_out(tname, (p) => {+      this._check(this._c(a.zip, p, ...vs));+      this._sync();+    });+    this._set_var(dst, tname, arr);+  }++  _cmd_unzip(args) {+    var arr = this._get_var(this._get_arg(args, 0));+    var a = this._array_type(arr.type);+    if (!a.fields) {+      throw "Cannot unzip this array type";+    }+    var dsts = args.slice(1);+    if (dsts.length != a.fields.length) {+      throw a.fields.length + " arrays expected but " + dsts.length + " values provided.";+    }+    dsts.forEach((dst) => this._check_new_var(dst));+    a.fields.forEach((f, i) => {+      var v = this._with_out(f.type, (p) => {+        this._check(this._c(f.project, p, arr.value));+      });+      this._set_var(dsts[i], f.type, v);+    });+    this._sync();+  }++  _cmd_fields(args) {+    for (var f of this._record_type(this._get_arg(args, 0)).fields) {+      console.log(f.name + " " + f.type);+    }+  }++  _cmd_new(args) {+    var dst = this._get_arg(args, 0);+    var tname = this._get_arg(args, 1);+    this._check_new_var(dst);+    var r = this._record_type(tname);+    var vnames = args.slice(2);+    if (vnames.length != r.fields.length) {+      throw r.fields.length + " fields expected but " + vnames.length + " values provided.";+    }+    var vs = vnames.map((v, i) => this._get_typed_var(v, r.fields[i].type));+    var obj = this._with_out(tname, (p) => {+      this._check(this._c(r.new, p, ...vs));+    });+    this._set_var(dst, tname, obj);+  }++  _cmd_project(args) {+    var dst = this._get_arg(args, 0);+    var from = this._get_var(this._get_arg(args, 1));+    var field = this._get_arg(args, 2);+    this._check_new_var(dst);+    var f = this._record_type(from.type).fields.find((f) => f.name == field);+    if (f === undefined) {+      throw "No such field: " + field;+    }+    var v = this._with_out(f.type, (p) => {+      this._check(this._c(f.project, p, from.value));+    });+    this._set_var(dst, f.type, v);+  }++  _cmd_variants(args) {+    for (var v of this._sum_type(this._get_arg(args, 0)).variants) {+      console.log(v.name);+      for (var t of v.payload) {+        console.log("- " + t);+      }+    }+  }++  _variant_of(v) {+    var s = this._sum_type(v.type);+    return s.variants[this._c(s.variant, v.value)];+  }++  _cmd_variant(args) {+    console.log(this._variant_of(this._get_var(this._get_arg(args, 0))).name);+  }++  _cmd_construct(args) {+    var dst = this._get_arg(args, 0);+    var tname = this._get_arg(args, 1);+    var vname = this._get_arg(args, 2);+    this._check_new_var(dst);+    var variant = this._sum_type(tname).variants.find((v) => v.name == vname);+    if (variant === undefined) {+      throw "No such variant: " + vname;+    }+    var vnames = args.slice(3);+    if (vnames.length != variant.payload.length) {+      throw variant.payload.length + " values expected but " + vnames.length + " provided.";+    }+    var vs = vnames.map((v, i) => this._get_typed_var(v, variant.payload[i]));+    var obj = this._with_out(tname, (p) => {+      this._check(this._c(variant.construct, p, ...vs));+    });+    this._set_var(dst, tname, obj);+  }++  _cmd_destruct(args) {+    var v = this._get_var(this._get_arg(args, 0));+    var variant = this._variant_of(v);+    var dsts = args.slice(1);+    if (dsts.length != variant.payload.length) {+      throw variant.payload.length + " variables expected but " + dsts.length + " provided.";+    }+    dsts.forEach((dst) => this._check_new_var(dst));+    var ps = variant.payload.map((t) => this._malloc(this._sizeof(t)));+    try {+      this._check(this._c(variant.destruct, ...ps, v.value));+      variant.payload.forEach((t, i) => this._set_var(dsts[i], t, this._load(t, ps[i])));+    } finally {+      ps.forEach((p) => this.wasm._free(p));+    }+  }+   _process_line(line) {-    // TODO make sure it splits on anywhite space-    var words = line.split(" ");+    var words = split_words(line);     if (words.length == 0) {       throw "Empty line";     } else {       var cmd = words[0];-      var args = words.splice(1);+      var args = words.slice(1);       switch (cmd) {       case 'inputs': this._cmd_inputs(args); break;-      case 'output': this._cmd_output(args); break-      case 'call': this._cmd_call(args); break-      case 'restore': this._cmd_restore(args); break-      case 'store': this._cmd_store(args); break-      case 'free': this._cmd_free(args); break-      case 'clear': this._cmd_dummy(args); break-      case 'pause_profiling': this._cmd_dummy(args); break-      case 'unpause_profiling': this._cmd_dummy(args); break-      case 'report': this._cmd_dummy(args); break-      case 'rename': this._cmd_rename(args); break-      case 'types': this._cmd_types(args); break-      case 'fields': this._cmd_fields(args); break-      case 'project': this._cmd_project(args); break-          // XXX: these should be implemented.-      case 'attributes': this._cmd_dummy(args); break-      case 'entry_points': this._cmd_dummy(args); break+      case 'output': this._cmd_output(args); break;+      case 'call': this._cmd_call(args); break;+      case 'restore': this._cmd_restore(args); break;+      case 'store': this._cmd_store(args); break;+      case 'free': this._cmd_free(args); break;+      case 'clear': this._cmd_dummy(args); break;+      case 'pause_profiling': this._cmd_dummy(args); break;+      case 'unpause_profiling': this._cmd_dummy(args); break;+      case 'report': this._cmd_dummy(args); break;+      case 'rename': this._cmd_rename(args); break;+      case 'types': this._cmd_types(args); break;+      case 'entry_points': this._cmd_entry_points(args); break;+      case 'attributes': this._cmd_attributes(args); break;+      case 'kind': this._cmd_kind(args); break;+      case 'type': this._cmd_type(args); break;+      case 'rank': this._cmd_rank(args); break;+      case 'elemtype': this._cmd_elemtype(args); break;+      case 'shape': this._cmd_shape(args); break;+      case 'new_array': this._cmd_new_array(args); break;+      case 'set': this._cmd_set(args); break;+      case 'index': this._cmd_index(args); break;+      case 'zip': this._cmd_zip(args); break;+      case 'unzip': this._cmd_unzip(args); break;+      case 'fields': this._cmd_fields(args); break;+      case 'new': this._cmd_new(args); break;+      case 'project': this._cmd_project(args); break;+      case 'variants': this._cmd_variants(args); break;+      case 'construct': this._cmd_construct(args); break;+      case 'destruct': this._cmd_destruct(args); break;+      case 'variant': this._cmd_variant(args); break;       default: throw "Unknown command: " + cmd;       }     }@@ -271,6 +694,7 @@     rl.on('line', (line) => {       if (line == "") {         rl.close();+        return;       }       try {         this._process_line(line);@@ -282,6 +706,26 @@       }     }).on('close', () => { process.exit(0); });   }+}++// Split a command line into words separated by whitespace.  A word may be+// enclosed in double quotes, in which case it may contain whitespace.+function split_words(line) {+  var words = [];+  var re = /"([^"]*)"|[^\s"]+/g;+  var m;+  var pos = 0;+  while ((m = re.exec(line)) !== null) {+    if (line.slice(pos, m.index).trim() != "") {+      throw "Unterminated quote";+    }+    words.push(m[1] !== undefined ? m[1] : m[0]);+    pos = re.lastIndex;+  }+  if (line.slice(pos).trim() != "") {+    throw "Unterminated quote";+  }+  return words; }  // End of server.js
rts/javascript/values.js view
@@ -61,43 +61,19 @@   return new Uint8Array(ta.buffer, ta.byteOffset, ta.byteLength); } -function construct_binary_value(v, typ) {-  var dims;-  var payload_bytes;-  var filler;-  if (v instanceof FutharkOpaque) {-    throw "Opaques are not supported";-  } else if (v instanceof FutharkArray) {-    var t = v.futharkType();-    var ftype = "    ".slice(t.length) + t;-    var shape = v.shape();-    var ta = v.toTypedArray(shape);-    var da = new BigInt64Array(shape);-    dims = shape.length;-    payload_bytes = da.byteLength + ta.byteLength;-    filler = (bytes) => {-      bytes.set(toU8(da), 7);-      bytes.set(toU8(ta), 7 + da.byteLength);-    }-  } else {-    var ftype = "    ".slice(typ.length) + typ;-    dims = 0;-    payload_bytes = typToSize[ftype];-    filler = (bytes) => {-      var scalar = new (typToType[ftype])([v]);-      bytes.set(toU8(scalar), 7);-    }-  }-  var total_bytes = 7 + payload_bytes;-  var bytes = new Uint8Array(total_bytes);-  bytes[0] = Buffer.from('b').readUInt8();-  bytes[1] = 2;-  bytes[2] = dims;+// The binary encoding of a value with the given primitive type and shape (a+// list of BigInts), where 'bytes' is the payload.+function binary_value(typ, shape, bytes) {+  var ftype = "    ".slice(typ.length) + typ;+  var header = new Uint8Array(7);+  header[0] = 'b'.charCodeAt(0);+  header[1] = 2;+  header[2] = shape.length;   for (var i = 0; i < 4; i++) {-    bytes[3+i] = ftype.charCodeAt(i);+    header[3+i] = ftype.charCodeAt(i);   }-  filler(bytes);-  return Buffer.from(bytes);+  var dims = new BigInt64Array(shape);+  return Buffer.concat([header, toU8(dims), bytes]); }  class Reader {@@ -156,8 +132,6 @@     this.buff = this.buff.slice(7);     var exp_typ = "[]".repeat(dim) + typename;     var given_typ = "[]".repeat(num_dim) + typ.toString().trim();-    console.log(exp_typ);-    console.log(given_typ);     if (exp_typ !== given_typ) {       throw ("Expected type : " + exp_typ + ", Actual type : " + given_typ);     }
rts/python/memory.py view
@@ -145,12 +145,12 @@     if rowmajor_strides[map_r:] == dst_strides[map_r:]:         r = lmad_is_tr(src_strides[map_r:], shape[map_r:])         if r is not None:-            (n, m) = r+            n, m = r             return (k, n, m)     elif rowmajor_strides[map_r:] == src_strides[map_r:]:         r = lmad_is_tr(dst_strides[map_r:], shape[map_r:])         if r is not None:-            (n, m) = r+            n, m = r             return (k, m, n)  # Sic!     return None
rts/python/opencl.py view
@@ -36,7 +36,7 @@     interactive=False, platform_pref=None, device_pref=None ):     if device_pref != None:-        (device_pref, device_num) = parse_preferred_device(device_pref)+        device_pref, device_num = parse_preferred_device(device_pref)     else:         device_num = 0 @@ -521,7 +521,7 @@     else:         tr = lmad_map_tr(dst_strides, src_strides, shape)         if tr is not None:-            (k, n, m) = tr+            k, n, m = tr             map_transpose_gpu2gpu(                 self, elem_size, dst, dst_offset, src, src_offset, k, m, n             )
rts/python/scalar.py view
@@ -61,7 +61,7 @@         return x // y  -def sdiv_upN(x, y):+def sceil_divN(x, y):     if y == 0:         return intlit(type(x), 0)     else:@@ -82,7 +82,7 @@         return signed(unsigned(x) // unsigned(y))  -def udiv_upN(x, y):+def uceil_divN(x, y):     if y == 0:         return intlit(type(x), 0)     else:@@ -294,15 +294,19 @@   sdiv8 = sdiv16 = sdiv32 = sdiv64 = sdivN-sdiv_up8 = sdiv1_up6 = sdiv_up32 = sdiv_up64 = sdiv_upN+sceil_div8 = sdiv1_up6 = sceil_div32 = sceil_div64 = sceil_divN sdiv_safe8 = sdiv1_safe6 = sdiv_safe32 = sdiv_safe64 = sdivN-sdiv_up_safe8 = sdiv_up1_safe6 = sdiv_up_safe32 = sdiv_up_safe64 = sdiv_upN+sceil_div_safe8 = sceil_div1_safe6 = sceil_div_safe32 = sceil_div_safe64 = (+    sceil_divN+) smod8 = smod16 = smod32 = smod64 = smodN smod_safe8 = smod_safe16 = smod_safe32 = smod_safe64 = smodN udiv8 = udiv16 = udiv32 = udiv64 = udivN-udiv_up8 = udiv_up16 = udiv_up32 = udiv_up64 = udivN-udiv_safe8 = udiv_safe16 = udiv_safe32 = udiv_safe64 = udiv_upN-udiv_up_safe8 = udiv_up_safe16 = udiv_up_safe32 = udiv_up_safe64 = udiv_upN+uceil_div8 = uceil_div16 = uceil_div32 = uceil_div64 = udivN+udiv_safe8 = udiv_safe16 = udiv_safe32 = udiv_safe64 = uceil_divN+uceil_div_safe8 = uceil_div_safe16 = uceil_div_safe32 = uceil_div_safe64 = (+    uceil_divN+) umod8 = umod16 = umod32 = umod64 = umodN umod_safe8 = umod_safe16 = umod_safe32 = umod_safe64 = umodN squot8 = squot16 = squot32 = squot64 = squotN@@ -407,7 +411,7 @@   def fptosi_T_i8(x):-    if np.isnan(x) or np.isinf(x):+    if np.isnan(x) or x < -(1 << 7) or x >= (1 << 7):         return np.int8(0)     else:         return np.int8(np.trunc(x))@@ -417,7 +421,7 @@   def fptosi_T_i16(x):-    if np.isnan(x) or np.isinf(x):+    if np.isnan(x) or x < -(1 << 15) or x >= (1 << 15):         return np.int16(0)     else:         return np.int16(np.trunc(x))@@ -427,7 +431,7 @@   def fptosi_T_i32(x):-    if np.isnan(x) or np.isinf(x):+    if np.isnan(x) or x < -(1 << 31) or x >= (1 << 31):         return np.int32(0)     else:         return np.int32(np.trunc(x))@@ -437,7 +441,7 @@   def fptosi_T_i64(x):-    if np.isnan(x) or np.isinf(x):+    if np.isnan(x) or x < -(1 << 63) or x >= (1 << 63):         return np.int64(0)     else:         return np.int64(np.trunc(x))@@ -447,7 +451,7 @@   def fptoui_T_i8(x):-    if np.isnan(x) or np.isinf(x):+    if np.isnan(x) or x < 0 or x >= (1 << 8):         return np.int8(0)     else:         return np.int8(np.trunc(x))@@ -457,7 +461,7 @@   def fptoui_T_i16(x):-    if np.isnan(x) or np.isinf(x):+    if np.isnan(x) or x < 0 or x >= (1 << 16):         return np.int16(0)     else:         return np.int16(np.trunc(x))@@ -467,7 +471,7 @@   def fptoui_T_i32(x):-    if np.isnan(x) or np.isinf(x):+    if np.isnan(x) or x < 0 or x >= (1 << 32):         return np.int32(0)     else:         return np.int32(np.trunc(x))@@ -477,7 +481,7 @@   def fptoui_T_i64(x):-    if np.isnan(x) or np.isinf(x):+    if np.isnan(x) or x < 0 or x >= (1 << 64):         return np.int64(0)     else:         return np.int64(np.trunc(x))
rts/python/server.py view
@@ -80,7 +80,7 @@         ins = [self._get_var(in_vname) for in_vname in in_vnames]          try:-            (runtime, vals) = getattr(self._ctx, entry_fname)(*ins)+            runtime, vals = getattr(self._ctx, entry_fname)(*ins)         except Exception as e:             raise self.Failure(str(e)) @@ -115,11 +115,11 @@                 self._store_val(f, self._get_var(args[i]))      def _restore_val(self, reader, typename):-        if typename in self._ctx.opaques:+        if typename in self._ctx.opaque_types:             vs = []-            for t in self._ctx.opaques[typename]:+            for t in self._ctx.opaque_types[typename]["payload"]:                 vs += [read_value(t, reader)]-            return opaque(typename, *vs)+            return self._opaque(typename, vs)         else:             return read_value(typename, reader) @@ -156,27 +156,363 @@         for k in self._ctx.opaques.keys():             print(k) -    def _cmd_fields(self, args):-        tname = self._get_arg(args, 0)-        if not tname in self._ctx.opaques:-            raise self.Failure(f"Unknown type {tname}")+    # Types and values.+    #+    # An opaque value is represented by its payload: a flat list of primitive+    # values and arrays, as described by 'opaque_types'. A transparent value of+    # type t is represented by a single NumPy value (or a PyOpenCL array).++    def _opaque(self, tname, payload):+        return opaque(tname, self._ctx.opaques, *payload)++    def _opaque_type(self, tname):+        if tname in self._ctx.opaque_types:+            return self._ctx.opaque_types[tname]         else:-            t = self._ctx.opaques[tname]-            if type(t[1]) is tuple:-                i = 0-                for x in t[1]:-                    print(i, x)-                    i += 1+            raise self.Failure("Unknown opaque type: %s" % tname) +    # Split a transparent type name into its rank and primitive type.+    def _split_type(self, tname):+        rank = 0+        while tname.startswith("[]"):+            rank += 1+            tname = tname[2:]+        if tname not in FUTHARK_PRIMTYPES:+            raise self.Failure("Unknown type: %s" % ("[]" * rank + tname))+        return rank, tname++    def _kind(self, tname):+        if tname in self._ctx.opaque_types:+            return self._ctx.opaque_types[tname]["kind"]+        elif self._split_type(tname)[0] == 0:+            return "primitive"+        else:+            return "array"++    def _array_type(self, tname):+        if self._kind(tname) != "array":+            raise self.Failure("Not an array type")+        if tname in self._ctx.opaque_types:+            t = self._ctx.opaque_types[tname]+            return t["rank"], t["elemtype"]+        else:+            return self._split_type(tname)++    def _record_fields(self, tname):+        if self._kind(tname) != "record":+            raise self.Failure("Not a record type")+        return self._opaque_type(tname)["fields"]++    def _sum_variants(self, tname):+        if self._kind(tname) != "sum":+            raise self.Failure("Not a sum type")+        return self._opaque_type(tname)["variants"]++    def _type_of(self, v):+        if isinstance(v, opaque):+            return v.desc+        dtype = v.dtype if hasattr(v, "dtype") else np.dtype(type(v))+        return "[]" * np.ndim(v) + numpy_type_to_type_name(dtype)++    def _get_typed_var(self, vname, tname):+        v = self._get_var(vname)+        if self._type_of(v) != tname:+            raise self.Failure(+                "Variable %s has type %s, expected %s"+                % (vname, self._type_of(v), tname)+            )+        return v++    def _payload_size(self, tname):+        if tname in self._ctx.opaque_types:+            return len(self._ctx.opaque_types[tname]["payload"])+        else:+            return 1++    def _payload(self, v):+        if isinstance(v, opaque):+            return list(v.data)+        else:+            return [v]++    def _from_payload(self, tname, payload):+        if tname in self._ctx.opaque_types:+            return self._opaque(tname, payload)+        else:+            return payload[0]++    # Split a payload into the parts corresponding to the given types.+    def _split_payload(self, tnames, payload):+        parts = []+        for t in tnames:+            n = self._payload_size(t)+            parts += [payload[:n]]+            payload = payload[n:]+        return parts++    # An empty value of the given transparent type, used for the unused+    # parts of the payload of a sum type.+    def _blank(self, tname):+        rank, pt = self._split_type(tname)+        dtype = FUTHARK_PRIMTYPES[pt]["numpy_type"]+        if rank == 0:+            return dtype(0)+        else:+            return np.zeros((0,) * rank, dtype=dtype)++    # Convert a PyOpenCL array to a NumPy array.+    def _to_host(self, x):+        if isinstance(x, np.ndarray) or not hasattr(x, "get"):+            return x+        else:+            return x.get()++    def _shape(self, v, rank):+        return tuple(int(d) for d in np.shape(self._payload(v)[0])[:rank])++    def _parse_ints(self, args):+        try:+            return [int(x) for x in args]+        except ValueError:+            raise self.Failure("Invalid integer in: %s" % " ".join(args))++    # Index a transparent array, producing a fresh value.+    def _index_transparent(self, x, idx):+        x = self._to_host(x[idx])+        if isinstance(x, np.ndarray):+            return x[()] if x.ndim == 0 else x.copy()+        else:+            return x++    def _cmd_kind(self, args):+        print(self._kind(self._get_arg(args, 0)))++    def _cmd_type(self, args):+        print(self._type_of(self._get_var(self._get_arg(args, 0))))++    def _cmd_rank(self, args):+        print(self._array_type(self._get_arg(args, 0))[0])++    def _cmd_elemtype(self, args):+        print(self._array_type(self._get_arg(args, 0))[1])++    def _cmd_shape(self, args):+        v = self._get_var(self._get_arg(args, 0))+        rank, _ = self._array_type(self._type_of(v))+        for d in self._shape(v, rank):+            print(d)++    def _cmd_new_array(self, args):+        dst = self._get_arg(args, 0)+        tname = self._get_arg(args, 1)+        self._check_new_var(dst)+        rank, et = self._array_type(tname)+        dims = tuple(self._parse_ints(args[2 : 2 + rank]))+        if len(dims) != rank or any(d < 0 for d in dims):+            raise self.Failure("Expected %d valid dimensions" % rank)+        vnames = args[2 + rank :]+        if len(vnames) != np.prod(dims, dtype=np.int64):+            raise self.Failure(+                "Expected %d values, but got %d"+                % (np.prod(dims, dtype=np.int64), len(vnames))+            )+        elems = [self._payload(self._get_typed_var(v, et)) for v in vnames]+        if tname in self._ctx.opaque_types:+            ts = self._ctx.opaque_types[tname]["payload"]+        else:+            ts = [tname]+        payload = []+        for i, t in enumerate(ts):+            r, pt = self._split_type(t)+            dtype = FUTHARK_PRIMTYPES[pt]["numpy_type"]+            if elems == []:+                payload += [np.zeros(dims + (0,) * (r - rank), dtype=dtype)]+            else:+                try:+                    x = np.array(+                        [self._to_host(e[i]) for e in elems], dtype=dtype+                    )+                except ValueError:+                    raise self.Failure("Array elements have irregular shapes")+                payload += [x.reshape(dims + x.shape[1:])]+        self._vars[dst] = self._from_payload(tname, payload)++    def _cmd_set(self, args):+        arr = self._get_arg(args, 0)+        v = self._get_var(arr)+        rank, et = self._array_type(self._type_of(v))+        val = self._payload(self._get_typed_var(self._get_arg(args, 1), et))+        idx = tuple(self._parse_ints(args[2:]))+        if len(idx) != rank:+            raise self.Failure(+                "%d indices expected but %d values provided."+                % (rank, len(idx))+            )+        shape = self._shape(v, rank)+        if not all(0 <= i < d for i, d in zip(idx, shape)):+            raise self.Failure(+                "Index %s out of bounds for shape %s" % (idx, shape)+            )+        payload = [self._to_host(x) for x in self._payload(v)]+        for x, y in zip(payload, val):+            x[idx] = self._to_host(y)+        self._vars[arr] = self._from_payload(self._type_of(v), payload)++    def _cmd_index(self, args):+        dst = self._get_arg(args, 0)+        v = self._get_var(self._get_arg(args, 1))+        self._check_new_var(dst)+        rank, et = self._array_type(self._type_of(v))+        idx = tuple(self._parse_ints(args[2:]))+        if len(idx) != rank:+            raise self.Failure(+                "%d indices expected but %d values provided."+                % (rank, len(idx))+            )+        shape = self._shape(v, rank)+        if not all(0 <= i < d for i, d in zip(idx, shape)):+            raise self.Failure(+                "Index %s out of bounds for shape %s" % (idx, shape)+            )+        payload = [self._index_transparent(x, idx) for x in self._payload(v)]+        self._vars[dst] = self._from_payload(et, payload)++    def _cmd_zip(self, args):+        dst = self._get_arg(args, 0)+        tname = self._get_arg(args, 1)+        self._check_new_var(dst)+        rank, _ = self._array_type(tname)+        fields = self._opaque_type(tname).get("fields")+        if fields is None:+            raise self.Failure("Cannot zip to this array type")+        vnames = args[2:]+        if len(vnames) != len(fields):+            raise self.Failure(+                "%d arrays expected but %d values provided."+                % (len(fields), len(vnames))+            )+        vs = [self._get_typed_var(v, t) for v, (_, t) in zip(vnames, fields)]+        if len(set(self._shape(v, rank) for v in vs)) > 1:+            raise self.Failure("Arrays have different shapes")+        payload = []+        for v in vs:+            payload += self._payload(v)+        self._vars[dst] = self._opaque(tname, payload)++    def _cmd_unzip(self, args):+        v = self._get_var(self._get_arg(args, 0))+        tname = self._type_of(v)+        self._array_type(tname)+        fields = self._opaque_type(tname).get("fields")+        if fields is None:+            raise self.Failure("Cannot unzip this array type")+        dsts = args[1:]+        if len(dsts) != len(fields):+            raise self.Failure(+                "%d arrays expected but %d values provided."+                % (len(fields), len(dsts))+            )+        for dst in dsts:+            self._check_new_var(dst)+        ts = [t for _, t in fields]+        for dst, t, p in zip(+            dsts, ts, self._split_payload(ts, self._payload(v))+        ):+            self._vars[dst] = self._from_payload(t, p)++    def _cmd_fields(self, args):+        for f, t in self._record_fields(self._get_arg(args, 0)):+            print(f, t)++    def _cmd_new(self, args):+        dst = self._get_arg(args, 0)+        tname = self._get_arg(args, 1)+        self._check_new_var(dst)+        fields = self._record_fields(tname)+        vnames = args[2:]+        if len(vnames) != len(fields):+            raise self.Failure(+                "%d fields expected but %d values provided."+                % (len(fields), len(vnames))+            )+        payload = []+        for v, (_, t) in zip(vnames, fields):+            payload += self._payload(self._get_typed_var(v, t))+        self._vars[dst] = self._opaque(tname, payload)+     def _cmd_project(self, args):         dst = self._get_arg(args, 0)-        src = self._get_arg(args, 1)+        v = self._get_var(self._get_arg(args, 1))         field = self._get_arg(args, 2)         self._check_new_var(dst)-        self._check_var(src)-        # FIXME: assuming a tuple.-        self._vars[dst] = self._vars[src].data[int(field)]+        fields = self._record_fields(self._type_of(v))+        ts = [t for _, t in fields]+        for (f, t), p in zip(+            fields, self._split_payload(ts, self._payload(v))+        ):+            if f == field:+                self._vars[dst] = self._from_payload(t, p)+                return+        raise self.Failure("No such field: %s" % field) +    def _cmd_variants(self, args):+        for name, payload in self._sum_variants(self._get_arg(args, 0)):+            print(name)+            for t, _ in payload:+                print("- %s" % t)++    # The variant of a sum-typed value. When there is more than one variant,+    # the first element of the payload is the index of the variant.+    def _variant_of(self, v):+        variants = self._sum_variants(self._type_of(v))+        if len(variants) == 1:+            return variants[0]+        else:+            return variants[int(v.data[0])]++    def _cmd_construct(self, args):+        dst = self._get_arg(args, 0)+        tname = self._get_arg(args, 1)+        vname = self._get_arg(args, 2)+        self._check_new_var(dst)+        variants = self._sum_variants(tname)+        for i, (name, vpayload) in enumerate(variants):+            if name == vname:+                break+        else:+            raise self.Failure("No such variant: %s" % vname)+        vnames = args[3:]+        if len(vnames) != len(vpayload):+            raise self.Failure(+                "%d values expected but %d provided."+                % (len(vpayload), len(vnames))+            )+        ts = self._opaque_type(tname)["payload"]+        payload = [self._blank(t) for t in ts]+        if len(variants) > 1:+            payload[0] = FUTHARK_PRIMTYPES[ts[0]]["numpy_type"](i)+        for v, (t, js) in zip(vnames, vpayload):+            for j, x in zip(js, self._payload(self._get_typed_var(v, t))):+                payload[j] = x+        self._vars[dst] = self._opaque(tname, payload)++    def _cmd_destruct(self, args):+        v = self._get_var(self._get_arg(args, 0))+        _, vpayload = self._variant_of(v)+        dsts = args[1:]+        if len(dsts) != len(vpayload):+            raise self.Failure(+                "%d variables expected but %d provided."+                % (len(vpayload), len(dsts))+            )+        for dst in dsts:+            self._check_new_var(dst)+        for dst, (t, js) in zip(dsts, vpayload):+            self._vars[dst] = self._from_payload(t, [v.data[j] for j in js])++    def _cmd_variant(self, args):+        print(self._variant_of(self._get_var(self._get_arg(args, 0)))[0])+     def _cmd_attributes(self, args):         return self._get_entry_point(self._get_arg(args, 0))["attributes"] @@ -198,8 +534,23 @@         "report": _cmd_dummy,         "types": _cmd_types,         "entry_points": _cmd_entry_points,+        "kind": _cmd_kind,+        "type": _cmd_type,+        "rank": _cmd_rank,+        "elemtype": _cmd_elemtype,+        "shape": _cmd_shape,+        "new_array": _cmd_new_array,+        "set": _cmd_set,+        "index": _cmd_index,+        "zip": _cmd_zip,+        "unzip": _cmd_unzip,         "fields": _cmd_fields,+        "new": _cmd_new,         "project": _cmd_project,+        "variants": _cmd_variants,+        "construct": _cmd_construct,+        "destruct": _cmd_destruct,+        "variant": _cmd_variant,         "attributes": _cmd_attributes,     }
rts/python/values.py view
@@ -51,7 +51,7 @@             # May be line comment.             if f.peek_char() == b"-":                 # Yes, line comment. Skip to end of line.-                while c != b"\n" and c != None:+                while c and c != b"\n":                     c = f.get_char()             else:                 break@@ -125,7 +125,7 @@ def parse_hex_int(f):     s = b""     c = f.get_char()-    while c != None:+    while c:         if c in b"01234556789ABCDEFabcdef":             s += c             c = f.get_char()@@ -140,7 +140,7 @@ def parse_int(f):     s = b""     c = f.get_char()-    if c == b"0" and f.peek_char() in b"xX":+    if c == b"0" and f.peek_char() in (b"x", b"X"):         c = f.get_char()  # skip X         return parse_hex_int(f)     else:
src-testing/Futhark/BenchTests.hs view
@@ -44,5 +44,23 @@     prop :: BenchResult -> Bool     prop brs = decodeBenchResults (encodeBenchResults [brs]) == Right [brs] +metadataJSON :: TestTree+metadataJSON = testProperty "metadata preserves benchmark decoding" prop+  where+    prop :: BenchResult -> Bool+    prop brs =+      decodeBenchResults (encodeBenchResultsWithMetadata metadata [brs])+        == Right [brs]+    metadata =+      BenchMetadata+        { benchStartTime = read "2026-09-09 01:02:03 UTC",+          benchEndTime = read "2026-09-09 01:02:04 UTC",+          benchHostname = Just "benchmark-host",+          benchCompilerVersion = Just "Futhark test compiler",+          benchBackend = "c",+          benchCompilerOptions = ["--safe"],+          benchRuntimeOptions = ["--debugging"]+        }+ tests :: TestTree-tests = testGroup "Futhark.BenchTests" [encodeDecodeJSON]+tests = testGroup "Futhark.BenchTests" [encodeDecodeJSON, metadataJSON]
src-testing/Futhark/IR/Prop/ReshapeTests.hs view
@@ -10,6 +10,7 @@ import Futhark.IR.Prop.Reshape import Futhark.IR.Syntax import Futhark.IR.SyntaxTests ()+import Futhark.Util.IntegralExp (Wrapped (..)) import Test.Tasty import Test.Tasty.HUnit @@ -64,7 +65,12 @@       )       $ flipReshapeRearrange v0_shape v1_shape perm @?= res   | (v0_shape :: [String], v1_shape, perm, res) <--      [ ( ["A", "B", "C"],+      [ ( ["M", "A", "B"],+          ["M", "C", "D"],+          [0, 2, 1],+          Nothing+        ),+        ( ["A", "B", "C"],           ["A", "BC"],           [1, 0],           Just [1, 2, 0]@@ -127,8 +133,13 @@ simplifyTests =   testGroup     "simplifyNewShape"-    [ testCase "Inverse flatten and unflatten - simple case" $+    [ testCase "Partial inverse must preserve extra dimension" $         lhs+          ["A", "B", "C"]+          [dimSplice 0 2 ["AB", "1"], dimUnflatten 0 ["A", "B"]]+          @?= Nothing,+      testCase "Inverse flatten and unflatten - simple case" $+        lhs           ["A", "B"]           [dimFlatten 0 2 "AB", dimUnflatten 0 ["A", "B"]]           @?= Just [],@@ -225,6 +236,44 @@        in dimSplices             <$> simplifyNewShape (Shape orig_shape) (NewShape ss res_shape) +unreshapeSliceTests :: TestTree+unreshapeSliceTests =+  testGroup+    "unreshapeSlice"+    [ testCase "Unflatten" $+        unreshape [6] [dimUnflatten 0 [2, 3]] [ix 1, ix 2]+          @?= Just [ix 5],+      testCase "Unflatten with untouched slice" $+        unreshape [4, 6, 5] [dimUnflatten 1 [2, 3]] [ix 1, ix 1, ix 2, DimSlice 0 5 1]+          @?= Just [ix 1, ix 5, DimSlice 0 5 1],+      testCase "Flatten" $+        unreshape [2, 3] [dimFlatten 0 2 6] [ix 5]+          @?= Just [ix 1, ix 2],+      testCase "Sliced flatten" $+        unreshape [2, 3] [dimFlatten 0 2 6] [DimSlice 0 6 1]+          @?= Nothing,+      testCase "Sliced coercion" $+        unreshape [4] [dimCoerce 0 4] [DimSlice 1 2 1]+          @?= Just [DimSlice 1 2 1],+      testCase "Flatten followed by unflatten" $+        unreshape [2, 3, 4] [dimFlatten 1 2 12, dimUnflatten 1 [3, 4]] [ix 1, ix 2, ix 3]+          @?= Just [ix 1, ix 2, ix 3],+      testCase "Complete reshape agrees with reshapeIndex" $+        unreshape [6, 4] [dimSplice 0 2 [4, 3, 2]] [ix 3, ix 2, ix 1]+          @?= Just (map ix $ reshapeIndex [6, 4] [4, 3, 2] [3, 2, 1])+    ]+  where+    ix = DimFix+    unreshape ::+      [Wrapped Int] ->+      [DimSplice (Wrapped Int)] ->+      [DimIndex (Wrapped Int)] ->+      Maybe [DimIndex (Wrapped Int)]+    unreshape shape ss =+      unreshapeSlice (Shape shape) $+        NewShape ss $+          L.foldl' applySplice (Shape shape) ss+ tests :: TestTree tests =   testGroup "ReshapeTests" . mconcat $@@ -232,5 +281,5 @@       reshapeInnerTests,       flipReshapeRearrangeTests,       flipRearrangeReshapeTests,-      [simplifyTests]+      [simplifyTests, unreshapeSliceTests]     ]
src-testing/Futhark/IR/Syntax/CoreTests.hs view
@@ -12,10 +12,10 @@ import Test.Tasty.HUnit import Prelude -instance Arbitrary NoUniqueness where-  arbitrary = pure NoUniqueness+instance Arbitrary NoMode where+  arbitrary = pure NoMode -instance (Arbitrary shape, Arbitrary u) => Arbitrary (TypeBase shape u) where+instance (Arbitrary shape, Arbitrary o) => Arbitrary (TypeBase shape o) where   arbitrary =     oneof       [ Prim <$> arbitrary,
src-testing/Futhark/IR/SyntaxTests.hs view
@@ -17,6 +17,9 @@ instance IsString Type where   fromString = parseString "Type" parseType +instance IsString ExtType where+  fromString = parseString "ExtType" parseExtType+ instance IsString DeclExtType where   fromString = parseString "DeclExtType" parseDeclExtType
src-testing/Futhark/Internalise/TypesValuesTests.hs view
@@ -1,11 +1,13 @@ module Futhark.Internalise.TypesValuesTests (tests) where  import Control.Monad.Free (Free (..))+import Data.Bifunctor (first, second) import Data.Map qualified as M import Data.String (fromString) import Futhark.IR.Syntax hiding (Free) import Futhark.IR.SyntaxTests () import Futhark.Internalise.TypesValues+import Language.Futhark qualified as E import Language.Futhark.SyntaxTests () import Test.Tasty import Test.Tasty.HUnit@@ -41,7 +43,7 @@   testGroup     "internaliseConstructors"     [ testCase "Dedup of primitives" $-        internaliseConstructors+        constrs           ( M.fromList               [ ("foo", [Pure "i64"]),                 ("bar", [Pure "i64"])@@ -53,7 +55,7 @@                 ]               ),       testCase "Dedup of array" $-        internaliseConstructors+        constrs           ( M.fromList               [ ("foo", [Pure "[?0]i64"]),                 ("bar", [Pure "[?0]i64"])@@ -66,7 +68,7 @@               ),       testCase         "Dedup of array of tuple"-        $ internaliseConstructors+        $ constrs           ( M.fromList               [ ("foo", [Free [Pure "[?0]i64", Pure "[?0]i64"]]),                 ("bar", [Pure "[?0]i64"])@@ -78,6 +80,9 @@                 ]               )     ]+  where+    constrs :: M.Map Name [Tree ExtType] -> ([Tree ExtType], [(Name, [Int])])+    constrs = internaliseConstructors  -- Be aware that some of these tests simply reinforce current -- behaviour - it may be that we want to restrict aliasing even@@ -153,12 +158,24 @@         ]     ]   where+    -- Result types are written with the source-level meaning of '*',+    -- i.e. fresh, but are parsed with the 'Diet' parser.+    asFreshness :: DeclExtType -> TypeBase ExtShape E.Freshness+    asFreshness = second f+      where+        f Consume = E.Fresh+        f Observe = E.Nonfresh+    mkTest ::+      [Tree String] ->+      [Tree String] ->+      [[(String, RetAls)]] ->+      TestTree     mkTest all_param_ts all_res_ts expected =       testCase (show all_param_ts <> " " <> show all_res_ts) $         inferAliases           (map (fmap fromString) all_param_ts)-          (map (fmap fromString) all_res_ts)-          @?= expected+          (map (fmap (asFreshness . fromString)) all_res_ts)+          @?= map (map (first (asFreshness . fromString))) expected  tests :: TestTree tests =
src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs view
@@ -220,7 +220,7 @@       \  let {segmap_group_size_5202 : i64} =\       \    get_size(segmap_group_size_5190, thread_block_size)\       \  let {segmap_usable_groups_5203 : i64} =\-      \    sdiv_up64(n_5142, segmap_group_size_5202)\+      \    sceil_div64(n_5142, segmap_group_size_5202)\       \  let {defunc_0_map_res_5204 : [n_5142]i64} =\       \    segmap(thread; ; grid=segmap_usable_groups_5203; blocksize=segmap_group_size_5202)\       \    (gtid_5205 < n_5142) (~phys_tid_5206) : {i64} {\
src-testing/Generated/AllFutBenchmarks/Accelerate/Nbody/Nbodybh.hs view
@@ -12,7 +12,7 @@     TyVars,   ) -(~) :: TypeBase () NoUniqueness -> TypeBase () NoUniqueness -> CtTy ()+(~) :: TypeBase () NoMode -> TypeBase () NoMode -> CtTy () t1 ~ t2 = CtEq (Reason mempty) t1 t2  type BenchmarkCaseData = ([CtTy ()], TyParams, TyVars ())@@ -692,7 +692,7 @@         "[]{delta_node: i32, left: #inner i32 | #leaf i32, parent: i32, right: #inner i32 | #leaf i32, sfc_code: u32}" ~ "[]x_8324_8325_8323"       ],       M.empty,-      M.fromList [("t_8320", (3, TyVarFree NoLoc Lifted)), ("t_8321", (3, TyVarFree NoLoc Lifted)), ("t_8322", (4, TyVarPrim NoLoc [Bool])), ("t_8323", (4, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329", (4, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8321", (4, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8322", (4, TyVarFree NoLoc Unlifted)), ("t_8322_8323", (5, TyVarFree NoLoc Lifted)), ("t_8322_8324", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8325", (6, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8326", (6, TyVarFree NoLoc Unlifted)), ("t_8322_8327", (7, TyVarFree NoLoc Lifted)), ("t_8322_8328", (8, TyVarFree NoLoc Unlifted)), ("t_8323_8323", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8324", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64])), ("t_8325_8320", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64])), ("if_t_8325_8327", (8, TyVarFree NoLoc SizeLifted)), ("num_8325_8328", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8329", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8326_8320", (4, TyVarFree NoLoc SizeLifted)), ("t_8326_8321", (3, TyVarFree NoLoc Lifted)), ("t_8326_8324", (5, TyVarFree NoLoc Lifted)), ("t_8326_8325", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8326", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8326_8327", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8327_8324", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8327_8325", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8328_8328", (7, TyVarFree NoLoc Lifted)), ("t_8328_8329", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8326", (9, TyVarFree NoLoc Lifted)), ("num_8329_8327", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8328", (10, TyVarFree NoLoc Lifted)), ("t_8329_8329", (10, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8320", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8321", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8321_8326", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8321_8327", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8322_8322", (11, TyVarFree NoLoc Lifted)), ("num_8321_8322_8323", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8322_8324", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8322_8325", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8320", (12, TyVarFree NoLoc Lifted)), ("t_8321_8323_8321", (12, TyVarFree NoLoc Lifted)), ("t_8321_8323_8322", (12, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8323_8323", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8328", (12, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8329", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8324_8320", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8324_8321", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8326_8320", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8326_8325", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8326_8326", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327_8321", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8327_8322", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8321_8327_8327", (12, TyVarFree NoLoc SizeLifted)), ("t_8321_8327_8328", (13, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329", (13, TyVarFree NoLoc Lifted)), ("t_8321_8328_8320", (14, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8328_8321", (14, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8329_8320", (15, TyVarFree NoLoc Lifted)), ("t_8321_8329_8323", (17, TyVarFree NoLoc Lifted)), ("num_8321_8329_8324", (18, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8329_8325", (18, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8329_8326", (18, TyVarFree NoLoc Lifted)), ("t_8321_8329_8327", (18, TyVarFree NoLoc Lifted)), ("t_8321_8329_8328", (18, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8323", (18, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8320_8324", (18, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8323", (19, TyVarFree NoLoc Lifted)), ("t_8322_8321_8324", (20, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8325", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8326", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8327", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8323_8326", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8321", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8324_8322", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8327", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8324_8328", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8322_8325_8323", (20, TyVarFree NoLoc SizeLifted)), ("t_8322_8325_8324", (19, TyVarFree NoLoc Lifted)), ("t_8322_8325_8325", (19, TyVarFree NoLoc Lifted)), ("t_8322_8325_8326", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8325_8327", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8325_8328", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8326_8327", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8327_8326", (21, TyVarFree NoLoc Lifted)), ("t_8322_8327_8327", (22, TyVarFree NoLoc Unlifted)), ("t_8322_8328_8326", (22, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8322_8327_8326" 14782}) [])])]))), ("num_8322_8328_8327", (22, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8328_8328", (22, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8328_8329", (22, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8322_8327_8326" 14782}) [])])]))), ("if_t_8322_8329_8320", (22, TyVarFree NoLoc SizeLifted)), ("t_8322_8329_8321", (23, TyVarFree NoLoc Lifted)), ("t_8322_8329_8322", (23, TyVarFree NoLoc Lifted)), ("t_8322_8329_8323", (24, TyVarFree NoLoc Unlifted)), ("t_8322_8329_8328", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8329_8329", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8320_8328", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8320_8329", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8321_8324", (24, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8323_8320_8328" 14819}) [])])]))), ("num_8323_8321_8325", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8321_8326", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8321_8327", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8321_8328", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8322_8323", (24, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8323_8321_8327" 14829}) [])])]))), ("t_8323_8322_8324", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8322_8325", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8323_8323_8320", (24, TyVarFree NoLoc SizeLifted)), ("t_8323_8323_8321", (25, TyVarFree NoLoc Lifted)), ("t_8323_8323_8322", (25, TyVarFree NoLoc Lifted)), ("t_8323_8323_8323", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64])), ("t_8323_8323_8324", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8323_8325", (26, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8323_8326", (26, TyVarFree NoLoc Unlifted)), ("t_8323_8323_8327", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8328", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8324_8329", (27, TyVarFree NoLoc Lifted)), ("a_8323_8325_8320", (2, TyVarFree NoLoc Lifted)), ("b_8323_8325_8321", (2, TyVarFree NoLoc Lifted)), ("a_8323_8325_8322", (2, TyVarFree NoLoc Unlifted)), ("t_8323_8325_8323", (2, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8325_8324", (2, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("a_8323_8326_8323", (2, TyVarFree NoLoc Unlifted)), ("b_8323_8326_8324", (2, TyVarFree NoLoc Unlifted)), ("c_8323_8326_8325", (2, TyVarFree NoLoc Unlifted)), ("t_8323_8327_8320", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8321", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8322", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8323", (4, TyVarFree NoLoc Unlifted)), ("t_8323_8327_8324", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8327_8325", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8328_8320", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8328_8321", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8328_8322", (4, TyVarFree NoLoc Unlifted)), ("a_8323_8328_8323", (4, TyVarFree NoLoc Unlifted)), ("x_8323_8328_8324", (4, TyVarFree NoLoc Unlifted)), ("a_8323_8328_8325", (4, TyVarFree NoLoc Lifted)), ("b_8323_8328_8326", (4, TyVarFree NoLoc Lifted)), ("c_8323_8328_8327", (4, TyVarFree NoLoc Lifted)), ("a_8323_8328_8328", (4, TyVarFree NoLoc Lifted)), ("b_8323_8328_8329", (4, TyVarFree NoLoc Lifted)), ("ft_8323_8329_8320", (4, TyVarRecord NoLoc (M.fromList [("0", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8323_8328_8329" 14921}) []))]))), ("a_8323_8329_8329", (4, TyVarFree NoLoc Unlifted)), ("x_8324_8320_8320", (4, TyVarFree NoLoc Unlifted)), ("a_8324_8320_8321", (4, TyVarFree NoLoc Lifted)), ("b_8324_8320_8322", (4, TyVarFree NoLoc Lifted)), ("c_8324_8320_8323", (4, TyVarFree NoLoc Lifted)), ("a_8324_8320_8324", (4, TyVarFree NoLoc Lifted)), ("b_8324_8320_8325", (4, TyVarFree NoLoc Lifted)), ("ft_8324_8320_8326", (4, TyVarRecord NoLoc (M.fromList [("0", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8324_8320_8325" 14941}) []))]))), ("t_8324_8321_8329", (4, TyVarFree NoLoc Unlifted)), ("a_8324_8322_8320", (4, TyVarFree NoLoc Unlifted)), ("x_8324_8322_8321", (4, TyVarFree NoLoc Unlifted)), ("a_8324_8322_8322", (4, TyVarFree NoLoc Lifted)), ("b_8324_8322_8323", (4, TyVarFree NoLoc Lifted)), ("ft_8324_8322_8324", (4, TyVarRecord NoLoc (M.fromList [("1", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8324_8322_8323" 14967}) []))]))), ("a_8324_8322_8329", (4, TyVarFree NoLoc Unlifted)), ("x_8324_8323_8320", (4, TyVarFree NoLoc Unlifted)), ("a_8324_8323_8321", (4, TyVarFree NoLoc Lifted)), ("b_8324_8323_8322", (4, TyVarFree NoLoc Lifted)), ("ft_8324_8323_8323", (4, TyVarRecord NoLoc (M.fromList [("1", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8324_8323_8322" 14979}) []))]))), ("t_8324_8325_8320", (5, TyVarFree NoLoc Lifted)), ("a_8324_8325_8321", (6, TyVarFree NoLoc Unlifted)), ("b_8324_8325_8322", (6, TyVarFree NoLoc Unlifted)), ("x_8324_8325_8323", (6, TyVarFree NoLoc Unlifted)), ("t_8324_8325_8324", (7, TyVarFree NoLoc Lifted)), ("t_8324_8325_8325", (7, TyVarFree NoLoc Lifted)), ("t_8324_8325_8326", (7, TyVarFree NoLoc Lifted)), ("t_8324_8325_8327", (7, TyVarFree NoLoc Lifted)), ("t_8324_8325_8328", (8, TyVarFree NoLoc Lifted)), ("t_8324_8325_8320_8324_8326_8326", (5, TyVarFree NoLoc Lifted)), ("t_8323_8327_8320_8324_8326_8327", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8322_8324_8326_8328", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8321_8324_8326_8329", (3, TyVarFree NoLoc Lifted)), ("a_8323_8325_8320_8324_8327_8320", (2, TyVarFree NoLoc Lifted))]+      M.fromList [("t_8320", (3, TyVarFree NoLoc Lifted)), ("t_8321", (3, TyVarFree NoLoc Lifted)), ("t_8322", (4, TyVarPrim NoLoc [Bool])), ("t_8323", (4, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329", (4, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8321", (4, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8322", (4, TyVarFree NoLoc Unlifted)), ("t_8322_8323", (5, TyVarFree NoLoc Lifted)), ("t_8322_8324", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8325", (6, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8326", (6, TyVarFree NoLoc Unlifted)), ("t_8322_8327", (7, TyVarFree NoLoc Lifted)), ("t_8322_8328", (8, TyVarFree NoLoc Unlifted)), ("t_8323_8323", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8324", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64])), ("t_8325_8320", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64])), ("if_t_8325_8327", (8, TyVarFree NoLoc SizeLifted)), ("num_8325_8328", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8329", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8326_8320", (4, TyVarFree NoLoc SizeLifted)), ("t_8326_8321", (3, TyVarFree NoLoc Lifted)), ("t_8326_8324", (5, TyVarFree NoLoc Lifted)), ("t_8326_8325", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8326", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8326_8327", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8327_8324", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8327_8325", (6, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8328_8328", (7, TyVarFree NoLoc Lifted)), ("t_8328_8329", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8326", (9, TyVarFree NoLoc Lifted)), ("num_8329_8327", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8328", (10, TyVarFree NoLoc Lifted)), ("t_8329_8329", (10, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8320", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8321", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8321_8326", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8321_8327", (10, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8322_8322", (11, TyVarFree NoLoc Lifted)), ("num_8321_8322_8323", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8322_8324", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8322_8325", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8320", (12, TyVarFree NoLoc Lifted)), ("t_8321_8323_8321", (12, TyVarFree NoLoc Lifted)), ("t_8321_8323_8322", (12, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8323_8323", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8328", (12, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8329", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8324_8320", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8324_8321", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8326_8320", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8326_8325", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8326_8326", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327_8321", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8327_8322", (12, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8321_8327_8327", (12, TyVarFree NoLoc SizeLifted)), ("t_8321_8327_8328", (13, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329", (13, TyVarFree NoLoc Lifted)), ("t_8321_8328_8320", (14, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8328_8321", (14, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8329_8320", (15, TyVarFree NoLoc Lifted)), ("t_8321_8329_8323", (17, TyVarFree NoLoc Lifted)), ("num_8321_8329_8324", (18, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8329_8325", (18, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8329_8326", (18, TyVarFree NoLoc Lifted)), ("t_8321_8329_8327", (18, TyVarFree NoLoc Lifted)), ("t_8321_8329_8328", (18, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8323", (18, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8320_8324", (18, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8323", (19, TyVarFree NoLoc Lifted)), ("t_8322_8321_8324", (20, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8325", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8326", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8327", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8323_8326", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8321", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8324_8322", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8327", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8324_8328", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8322_8325_8323", (20, TyVarFree NoLoc SizeLifted)), ("t_8322_8325_8324", (19, TyVarFree NoLoc Lifted)), ("t_8322_8325_8325", (19, TyVarFree NoLoc Lifted)), ("t_8322_8325_8326", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8325_8327", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8325_8328", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8326_8327", (20, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8327_8326", (21, TyVarFree NoLoc Lifted)), ("t_8322_8327_8327", (22, TyVarFree NoLoc Unlifted)), ("t_8322_8328_8326", (22, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8322_8327_8326" 14782}) [])])]))), ("num_8322_8328_8327", (22, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8328_8328", (22, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8328_8329", (22, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8322_8327_8326" 14782}) [])])]))), ("if_t_8322_8329_8320", (22, TyVarFree NoLoc SizeLifted)), ("t_8322_8329_8321", (23, TyVarFree NoLoc Lifted)), ("t_8322_8329_8322", (23, TyVarFree NoLoc Lifted)), ("t_8322_8329_8323", (24, TyVarFree NoLoc Unlifted)), ("t_8322_8329_8328", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8329_8329", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8320_8328", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8320_8329", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8321_8324", (24, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8323_8320_8328" 14819}) [])])]))), ("num_8323_8321_8325", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8321_8326", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8321_8327", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8321_8328", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8322_8323", (24, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8323_8321_8327" 14829}) [])])]))), ("t_8323_8322_8324", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8322_8325", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8323_8323_8320", (24, TyVarFree NoLoc SizeLifted)), ("t_8323_8323_8321", (25, TyVarFree NoLoc Lifted)), ("t_8323_8323_8322", (25, TyVarFree NoLoc Lifted)), ("t_8323_8323_8323", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64])), ("t_8323_8323_8324", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8323_8325", (26, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8323_8326", (26, TyVarFree NoLoc Unlifted)), ("t_8323_8323_8327", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8328", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8324_8329", (27, TyVarFree NoLoc Lifted)), ("a_8323_8325_8320", (2, TyVarFree NoLoc Lifted)), ("b_8323_8325_8321", (2, TyVarFree NoLoc Lifted)), ("a_8323_8325_8322", (2, TyVarFree NoLoc Unlifted)), ("t_8323_8325_8323", (2, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8325_8324", (2, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("a_8323_8326_8323", (2, TyVarFree NoLoc Unlifted)), ("b_8323_8326_8324", (2, TyVarFree NoLoc Unlifted)), ("c_8323_8326_8325", (2, TyVarFree NoLoc Unlifted)), ("t_8323_8327_8320", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8321", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8322", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8323", (4, TyVarFree NoLoc Unlifted)), ("t_8323_8327_8324", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8327_8325", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8328_8320", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8328_8321", (4, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8328_8322", (4, TyVarFree NoLoc Unlifted)), ("a_8323_8328_8323", (4, TyVarFree NoLoc Unlifted)), ("x_8323_8328_8324", (4, TyVarFree NoLoc Unlifted)), ("a_8323_8328_8325", (4, TyVarFree NoLoc Lifted)), ("b_8323_8328_8326", (4, TyVarFree NoLoc Lifted)), ("c_8323_8328_8327", (4, TyVarFree NoLoc Lifted)), ("a_8323_8328_8328", (4, TyVarFree NoLoc Lifted)), ("b_8323_8328_8329", (4, TyVarFree NoLoc Lifted)), ("ft_8323_8329_8320", (4, TyVarRecord NoLoc (M.fromList [("0", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8323_8328_8329" 14921}) []))]))), ("a_8323_8329_8329", (4, TyVarFree NoLoc Unlifted)), ("x_8324_8320_8320", (4, TyVarFree NoLoc Unlifted)), ("a_8324_8320_8321", (4, TyVarFree NoLoc Lifted)), ("b_8324_8320_8322", (4, TyVarFree NoLoc Lifted)), ("c_8324_8320_8323", (4, TyVarFree NoLoc Lifted)), ("a_8324_8320_8324", (4, TyVarFree NoLoc Lifted)), ("b_8324_8320_8325", (4, TyVarFree NoLoc Lifted)), ("ft_8324_8320_8326", (4, TyVarRecord NoLoc (M.fromList [("0", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8324_8320_8325" 14941}) []))]))), ("t_8324_8321_8329", (4, TyVarFree NoLoc Unlifted)), ("a_8324_8322_8320", (4, TyVarFree NoLoc Unlifted)), ("x_8324_8322_8321", (4, TyVarFree NoLoc Unlifted)), ("a_8324_8322_8322", (4, TyVarFree NoLoc Lifted)), ("b_8324_8322_8323", (4, TyVarFree NoLoc Lifted)), ("ft_8324_8322_8324", (4, TyVarRecord NoLoc (M.fromList [("1", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8324_8322_8323" 14967}) []))]))), ("a_8324_8322_8329", (4, TyVarFree NoLoc Unlifted)), ("x_8324_8323_8320", (4, TyVarFree NoLoc Unlifted)), ("a_8324_8323_8321", (4, TyVarFree NoLoc Lifted)), ("b_8324_8323_8322", (4, TyVarFree NoLoc Lifted)), ("ft_8324_8323_8323", (4, TyVarRecord NoLoc (M.fromList [("1", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8324_8323_8322" 14979}) []))]))), ("t_8324_8325_8320", (5, TyVarFree NoLoc Lifted)), ("a_8324_8325_8321", (6, TyVarFree NoLoc Unlifted)), ("b_8324_8325_8322", (6, TyVarFree NoLoc Unlifted)), ("x_8324_8325_8323", (6, TyVarFree NoLoc Unlifted)), ("t_8324_8325_8324", (7, TyVarFree NoLoc Lifted)), ("t_8324_8325_8325", (7, TyVarFree NoLoc Lifted)), ("t_8324_8325_8326", (7, TyVarFree NoLoc Lifted)), ("t_8324_8325_8327", (7, TyVarFree NoLoc Lifted)), ("t_8324_8325_8328", (8, TyVarFree NoLoc Lifted)), ("t_8324_8325_8320_8324_8326_8326", (5, TyVarFree NoLoc Lifted)), ("t_8323_8327_8320_8324_8326_8327", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8322_8324_8326_8328", (3, TyVarFree NoLoc Lifted)), ("t_8323_8327_8321_8324_8326_8329", (3, TyVarFree NoLoc Lifted)), ("a_8323_8325_8320_8324_8327_8320", (2, TyVarFree NoLoc Lifted))]     ),     ( [ "t_8326_8325_8325" ~ "[]t_8326_8325_8325_8326_8325_8327",         "t_8322_8320_8326" ~ "[]t_8322_8320_8326_8326_8325_8328",@@ -1097,7 +1097,7 @@         "[]{body: {mass: f32, position: {x: f32, y: f32, z: f32}, velocity: {x: f32, y: f32, z: f32}}, children: []i32, is_leaf: bool, parent: i32, tree_level: i32}" ~ "t_8326_8325_8325"       ],       M.empty,-      M.fromList [("num_8320", (3, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321", (3, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322", (3, TyVarFree NoLoc Unlifted)), ("index_elem_8323", (3, TyVarFree NoLoc Unlifted)), ("kt_8324", (3, TyVarFree NoLoc Lifted)), ("t_8325", (3, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8324" 15206}) []))]))), ("t_8326", (4, TyVarFree NoLoc Lifted)), ("t_8327", (6, TyVarFree NoLoc Lifted)), ("t_8328", (7, TyVarFree NoLoc Lifted)), ("t_8329", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8321", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8326", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8327", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8326", (6, TyVarFree NoLoc Lifted)), ("t_8322_8327", (7, TyVarFree NoLoc Lifted)), ("t_8322_8328", (7, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8322_8327" 15232}) [])])]))), ("t_8322_8329", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8320", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325", (7, TyVarFree NoLoc Lifted)), ("t_8323_8326", (7, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8323_8325" 15241}) [])])]))), ("t_8323_8327", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8328", (7, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8329", (7, TyVarFree NoLoc Unlifted)), ("kt_8324_8320", (7, TyVarFree NoLoc Lifted)), ("t_8324_8321", (7, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8320" 15247}) []))]))), ("match_t_8324_8322", (7, TyVarFree NoLoc SizeLifted)), ("a_8324_8323", (5, TyVarFree NoLoc Unlifted)), ("x_8324_8324", (5, TyVarFree NoLoc Unlifted)), ("t_8324_8325", (6, TyVarFree NoLoc Lifted)), ("kt_8324_8326", (7, TyVarFree NoLoc Lifted)), ("t_8324_8327", (7, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8326" 15255}) []))]))), ("kt_8325_8320", (7, TyVarFree NoLoc Lifted)), ("t_8325_8321", (7, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8320" 15260}) []))]))), ("t_8325_8326", (8, TyVarFree NoLoc Lifted)), ("kt_8325_8327", (9, TyVarFree NoLoc Lifted)), ("t_8325_8328", (9, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8327" 15268}) []))]))), ("kt_8326_8321", (9, TyVarFree NoLoc Lifted)), ("t_8326_8322", (9, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8326_8321" 15273}) []))]))), ("t_8326_8327", (10, TyVarFree NoLoc Lifted)), ("t_8327_8322", (6, TyVarFree NoLoc Lifted)), ("a_8327_8323", (7, TyVarFree NoLoc Lifted)), ("b_8327_8324", (7, TyVarFree NoLoc Lifted)), ("a_8327_8325", (7, TyVarFree NoLoc Lifted)), ("b_8327_8326", (7, TyVarFree NoLoc Lifted)), ("a_8327_8327", (7, TyVarFree NoLoc Unlifted)), ("x_8327_8328", (7, TyVarFree NoLoc Unlifted)), ("t_8327_8329", (8, TyVarFree NoLoc Lifted)), ("t_8328_8320", (8, TyVarFree NoLoc Lifted)), ("t_8328_8321", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8328_8322", (9, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8328_8323", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8320", (9, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8329_8321", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("a_8321_8320_8328", (7, TyVarFree NoLoc Unlifted)), ("t_8321_8320_8329", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8321_8320", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8321_8329", (8, TyVarFree NoLoc Lifted)), ("t_8321_8322_8320", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8322_8321", (9, TyVarFree NoLoc Unlifted)), ("num_8321_8322_8326", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8321", (10, TyVarFree NoLoc Lifted)), ("a_8321_8323_8322", (11, TyVarFree NoLoc Unlifted)), ("x_8321_8323_8323", (11, TyVarFree NoLoc Unlifted)), ("t_8321_8323_8324", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8323_8325", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8326", (11, TyVarFree NoLoc Lifted)), ("t_8321_8324_8321", (11, TyVarFree NoLoc Unlifted)), ("num_8321_8324_8322", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8324_8323", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8325_8322", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8325_8323", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8321_8325_8324", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8321_8325_8325", (11, TyVarFree NoLoc Unlifted)), ("t_8321_8325_8326", (12, TyVarFree NoLoc Lifted)), ("a_8321_8325_8327", (13, TyVarFree NoLoc Lifted)), ("b_8321_8325_8328", (13, TyVarFree NoLoc Lifted)), ("a_8321_8325_8329", (13, TyVarFree NoLoc Unlifted)), ("x_8321_8326_8320", (13, TyVarFree NoLoc Unlifted)), ("t_8321_8326_8321", (14, TyVarFree NoLoc Lifted)), ("num_8321_8326_8324", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8326_8325", (13, TyVarFree NoLoc Unlifted)), ("a_8321_8327_8322", (13, TyVarFree NoLoc Unlifted)), ("b_8321_8327_8323", (13, TyVarFree NoLoc Unlifted)), ("t_8321_8327_8328", (14, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329", (14, TyVarFree NoLoc Lifted)), ("a_8321_8328_8320", (15, TyVarFree NoLoc Lifted)), ("b_8321_8328_8321", (15, TyVarFree NoLoc Lifted)), ("a_8321_8328_8322", (15, TyVarFree NoLoc Unlifted)), ("t_8321_8328_8323", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8328_8324", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("a_8321_8329_8325", (15, TyVarFree NoLoc Unlifted)), ("t_8321_8329_8326", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8329_8327", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8326", (16, TyVarFree NoLoc Lifted)), ("a_8322_8320_8327", (17, TyVarFree NoLoc Unlifted)), ("b_8322_8320_8328", (17, TyVarFree NoLoc Unlifted)), ("x_8322_8320_8329", (17, TyVarFree NoLoc Unlifted)), ("t_8322_8321_8320", (18, TyVarFree NoLoc Lifted)), ("t_8322_8321_8321", (19, TyVarFree NoLoc Lifted)), ("t_8322_8321_8324", (21, TyVarFree NoLoc Lifted)), ("t_8322_8321_8325", (22, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8321_8326", (22, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8321_8327", (22, TyVarFree NoLoc Unlifted)), ("t_8322_8321_8328", (23, TyVarFree NoLoc Lifted)), ("t_8322_8321_8329", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8322_8320", (24, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8322_8321", (24, TyVarFree NoLoc Unlifted)), ("t_8322_8322_8322", (25, TyVarFree NoLoc Lifted)), ("t_8322_8322_8323", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8322_8324", (26, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8322_8325", (26, TyVarFree NoLoc Unlifted)), ("t_8322_8322_8326", (27, TyVarFree NoLoc Lifted)), ("t_8322_8322_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8322_8328", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8322_8329", (28, TyVarFree NoLoc Lifted)), ("t_8322_8323_8320", (28, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8322_8329" 15494}) []))]))), ("num_8322_8323_8321", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8323_8326", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8323_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8326", (29, TyVarFree NoLoc Lifted)), ("kt_8322_8324_8327", (30, TyVarFree NoLoc Lifted)), ("t_8322_8324_8328", (30, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8324_8327" 15515}) []))]))), ("t_8322_8324_8329", (31, TyVarFree NoLoc Lifted)), ("t_8322_8325_8320", (32, TyVarPrim NoLoc [Bool])), ("t_8322_8325_8321", (32, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8325_8322", (32, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8325_8327", (32, TyVarFree NoLoc Unlifted)), ("t_8322_8326_8326", (33, TyVarFree NoLoc Lifted)), ("t_8322_8326_8327", (34, TyVarFree NoLoc Unlifted)), ("num_8322_8326_8328", (34, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8327_8323", (34, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8327_8324", (34, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8327_8325", (34, TyVarFree NoLoc Lifted)), ("t_8322_8327_8326", (34, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8327_8325" 15547}) []))]))), ("if_t_8322_8327_8327", (34, TyVarFree NoLoc SizeLifted)), ("if_t_8322_8328_8322", (34, TyVarFree NoLoc SizeLifted)), ("t_8322_8328_8323", (35, TyVarFree NoLoc Lifted)), ("kt_8322_8328_8324", (36, TyVarFree NoLoc Lifted)), ("t_8322_8328_8325", (36, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8328_8324" 15557}) []))]))), ("kt_8322_8328_8326", (36, TyVarFree NoLoc Lifted)), ("t_8322_8328_8327", (36, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8328_8326" 15559}) []))]))), ("if_t_8322_8328_8328", (36, TyVarFree NoLoc SizeLifted)), ("t_8322_8328_8329", (37, TyVarFree NoLoc Lifted)), ("t_8322_8329_8320", (38, TyVarPrim NoLoc [Bool])), ("t_8322_8329_8321", (38, TyVarFree NoLoc Unlifted)), ("num_8322_8329_8322", (38, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8329_8327", (38, TyVarFree NoLoc Lifted)), ("t_8322_8329_8328", (38, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8322_8329_8327" 15571}) [])])]))), ("t_8322_8329_8329", (38, TyVarFree NoLoc Lifted)), ("t_8323_8320_8320", (38, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8322_8329_8329" 15573}) [])])]))), ("match_t_8323_8320_8321", (38, TyVarFree NoLoc SizeLifted)), ("t_8323_8320_8326", (39, TyVarFree NoLoc Lifted)), ("t_8323_8320_8327", (41, TyVarFree NoLoc Lifted)), ("t_8323_8320_8328", (42, TyVarFree NoLoc Lifted)), ("t_8323_8320_8329", (42, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8323_8320_8328" 15583}) [])])]))), ("t_8323_8321_8320", (42, TyVarFree NoLoc Lifted)), ("t_8323_8321_8321", (42, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8323_8321_8320" 15585}) [])])]))), ("match_t_8323_8321_8322", (42, TyVarFree NoLoc SizeLifted)), ("t_8323_8321_8325", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8321_8326", (40, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8321_8327", (40, TyVarFree NoLoc Unlifted)), ("t_8323_8321_8328", (41, TyVarFree NoLoc Lifted)), ("kt_8323_8321_8329", (42, TyVarFree NoLoc Lifted)), ("t_8323_8322_8320", (42, TyVarRecord NoLoc (M.fromList [("mass", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8321_8329" 15596}) []))]))), ("kt_8323_8322_8321", (42, TyVarFree NoLoc Lifted)), ("t_8323_8322_8322", (42, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8322_8321" 15598}) []))]))), ("ft_8323_8322_8327", (42, TyVarRecord NoLoc (M.fromList [("position", Scalar (Record (M.fromList [("x", Scalar (Prim (FloatType Float32))), ("y", Scalar (Prim (FloatType Float32))), ("z", Scalar (Prim (FloatType Float32)))])))]))), ("num_8323_8322_8328", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8322_8329", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8320", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("float_8323_8323_8323", (40, TyVarPrim NoLoc [FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8324", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8325", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8326", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8323_8323_8329", (40, TyVarFree NoLoc SizeLifted)), ("t_8323_8324_8320", (41, TyVarFree NoLoc Lifted)), ("t_8323_8324_8321", (42, TyVarFree NoLoc Unlifted)), ("num_8323_8324_8322", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8324_8327", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8324_8328", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8324_8329", (43, TyVarFree NoLoc Lifted)), ("num_8323_8325_8320", (44, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325_8321", (44, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325_8322", (45, TyVarFree NoLoc Lifted)), ("t_8323_8325_8323", (46, TyVarFree NoLoc Lifted)), ("t_8323_8325_8324", (46, TyVarFree NoLoc Lifted)), ("t_8323_8325_8325", (46, TyVarFree NoLoc Unlifted)), ("num_8323_8325_8326", (46, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325_8327", (46, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8326_8322", (46, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8326_8323", (46, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8326_8324", (46, TyVarFree NoLoc Unlifted)), ("kt_8323_8326_8325", (46, TyVarFree NoLoc Lifted)), ("t_8323_8326_8326", (46, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8326_8325" 15648}) []))]))), ("t_8323_8326_8327", (47, TyVarFree NoLoc Lifted)), ("t_8323_8326_8328", (48, TyVarFree NoLoc Unlifted)), ("num_8323_8326_8329", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8327_8320", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8327_8325", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8327_8326", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8327_8327", (48, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8327_8328", (48, TyVarFree NoLoc Unlifted)), ("kt_8323_8327_8329", (48, TyVarFree NoLoc Lifted)), ("t_8323_8328_8320", (48, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8327_8329" 15664}) []))]))), ("t_8323_8328_8323", (49, TyVarFree NoLoc Lifted)), ("t_8323_8328_8324", (50, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8328_8325", (50, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8328_8326", (50, TyVarFree NoLoc Unlifted)), ("t_8323_8328_8327", (51, TyVarFree NoLoc Lifted)), ("t_8323_8328_8328", (52, TyVarFree NoLoc Unlifted)), ("t_8323_8329_8323", (53, TyVarFree NoLoc Lifted)), ("kt_8323_8329_8324", (54, TyVarFree NoLoc Lifted)), ("t_8323_8329_8325", (54, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8329_8324" 15681}) []))]))), ("kt_8323_8329_8326", (54, TyVarFree NoLoc Lifted)), ("t_8323_8329_8327", (54, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8329_8326" 15683}) []))]))), ("if_t_8323_8329_8328", (54, TyVarFree NoLoc SizeLifted)), ("t_8323_8329_8329", (55, TyVarFree NoLoc Lifted)), ("t_8324_8320_8320", (56, TyVarFree NoLoc Unlifted)), ("num_8324_8320_8321", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8320_8326", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8320_8327", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8320_8328", (56, TyVarFree NoLoc Unlifted)), ("t_8324_8320_8329", (57, TyVarFree NoLoc Lifted)), ("t_8324_8321_8320", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8321_8321", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8321_8322", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8321_8323", (58, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8324_8321_8324", (58, TyVarFree NoLoc Lifted)), ("t_8324_8321_8325", (58, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8321_8324" 15702}) []))]))), ("num_8324_8321_8326", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8324_8323_8321", (58, TyVarFree NoLoc SizeLifted)), ("if_t_8324_8323_8322", (56, TyVarFree NoLoc SizeLifted)), ("if_t_8324_8323_8323", (48, TyVarFree NoLoc SizeLifted)), ("t_8324_8323_8324", (47, TyVarFree NoLoc Lifted)), ("t_8324_8323_8325", (47, TyVarFree NoLoc Lifted)), ("if_t_8324_8323_8326", (42, TyVarFree NoLoc SizeLifted)), ("t_8324_8323_8327", (43, TyVarFree NoLoc Lifted)), ("num_8324_8323_8328", (44, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8323_8329", (44, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8324_8320", (46, TyVarFree NoLoc Unlifted)), ("num_8324_8324_8321", (46, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8324_8326", (47, TyVarFree NoLoc Lifted)), ("t_8324_8324_8327", (48, TyVarFree NoLoc Unlifted)), ("num_8324_8324_8328", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8325_8323", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8324_8325_8326", (48, TyVarFree NoLoc SizeLifted)), ("t_8324_8325_8327", (49, TyVarFree NoLoc Lifted)), ("num_8324_8325_8328", (50, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("et_8324_8325_8329", (52, TyVarFree NoLoc Unlifted)), ("num_8324_8326_8320", (52, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8326_8321", (52, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8326_8322", (52, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8326_8323", (53, TyVarFree NoLoc Lifted)), ("num_8324_8326_8324", (54, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8326_8325", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8326", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8327", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8328", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8329", (56, TyVarFree NoLoc Lifted)), ("t_8324_8327_8320", (56, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8327_8321", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8327_8322", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8327_8323", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8327_8324", (56, TyVarFree NoLoc Unlifted)), ("num_8324_8327_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8328_8320", (56, TyVarFree NoLoc Unlifted)), ("t_8324_8328_8321", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8328_8322", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8328_8323", (56, TyVarFree NoLoc Unlifted)), ("num_8324_8328_8324", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8328_8329", (56, TyVarFree NoLoc Unlifted)), ("t_8324_8329_8320", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8329_8321", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8329_8322", (56, TyVarFree NoLoc Unlifted)), ("kt_8324_8329_8323", (56, TyVarFree NoLoc Lifted)), ("t_8324_8329_8324", (56, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8329_8323" 15791}) []))]))), ("num_8324_8329_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8320_8320", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8320_8321", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8320_8322", (56, TyVarFree NoLoc Unlifted)), ("t_8325_8320_8323", (57, TyVarFree NoLoc Lifted)), ("t_8325_8320_8324", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("update_elem_8325_8320_8325", (58, TyVarFree NoLoc Unlifted)), ("t_8325_8320_8326", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8320_8327", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8321_8322", (59, TyVarFree NoLoc Lifted)), ("t_8325_8321_8323", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8325_8321_8324", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8325_8321_8325", (60, TyVarFree NoLoc Unlifted)), ("t_8325_8321_8326", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8321_8327", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8321_8328", (56, TyVarFree NoLoc Unlifted)), ("kt_8325_8321_8329", (56, TyVarFree NoLoc Lifted)), ("t_8325_8322_8320", (56, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8321_8329" 15820}) []))]))), ("t_8325_8322_8323", (57, TyVarFree NoLoc Lifted)), ("t_8325_8322_8324", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8322_8325", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8323_8320", (59, TyVarFree NoLoc Lifted)), ("t_8325_8323_8321", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8325_8323_8322", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8325_8323_8323", (60, TyVarFree NoLoc Unlifted)), ("if_t_8325_8323_8324", (56, TyVarFree NoLoc SizeLifted)), ("t_8325_8323_8325", (56, TyVarFree NoLoc Unlifted)), ("t_8325_8323_8326", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8323_8327", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8323_8328", (56, TyVarFree NoLoc Unlifted)), ("num_8325_8323_8329", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8324_8324", (56, TyVarFree NoLoc Unlifted)), ("t_8325_8324_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8324_8326", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8324_8327", (56, TyVarFree NoLoc Unlifted)), ("kt_8325_8324_8328", (56, TyVarFree NoLoc Lifted)), ("t_8325_8324_8329", (56, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8324_8328" 15852}) []))]))), ("num_8325_8325_8320", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8325_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8325_8326", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8325_8327", (56, TyVarFree NoLoc Unlifted)), ("t_8325_8325_8328", (57, TyVarFree NoLoc Lifted)), ("t_8325_8325_8329", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("t_8325_8326_8320", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8326_8321", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8326_8322", (58, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8326_8323", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8326_8324", (58, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8326_8325", (58, TyVarFree NoLoc Unlifted)), ("kt_8325_8326_8326", (58, TyVarFree NoLoc Lifted)), ("t_8325_8326_8327", (58, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8326_8326" 15871}) []))]))), ("num_8325_8326_8328", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8327_8325", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8325_8328_8324", (58, TyVarFree NoLoc Unlifted)), ("t_8325_8328_8325", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8328_8326", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8329_8321", (59, TyVarFree NoLoc Lifted)), ("t_8325_8329_8322", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8325_8329_8323", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8325_8329_8324", (60, TyVarFree NoLoc Unlifted)), ("t_8325_8329_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8329_8326", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8329_8327", (56, TyVarFree NoLoc Unlifted)), ("kt_8325_8329_8328", (56, TyVarFree NoLoc Lifted)), ("t_8325_8329_8329", (56, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8329_8328" 15909}) []))]))), ("t_8326_8320_8322", (57, TyVarFree NoLoc Lifted)), ("t_8326_8320_8323", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8326_8320_8324", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8320_8329", (59, TyVarFree NoLoc Lifted)), ("t_8326_8321_8320", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8326_8321_8321", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8326_8321_8322", (60, TyVarFree NoLoc Unlifted)), ("if_t_8326_8321_8323", (56, TyVarFree NoLoc SizeLifted)), ("t_8326_8321_8324", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8326_8321_8325", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8326_8321_8326", (56, TyVarFree NoLoc Unlifted)), ("kt_8326_8321_8327", (56, TyVarFree NoLoc Lifted)), ("t_8326_8321_8328", (56, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8326_8321_8327" 15931}) []))]))), ("t_8326_8321_8329", (57, TyVarFree NoLoc Lifted)), ("t_8326_8322_8320", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8326_8322_8321", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8322_8326", (59, TyVarFree NoLoc Lifted)), ("t_8326_8322_8327", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("t_8326_8322_8328", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8322_8329", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8326_8323_8320", (60, TyVarFree NoLoc Unlifted)), ("index_elem_8326_8323_8321", (60, TyVarFree NoLoc Unlifted)), ("num_8326_8323_8322", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8326_8323_8327", (60, TyVarFree NoLoc Unlifted)), ("if_t_8326_8323_8328", (56, TyVarFree NoLoc SizeLifted)), ("if_t_8326_8323_8329", (56, TyVarFree NoLoc SizeLifted)), ("t_8326_8324_8320", (57, TyVarFree NoLoc Lifted)), ("t_8326_8324_8321", (57, TyVarFree NoLoc Lifted)), ("t_8326_8324_8322", (57, TyVarFree NoLoc Lifted)), ("t_8326_8324_8323", (57, TyVarFree NoLoc Lifted)), ("t_8326_8324_8324", (57, TyVarFree NoLoc Lifted)), ("if_t_8326_8324_8325", (48, TyVarFree NoLoc SizeLifted)), ("t_8326_8324_8326", (47, TyVarFree NoLoc Lifted)), ("t_8326_8325_8325", (18, TyVarFree NoLoc Lifted)), ("t_8326_8325_8325_8326_8325_8327", (18, TyVarFree NoLoc Lifted)), ("t_8322_8320_8326_8326_8325_8328", (16, TyVarFree NoLoc Lifted)), ("t_8326_8324_8326_8326_8325_8329", (47, TyVarFree NoLoc Lifted)), ("if_t_8326_8324_8325_8326_8326_8320", (48, TyVarFree NoLoc SizeLifted)), ("t_8324_8324_8326_8326_8326_8321", (47, TyVarFree NoLoc Lifted)), ("t_8326_8324_8320_8326_8326_8322", (57, TyVarFree NoLoc Lifted)), ("t_8324_8326_8325_8326_8326_8323", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8326_8326_8326_8324", (56, TyVarFree NoLoc Lifted)), ("t_8326_8324_8321_8326_8326_8325", (57, TyVarFree NoLoc Lifted)), ("t_8324_8326_8323_8326_8326_8326", (53, TyVarFree NoLoc Lifted)), ("t_8327_8322_8326_8326_8327", (6, TyVarFree NoLoc Lifted)), ("t_8321_8325_8326_8326_8326_8328", (12, TyVarFree NoLoc Lifted)), ("b_8321_8328_8321_8326_8326_8329", (15, TyVarFree NoLoc Lifted)), ("a_8321_8328_8320_8326_8327_8320", (15, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329_8326_8327_8321", (14, TyVarFree NoLoc Lifted)), ("t_8321_8327_8328_8326_8327_8322", (14, TyVarFree NoLoc Lifted)), ("a_8321_8325_8327_8326_8327_8323", (13, TyVarFree NoLoc Lifted)), ("t_8321_8321_8329_8326_8327_8324", (8, TyVarFree NoLoc Lifted)), ("b_8327_8324_8326_8327_8325", (7, TyVarFree NoLoc Lifted)), ("a_8327_8323_8326_8327_8326", (7, TyVarFree NoLoc Lifted)), ("b_8327_8326_8326_8327_8327", (7, TyVarFree NoLoc Lifted)), ("a_8327_8325_8326_8327_8328", (7, TyVarFree NoLoc Lifted))]+      M.fromList [("num_8320", (3, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321", (3, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322", (3, TyVarFree NoLoc Unlifted)), ("index_elem_8323", (3, TyVarFree NoLoc Unlifted)), ("kt_8324", (3, TyVarFree NoLoc Lifted)), ("t_8325", (3, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8324" 15206}) []))]))), ("t_8326", (4, TyVarFree NoLoc Lifted)), ("t_8327", (6, TyVarFree NoLoc Lifted)), ("t_8328", (7, TyVarFree NoLoc Lifted)), ("t_8329", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8321", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8326", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8327", (8, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8326", (6, TyVarFree NoLoc Lifted)), ("t_8322_8327", (7, TyVarFree NoLoc Lifted)), ("t_8322_8328", (7, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8322_8327" 15232}) [])])]))), ("t_8322_8329", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8320", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325", (7, TyVarFree NoLoc Lifted)), ("t_8323_8326", (7, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8323_8325" 15241}) [])])]))), ("t_8323_8327", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8328", (7, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8329", (7, TyVarFree NoLoc Unlifted)), ("kt_8324_8320", (7, TyVarFree NoLoc Lifted)), ("t_8324_8321", (7, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8320" 15247}) []))]))), ("match_t_8324_8322", (7, TyVarFree NoLoc SizeLifted)), ("a_8324_8323", (5, TyVarFree NoLoc Unlifted)), ("x_8324_8324", (5, TyVarFree NoLoc Unlifted)), ("t_8324_8325", (6, TyVarFree NoLoc Lifted)), ("kt_8324_8326", (7, TyVarFree NoLoc Lifted)), ("t_8324_8327", (7, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8326" 15255}) []))]))), ("kt_8325_8320", (7, TyVarFree NoLoc Lifted)), ("t_8325_8321", (7, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8320" 15260}) []))]))), ("t_8325_8326", (8, TyVarFree NoLoc Lifted)), ("kt_8325_8327", (9, TyVarFree NoLoc Lifted)), ("t_8325_8328", (9, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8327" 15268}) []))]))), ("kt_8326_8321", (9, TyVarFree NoLoc Lifted)), ("t_8326_8322", (9, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8326_8321" 15273}) []))]))), ("t_8326_8327", (10, TyVarFree NoLoc Lifted)), ("t_8327_8322", (6, TyVarFree NoLoc Lifted)), ("a_8327_8323", (7, TyVarFree NoLoc Lifted)), ("b_8327_8324", (7, TyVarFree NoLoc Lifted)), ("a_8327_8325", (7, TyVarFree NoLoc Lifted)), ("b_8327_8326", (7, TyVarFree NoLoc Lifted)), ("a_8327_8327", (7, TyVarFree NoLoc Unlifted)), ("x_8327_8328", (7, TyVarFree NoLoc Unlifted)), ("t_8327_8329", (8, TyVarFree NoLoc Lifted)), ("t_8328_8320", (8, TyVarFree NoLoc Lifted)), ("t_8328_8321", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8328_8322", (9, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8328_8323", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8320", (9, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8329_8321", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("a_8321_8320_8328", (7, TyVarFree NoLoc Unlifted)), ("t_8321_8320_8329", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8321_8320", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8321_8329", (8, TyVarFree NoLoc Lifted)), ("t_8321_8322_8320", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8322_8321", (9, TyVarFree NoLoc Unlifted)), ("num_8321_8322_8326", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8321", (10, TyVarFree NoLoc Lifted)), ("a_8321_8323_8322", (11, TyVarFree NoLoc Unlifted)), ("x_8321_8323_8323", (11, TyVarFree NoLoc Unlifted)), ("t_8321_8323_8324", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8323_8325", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8326", (11, TyVarFree NoLoc Lifted)), ("t_8321_8324_8321", (11, TyVarFree NoLoc Unlifted)), ("num_8321_8324_8322", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8324_8323", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8325_8322", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8325_8323", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8321_8325_8324", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8321_8325_8325", (11, TyVarFree NoLoc Unlifted)), ("t_8321_8325_8326", (12, TyVarFree NoLoc Lifted)), ("a_8321_8325_8327", (13, TyVarFree NoLoc Lifted)), ("b_8321_8325_8328", (13, TyVarFree NoLoc Lifted)), ("a_8321_8325_8329", (13, TyVarFree NoLoc Unlifted)), ("x_8321_8326_8320", (13, TyVarFree NoLoc Unlifted)), ("t_8321_8326_8321", (14, TyVarFree NoLoc Lifted)), ("num_8321_8326_8324", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8326_8325", (13, TyVarFree NoLoc Unlifted)), ("a_8321_8327_8322", (13, TyVarFree NoLoc Unlifted)), ("b_8321_8327_8323", (13, TyVarFree NoLoc Unlifted)), ("t_8321_8327_8328", (14, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329", (14, TyVarFree NoLoc Lifted)), ("a_8321_8328_8320", (15, TyVarFree NoLoc Lifted)), ("b_8321_8328_8321", (15, TyVarFree NoLoc Lifted)), ("a_8321_8328_8322", (15, TyVarFree NoLoc Unlifted)), ("t_8321_8328_8323", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8328_8324", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("a_8321_8329_8325", (15, TyVarFree NoLoc Unlifted)), ("t_8321_8329_8326", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8329_8327", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8326", (16, TyVarFree NoLoc Lifted)), ("a_8322_8320_8327", (17, TyVarFree NoLoc Unlifted)), ("b_8322_8320_8328", (17, TyVarFree NoLoc Unlifted)), ("x_8322_8320_8329", (17, TyVarFree NoLoc Unlifted)), ("t_8322_8321_8320", (18, TyVarFree NoLoc Lifted)), ("t_8322_8321_8321", (19, TyVarFree NoLoc Lifted)), ("t_8322_8321_8324", (21, TyVarFree NoLoc Lifted)), ("t_8322_8321_8325", (22, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8321_8326", (22, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8321_8327", (22, TyVarFree NoLoc Unlifted)), ("t_8322_8321_8328", (23, TyVarFree NoLoc Lifted)), ("t_8322_8321_8329", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8322_8320", (24, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8322_8321", (24, TyVarFree NoLoc Unlifted)), ("t_8322_8322_8322", (25, TyVarFree NoLoc Lifted)), ("t_8322_8322_8323", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8322_8324", (26, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8322_8325", (26, TyVarFree NoLoc Unlifted)), ("t_8322_8322_8326", (27, TyVarFree NoLoc Lifted)), ("t_8322_8322_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8322_8328", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8322_8329", (28, TyVarFree NoLoc Lifted)), ("t_8322_8323_8320", (28, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8322_8329" 15494}) []))]))), ("num_8322_8323_8321", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8323_8326", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8323_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8326", (29, TyVarFree NoLoc Lifted)), ("kt_8322_8324_8327", (30, TyVarFree NoLoc Lifted)), ("t_8322_8324_8328", (30, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8324_8327" 15515}) []))]))), ("t_8322_8324_8329", (31, TyVarFree NoLoc Lifted)), ("t_8322_8325_8320", (32, TyVarPrim NoLoc [Bool])), ("t_8322_8325_8321", (32, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8325_8322", (32, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8325_8327", (32, TyVarFree NoLoc Unlifted)), ("t_8322_8326_8326", (33, TyVarFree NoLoc Lifted)), ("t_8322_8326_8327", (34, TyVarFree NoLoc Unlifted)), ("num_8322_8326_8328", (34, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8327_8323", (34, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8327_8324", (34, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8327_8325", (34, TyVarFree NoLoc Lifted)), ("t_8322_8327_8326", (34, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8327_8325" 15547}) []))]))), ("if_t_8322_8327_8327", (34, TyVarFree NoLoc SizeLifted)), ("if_t_8322_8328_8322", (34, TyVarFree NoLoc SizeLifted)), ("t_8322_8328_8323", (35, TyVarFree NoLoc Lifted)), ("kt_8322_8328_8324", (36, TyVarFree NoLoc Lifted)), ("t_8322_8328_8325", (36, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8328_8324" 15557}) []))]))), ("kt_8322_8328_8326", (36, TyVarFree NoLoc Lifted)), ("t_8322_8328_8327", (36, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8328_8326" 15559}) []))]))), ("if_t_8322_8328_8328", (36, TyVarFree NoLoc SizeLifted)), ("t_8322_8328_8329", (37, TyVarFree NoLoc Lifted)), ("t_8322_8329_8320", (38, TyVarPrim NoLoc [Bool])), ("t_8322_8329_8321", (38, TyVarFree NoLoc Unlifted)), ("num_8322_8329_8322", (38, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8329_8327", (38, TyVarFree NoLoc Lifted)), ("t_8322_8329_8328", (38, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8322_8329_8327" 15571}) [])])]))), ("t_8322_8329_8329", (38, TyVarFree NoLoc Lifted)), ("t_8323_8320_8320", (38, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8322_8329_8329" 15573}) [])])]))), ("match_t_8323_8320_8321", (38, TyVarFree NoLoc SizeLifted)), ("t_8323_8320_8326", (39, TyVarFree NoLoc Lifted)), ("t_8323_8320_8327", (41, TyVarFree NoLoc Lifted)), ("t_8323_8320_8328", (42, TyVarFree NoLoc Lifted)), ("t_8323_8320_8329", (42, TyVarSum NoLoc (M.fromList [("inner", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8323_8320_8328" 15583}) [])])]))), ("t_8323_8321_8320", (42, TyVarFree NoLoc Lifted)), ("t_8323_8321_8321", (42, TyVarSum NoLoc (M.fromList [("leaf", [Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8323_8321_8320" 15585}) [])])]))), ("match_t_8323_8321_8322", (42, TyVarFree NoLoc SizeLifted)), ("t_8323_8321_8325", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8321_8326", (40, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8321_8327", (40, TyVarFree NoLoc Unlifted)), ("t_8323_8321_8328", (41, TyVarFree NoLoc Lifted)), ("kt_8323_8321_8329", (42, TyVarFree NoLoc Lifted)), ("t_8323_8322_8320", (42, TyVarRecord NoLoc (M.fromList [("mass", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8321_8329" 15596}) []))]))), ("kt_8323_8322_8321", (42, TyVarFree NoLoc Lifted)), ("t_8323_8322_8322", (42, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8322_8321" 15598}) []))]))), ("ft_8323_8322_8327", (42, TyVarRecord NoLoc (M.fromList [("position", Scalar (Record (M.fromList [("x", Scalar (Prim (FloatType Float32))), ("y", Scalar (Prim (FloatType Float32))), ("z", Scalar (Prim (FloatType Float32)))])))]))), ("num_8323_8322_8328", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8322_8329", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8320", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("float_8323_8323_8323", (40, TyVarPrim NoLoc [FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8324", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8325", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8323_8326", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8323_8323_8329", (40, TyVarFree NoLoc SizeLifted)), ("t_8323_8324_8320", (41, TyVarFree NoLoc Lifted)), ("t_8323_8324_8321", (42, TyVarFree NoLoc Unlifted)), ("num_8323_8324_8322", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8324_8327", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8324_8328", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8324_8329", (43, TyVarFree NoLoc Lifted)), ("num_8323_8325_8320", (44, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325_8321", (44, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325_8322", (45, TyVarFree NoLoc Lifted)), ("t_8323_8325_8323", (46, TyVarFree NoLoc Lifted)), ("t_8323_8325_8324", (46, TyVarFree NoLoc Lifted)), ("t_8323_8325_8325", (46, TyVarFree NoLoc Unlifted)), ("num_8323_8325_8326", (46, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8325_8327", (46, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8326_8322", (46, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8326_8323", (46, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8326_8324", (46, TyVarFree NoLoc Unlifted)), ("kt_8323_8326_8325", (46, TyVarFree NoLoc Lifted)), ("t_8323_8326_8326", (46, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8326_8325" 15648}) []))]))), ("t_8323_8326_8327", (47, TyVarFree NoLoc Lifted)), ("t_8323_8326_8328", (48, TyVarFree NoLoc Unlifted)), ("num_8323_8326_8329", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8327_8320", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8327_8325", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8327_8326", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8327_8327", (48, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8327_8328", (48, TyVarFree NoLoc Unlifted)), ("kt_8323_8327_8329", (48, TyVarFree NoLoc Lifted)), ("t_8323_8328_8320", (48, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8327_8329" 15664}) []))]))), ("t_8323_8328_8323", (49, TyVarFree NoLoc Lifted)), ("t_8323_8328_8324", (50, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8328_8325", (50, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8328_8326", (50, TyVarFree NoLoc Unlifted)), ("t_8323_8328_8327", (51, TyVarFree NoLoc Lifted)), ("t_8323_8328_8328", (52, TyVarFree NoLoc Unlifted)), ("t_8323_8329_8323", (53, TyVarFree NoLoc Lifted)), ("kt_8323_8329_8324", (54, TyVarFree NoLoc Lifted)), ("t_8323_8329_8325", (54, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8329_8324" 15681}) []))]))), ("kt_8323_8329_8326", (54, TyVarFree NoLoc Lifted)), ("t_8323_8329_8327", (54, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8323_8329_8326" 15683}) []))]))), ("if_t_8323_8329_8328", (54, TyVarFree NoLoc SizeLifted)), ("t_8323_8329_8329", (55, TyVarFree NoLoc Lifted)), ("t_8324_8320_8320", (56, TyVarFree NoLoc Unlifted)), ("num_8324_8320_8321", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8320_8326", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8320_8327", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8320_8328", (56, TyVarFree NoLoc Unlifted)), ("t_8324_8320_8329", (57, TyVarFree NoLoc Lifted)), ("t_8324_8321_8320", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8321_8321", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8321_8322", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8321_8323", (58, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8324_8321_8324", (58, TyVarFree NoLoc Lifted)), ("t_8324_8321_8325", (58, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8321_8324" 15702}) []))]))), ("num_8324_8321_8326", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8324_8323_8321", (58, TyVarFree NoLoc SizeLifted)), ("if_t_8324_8323_8322", (56, TyVarFree NoLoc SizeLifted)), ("if_t_8324_8323_8323", (48, TyVarFree NoLoc SizeLifted)), ("t_8324_8323_8324", (47, TyVarFree NoLoc Lifted)), ("t_8324_8323_8325", (47, TyVarFree NoLoc Lifted)), ("if_t_8324_8323_8326", (42, TyVarFree NoLoc SizeLifted)), ("t_8324_8323_8327", (43, TyVarFree NoLoc Lifted)), ("num_8324_8323_8328", (44, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8323_8329", (44, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8324_8320", (46, TyVarFree NoLoc Unlifted)), ("num_8324_8324_8321", (46, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8324_8326", (47, TyVarFree NoLoc Lifted)), ("t_8324_8324_8327", (48, TyVarFree NoLoc Unlifted)), ("num_8324_8324_8328", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8325_8323", (48, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8324_8325_8326", (48, TyVarFree NoLoc SizeLifted)), ("t_8324_8325_8327", (49, TyVarFree NoLoc Lifted)), ("num_8324_8325_8328", (50, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("et_8324_8325_8329", (52, TyVarFree NoLoc Unlifted)), ("num_8324_8326_8320", (52, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8326_8321", (52, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8326_8322", (52, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8326_8323", (53, TyVarFree NoLoc Lifted)), ("num_8324_8326_8324", (54, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8326_8325", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8326", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8327", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8328", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8329", (56, TyVarFree NoLoc Lifted)), ("t_8324_8327_8320", (56, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8324_8327_8321", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8327_8322", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8327_8323", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8327_8324", (56, TyVarFree NoLoc Unlifted)), ("num_8324_8327_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8328_8320", (56, TyVarFree NoLoc Unlifted)), ("t_8324_8328_8321", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8328_8322", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8328_8323", (56, TyVarFree NoLoc Unlifted)), ("num_8324_8328_8324", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8328_8329", (56, TyVarFree NoLoc Unlifted)), ("t_8324_8329_8320", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8329_8321", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8329_8322", (56, TyVarFree NoLoc Unlifted)), ("kt_8324_8329_8323", (56, TyVarFree NoLoc Lifted)), ("t_8324_8329_8324", (56, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8329_8323" 15791}) []))]))), ("num_8324_8329_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8320_8320", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8320_8321", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8320_8322", (56, TyVarFree NoLoc Unlifted)), ("t_8325_8320_8323", (57, TyVarFree NoLoc Lifted)), ("t_8325_8320_8324", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("update_elem_8325_8320_8325", (58, TyVarFree NoLoc Unlifted)), ("t_8325_8320_8326", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8320_8327", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8321_8322", (59, TyVarFree NoLoc Lifted)), ("t_8325_8321_8323", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8325_8321_8324", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8325_8321_8325", (60, TyVarFree NoLoc Unlifted)), ("t_8325_8321_8326", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8321_8327", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8321_8328", (56, TyVarFree NoLoc Unlifted)), ("kt_8325_8321_8329", (56, TyVarFree NoLoc Lifted)), ("t_8325_8322_8320", (56, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8321_8329" 15820}) []))]))), ("t_8325_8322_8323", (57, TyVarFree NoLoc Lifted)), ("t_8325_8322_8324", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8322_8325", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8323_8320", (59, TyVarFree NoLoc Lifted)), ("t_8325_8323_8321", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8325_8323_8322", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8325_8323_8323", (60, TyVarFree NoLoc Unlifted)), ("if_t_8325_8323_8324", (56, TyVarFree NoLoc SizeLifted)), ("t_8325_8323_8325", (56, TyVarFree NoLoc Unlifted)), ("t_8325_8323_8326", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8323_8327", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8323_8328", (56, TyVarFree NoLoc Unlifted)), ("num_8325_8323_8329", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8324_8324", (56, TyVarFree NoLoc Unlifted)), ("t_8325_8324_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8324_8326", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8324_8327", (56, TyVarFree NoLoc Unlifted)), ("kt_8325_8324_8328", (56, TyVarFree NoLoc Lifted)), ("t_8325_8324_8329", (56, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8324_8328" 15852}) []))]))), ("num_8325_8325_8320", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8325_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8325_8326", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8325_8327", (56, TyVarFree NoLoc Unlifted)), ("t_8325_8325_8328", (57, TyVarFree NoLoc Lifted)), ("t_8325_8325_8329", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("t_8325_8326_8320", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8326_8321", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8326_8322", (58, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8326_8323", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8326_8324", (58, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8326_8325", (58, TyVarFree NoLoc Unlifted)), ("kt_8325_8326_8326", (58, TyVarFree NoLoc Lifted)), ("t_8325_8326_8327", (58, TyVarRecord NoLoc (M.fromList [("left", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8326_8326" 15871}) []))]))), ("num_8325_8326_8328", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8327_8325", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8325_8328_8324", (58, TyVarFree NoLoc Unlifted)), ("t_8325_8328_8325", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8328_8326", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8329_8321", (59, TyVarFree NoLoc Lifted)), ("t_8325_8329_8322", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8325_8329_8323", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8325_8329_8324", (60, TyVarFree NoLoc Unlifted)), ("t_8325_8329_8325", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8325_8329_8326", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8325_8329_8327", (56, TyVarFree NoLoc Unlifted)), ("kt_8325_8329_8328", (56, TyVarFree NoLoc Lifted)), ("t_8325_8329_8329", (56, TyVarRecord NoLoc (M.fromList [("right", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8325_8329_8328" 15909}) []))]))), ("t_8326_8320_8322", (57, TyVarFree NoLoc Lifted)), ("t_8326_8320_8323", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8326_8320_8324", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8320_8329", (59, TyVarFree NoLoc Lifted)), ("t_8326_8321_8320", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("num_8326_8321_8321", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8326_8321_8322", (60, TyVarFree NoLoc Unlifted)), ("if_t_8326_8321_8323", (56, TyVarFree NoLoc SizeLifted)), ("t_8326_8321_8324", (56, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8326_8321_8325", (56, TyVarFree NoLoc Unlifted)), ("index_elem_8326_8321_8326", (56, TyVarFree NoLoc Unlifted)), ("kt_8326_8321_8327", (56, TyVarFree NoLoc Lifted)), ("t_8326_8321_8328", (56, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8326_8321_8327" 15931}) []))]))), ("t_8326_8321_8329", (57, TyVarFree NoLoc Lifted)), ("t_8326_8322_8320", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8326_8322_8321", (58, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8322_8326", (59, TyVarFree NoLoc Lifted)), ("t_8326_8322_8327", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("t_8326_8322_8328", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8322_8329", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8326_8323_8320", (60, TyVarFree NoLoc Unlifted)), ("index_elem_8326_8323_8321", (60, TyVarFree NoLoc Unlifted)), ("num_8326_8323_8322", (60, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("update_elem_8326_8323_8327", (60, TyVarFree NoLoc Unlifted)), ("if_t_8326_8323_8328", (56, TyVarFree NoLoc SizeLifted)), ("if_t_8326_8323_8329", (56, TyVarFree NoLoc SizeLifted)), ("t_8326_8324_8320", (57, TyVarFree NoLoc Lifted)), ("t_8326_8324_8321", (57, TyVarFree NoLoc Lifted)), ("t_8326_8324_8322", (57, TyVarFree NoLoc Lifted)), ("t_8326_8324_8323", (57, TyVarFree NoLoc Lifted)), ("t_8326_8324_8324", (57, TyVarFree NoLoc Lifted)), ("if_t_8326_8324_8325", (48, TyVarFree NoLoc SizeLifted)), ("t_8326_8324_8326", (47, TyVarFree NoLoc Lifted)), ("t_8326_8325_8325", (18, TyVarFree NoLoc Lifted)), ("t_8326_8325_8325_8326_8325_8327", (18, TyVarFree NoLoc Lifted)), ("t_8322_8320_8326_8326_8325_8328", (16, TyVarFree NoLoc Lifted)), ("t_8326_8324_8326_8326_8325_8329", (47, TyVarFree NoLoc Lifted)), ("if_t_8326_8324_8325_8326_8326_8320", (48, TyVarFree NoLoc SizeLifted)), ("t_8324_8324_8326_8326_8326_8321", (47, TyVarFree NoLoc Lifted)), ("t_8326_8324_8320_8326_8326_8322", (57, TyVarFree NoLoc Lifted)), ("t_8324_8326_8325_8326_8326_8323", (56, TyVarFree NoLoc Lifted)), ("t_8324_8326_8326_8326_8326_8324", (56, TyVarFree NoLoc Lifted)), ("t_8326_8324_8321_8326_8326_8325", (57, TyVarFree NoLoc Lifted)), ("t_8324_8326_8323_8326_8326_8326", (53, TyVarFree NoLoc Lifted)), ("t_8327_8322_8326_8326_8327", (6, TyVarFree NoLoc Lifted)), ("t_8321_8325_8326_8326_8326_8328", (12, TyVarFree NoLoc Lifted)), ("b_8321_8328_8321_8326_8326_8329", (15, TyVarFree NoLoc Lifted)), ("a_8321_8328_8320_8326_8327_8320", (15, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329_8326_8327_8321", (14, TyVarFree NoLoc Lifted)), ("t_8321_8327_8328_8326_8327_8322", (14, TyVarFree NoLoc Lifted)), ("a_8321_8325_8327_8326_8327_8323", (13, TyVarFree NoLoc Lifted)), ("t_8321_8321_8329_8326_8327_8324", (8, TyVarFree NoLoc Lifted)), ("b_8327_8324_8326_8327_8325", (7, TyVarFree NoLoc Lifted)), ("a_8327_8323_8326_8327_8326", (7, TyVarFree NoLoc Lifted)), ("b_8327_8326_8326_8327_8327", (7, TyVarFree NoLoc Lifted)), ("a_8327_8325_8326_8327_8328", (7, TyVarFree NoLoc Lifted))]     ),     ( [ "t_8320" ~ "t_8323",         "num_8324" ~ "t_8323",@@ -1317,7 +1317,7 @@         "([]{body: {mass: f32, position: {x: f32, y: f32, z: f32}, velocity: {x: f32, y: f32, z: f32}}, children: []i32, is_leaf: bool, parent: i32, tree_level: i32}, f32, i32, []{mass: f32, position: {x: f32, y: f32, z: f32}, velocity: {x: f32, y: f32, z: f32})}" ~ "(t_8323_8321_8325, t_8323_8323_8324, t_8321_8328_8326, t_8321_8325_8327)"       ],       M.empty,-      M.fromList [("a_8320", (2, TyVarFree NoLoc Unlifted)), ("x_8321", (2, TyVarFree NoLoc Unlifted)), ("a_8322", (2, TyVarFree NoLoc Lifted)), ("b_8323", (2, TyVarFree NoLoc Lifted)), ("ft_8324", (2, TyVarFree NoLoc Lifted)), ("rt_8325", (2, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "ft_8324" 16341}) []))]))), ("ft_8326", (2, TyVarRecord NoLoc (M.fromList [("x", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8323" 16340}) []))]))), ("t_8321_8323", (3, TyVarFree NoLoc Lifted)), ("a_8321_8324", (4, TyVarFree NoLoc Unlifted)), ("x_8321_8325", (4, TyVarFree NoLoc Unlifted)), ("a_8321_8326", (4, TyVarFree NoLoc Lifted)), ("b_8321_8327", (4, TyVarFree NoLoc Lifted)), ("ft_8321_8328", (4, TyVarFree NoLoc Lifted)), ("rt_8321_8329", (4, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "ft_8321_8328" 16361}) []))]))), ("ft_8322_8320", (4, TyVarRecord NoLoc (M.fromList [("y", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8321_8327" 16360}) []))]))), ("t_8322_8327", (5, TyVarFree NoLoc Lifted)), ("a_8322_8328", (6, TyVarFree NoLoc Unlifted)), ("x_8322_8329", (6, TyVarFree NoLoc Unlifted)), ("a_8323_8320", (6, TyVarFree NoLoc Lifted)), ("b_8323_8321", (6, TyVarFree NoLoc Lifted)), ("ft_8323_8322", (6, TyVarFree NoLoc Lifted)), ("rt_8323_8323", (6, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "ft_8323_8322" 16381}) []))]))), ("ft_8323_8324", (6, TyVarRecord NoLoc (M.fromList [("z", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8323_8321" 16380}) []))]))), ("t_8324_8321", (7, TyVarFree NoLoc Lifted)), ("a_8324_8322", (8, TyVarFree NoLoc Unlifted)), ("x_8324_8323", (8, TyVarFree NoLoc Unlifted)), ("a_8324_8324", (8, TyVarFree NoLoc Lifted)), ("b_8324_8325", (8, TyVarFree NoLoc Lifted)), ("ft_8324_8326", (8, TyVarFree NoLoc Lifted)), ("rt_8324_8327", (8, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "ft_8324_8326" 16401}) []))]))), ("ft_8324_8328", (8, TyVarRecord NoLoc (M.fromList [("x", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8324_8325" 16400}) []))]))), ("t_8325_8325", (9, TyVarFree NoLoc Lifted)), ("a_8325_8326", (10, TyVarFree NoLoc Unlifted)), ("x_8325_8327", (10, TyVarFree NoLoc Unlifted)), ("a_8325_8328", (10, TyVarFree NoLoc Lifted)), ("b_8325_8329", (10, TyVarFree NoLoc Lifted)), ("ft_8326_8320", (10, TyVarFree NoLoc Lifted)), ("rt_8326_8321", (10, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "ft_8326_8320" 16421}) []))]))), ("ft_8326_8322", (10, TyVarRecord NoLoc (M.fromList [("y", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8325_8329" 16420}) []))]))), ("t_8326_8329", (11, TyVarFree NoLoc Lifted)), ("a_8327_8320", (12, TyVarFree NoLoc Unlifted)), ("x_8327_8321", (12, TyVarFree NoLoc Unlifted)), ("a_8327_8322", (12, TyVarFree NoLoc Lifted)), ("b_8327_8323", (12, TyVarFree NoLoc Lifted)), ("ft_8327_8324", (12, TyVarFree NoLoc Lifted)), ("rt_8327_8325", (12, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "ft_8327_8324" 16441}) []))]))), ("ft_8327_8326", (12, TyVarRecord NoLoc (M.fromList [("z", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "b_8327_8323" 16440}) []))]))), ("t_8328_8323", (13, TyVarFree NoLoc Lifted)), ("t_8328_8324", (15, TyVarFree NoLoc Lifted)), ("t_8328_8325", (15, TyVarFree NoLoc Lifted)), ("t_8328_8326", (15, TyVarFree NoLoc Lifted)), ("t_8328_8327", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8328_8328", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8323", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8322", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8323", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8328", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8321_8327", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8321_8328", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8322_8323", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("a_8321_8323_8322", (14, TyVarFree NoLoc Lifted)), ("b_8321_8323_8323", (14, TyVarFree NoLoc Lifted)), ("c_8321_8323_8324", (14, TyVarFree NoLoc Lifted)), ("t_8321_8323_8329", (15, TyVarFree NoLoc Lifted)), ("t_8321_8324_8320", (16, TyVarFree NoLoc Unlifted)), ("k_8321_8324_8321", (16, TyVarFree NoLoc Unlifted)), ("t_8321_8324_8322", (17, TyVarFree NoLoc Lifted)), ("kt_8321_8324_8323", (18, TyVarFree NoLoc Lifted)), ("t_8321_8324_8324", (18, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8324_8323" 16528}) []))]))), ("arg_8321_8324_8325", (18, TyVarFree NoLoc Lifted)), ("res_8321_8324_8326", (18, TyVarFree NoLoc Lifted)), ("t_8321_8325_8327", (17, TyVarFree NoLoc Lifted)), ("a_8321_8325_8328", (18, TyVarFree NoLoc Unlifted)), ("x_8321_8325_8329", (18, TyVarFree NoLoc Unlifted)), ("t_8321_8326_8320", (19, TyVarFree NoLoc Lifted)), ("kt_8321_8326_8321", (20, TyVarFree NoLoc Lifted)), ("t_8321_8326_8322", (20, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8326_8321" 16552}) []))]))), ("arg_8321_8326_8323", (20, TyVarFree NoLoc Lifted)), ("res_8321_8326_8324", (20, TyVarFree NoLoc Lifted)), ("t_8321_8327_8321", (19, TyVarFree NoLoc Lifted)), ("t_8321_8327_8324", (21, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329", (23, TyVarFree NoLoc Lifted)), ("num_8321_8328_8320", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8328_8321", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8321_8328_8322", (24, TyVarFree NoLoc Unlifted)), ("index_elem_8321_8328_8323", (24, TyVarFree NoLoc Unlifted)), ("kt_8321_8328_8324", (24, TyVarFree NoLoc Lifted)), ("t_8321_8328_8325", (24, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8328_8324" 16585}) []))]))), ("t_8321_8328_8326", (25, TyVarFree NoLoc Lifted)), ("t_8321_8328_8327", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8328_8328", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8328_8329", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8329_8328", (27, TyVarFree NoLoc Lifted)), ("t_8321_8329_8329", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8320", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8321", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8320_8322", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8320_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8321_8322", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8327", (29, TyVarFree NoLoc Lifted)), ("t_8322_8321_8328", (30, TyVarFree NoLoc Lifted)), ("t_8322_8321_8329", (30, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64])), ("t_8322_8322_8320", (30, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8322_8321", (30, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8322_8326", (30, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("range_8322_8322_8327", (30, TyVarFree NoLoc Unlifted)), ("elem_8322_8322_8328", (30, TyVarFree NoLoc Unlifted)), ("t_8322_8322_8329", (30, TyVarFree NoLoc Lifted)), ("a_8322_8323_8320", (30, TyVarFree NoLoc Unlifted)), ("x_8322_8323_8321", (30, TyVarFree NoLoc Unlifted)), ("t_8322_8323_8322", (32, TyVarFree NoLoc Unlifted)), ("kt_8322_8323_8323", (32, TyVarFree NoLoc Lifted)), ("t_8322_8323_8324", (32, TyVarRecord NoLoc (M.fromList [("tree_level", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8323_8323" 16643}) []))]))), ("num_8322_8323_8329", (32, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8320", (33, TyVarFree NoLoc Lifted)), ("kt_8322_8324_8321", (34, TyVarFree NoLoc Lifted)), ("t_8322_8324_8322", (34, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8324_8321" 16654}) []))]))), ("t_8322_8324_8323", (35, TyVarFree NoLoc Lifted)), ("t_8322_8324_8324", (36, TyVarFree NoLoc Lifted)), ("t_8322_8324_8325", (36, TyVarFree NoLoc Lifted)), ("t_8322_8324_8326", (36, TyVarPrim NoLoc [Bool])), ("t_8322_8324_8327", (36, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8324_8328", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8325_8323", (36, TyVarFree NoLoc Unlifted)), ("kt_8322_8325_8324", (36, TyVarFree NoLoc Lifted)), ("t_8322_8325_8325", (36, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8325_8324" 16669}) []))]))), ("t_8322_8325_8326", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8325_8327", (36, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8325_8328", (36, TyVarFree NoLoc Unlifted)), ("num_8322_8325_8329", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8326_8320", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8326_8329", (36, TyVarFree NoLoc Lifted)), ("t_8322_8327_8320", (36, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8326_8329" 16687}) []))]))), ("t_8322_8327_8321", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8327_8322", (36, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8327_8323", (36, TyVarFree NoLoc Unlifted)), ("t_8322_8327_8324", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8327_8325", (36, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8327_8326", (36, TyVarFree NoLoc Unlifted)), ("kt_8322_8327_8327", (36, TyVarFree NoLoc Lifted)), ("t_8322_8327_8328", (36, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8327_8327" 16695}) []))]))), ("t_8322_8327_8329", (37, TyVarFree NoLoc Lifted)), ("kt_8322_8328_8320", (38, TyVarFree NoLoc Lifted)), ("t_8322_8328_8321", (38, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8328_8320" 16698}) []))]))), ("kt_8322_8328_8322", (38, TyVarFree NoLoc Lifted)), ("t_8322_8328_8323", (38, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8328_8322" 16700}) []))]))), ("t_8322_8328_8328", (39, TyVarFree NoLoc Lifted)), ("t_8322_8328_8329", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8329_8320", (40, TyVarFree NoLoc Lifted)), ("t_8322_8329_8321", (40, TyVarRecord NoLoc (M.fromList [("mass", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8329_8320" 16709}) []))]))), ("kt_8322_8329_8322", (40, TyVarFree NoLoc Lifted)), ("t_8322_8329_8323", (40, TyVarRecord NoLoc (M.fromList [("mass", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8329_8322" 16711}) []))]))), ("t_8322_8329_8328", (41, TyVarFree NoLoc Lifted)), ("kt_8322_8329_8329", (42, TyVarFree NoLoc Lifted)), ("t_8323_8320_8320", (42, TyVarRecord NoLoc (M.fromList [("velocity", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8329_8329" 16719}) []))]))), ("t_8323_8320_8321", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8320_8322", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8320_8327", (37, TyVarFree NoLoc Lifted)), ("t_8323_8320_8328", (37, TyVarFree NoLoc Lifted)), ("ft_8323_8320_8329", (38, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "t_8323_8320_8327" 16731}) []))]))), ("if_t_8323_8321_8320", (32, TyVarFree NoLoc SizeLifted)), ("t_8323_8321_8325", (27, TyVarFree NoLoc Lifted)), ("et_8323_8321_8326", (28, TyVarFree NoLoc Unlifted)), ("t_8323_8321_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8322_8322", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8322_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8323_8324", (29, TyVarFree NoLoc Lifted)), ("t_8323_8321_8325_8323_8323_8326", (27, TyVarFree NoLoc Lifted)), ("t_8321_8325_8327_8323_8323_8327", (17, TyVarFree NoLoc Lifted)), ("t_8322_8321_8328_8323_8323_8328", (30, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329_8323_8323_8329", (23, TyVarFree NoLoc Lifted)), ("kt_8322_8326_8329_8323_8324_8320", (36, TyVarFree NoLoc Lifted)), ("kt_8322_8325_8324_8323_8324_8321", (36, TyVarFree NoLoc Lifted)), ("range_8322_8322_8327_8323_8324_8322", (30, TyVarFree NoLoc Unlifted)), ("t_8321_8327_8324_8323_8324_8323", (21, TyVarFree NoLoc Lifted)), ("t_8321_8327_8321_8323_8324_8324", (19, TyVarFree NoLoc Lifted))]+      M.fromList [("a_8320", (2, TyVarFree NoLoc Unlifted)), ("x_8321", (2, TyVarFree NoLoc Unlifted)), ("a_8322", (2, TyVarFree NoLoc Lifted)), ("b_8323", (2, TyVarFree NoLoc Lifted)), ("ft_8324", (2, TyVarFree NoLoc Lifted)), ("rt_8325", (2, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "ft_8324" 16341}) []))]))), ("ft_8326", (2, TyVarRecord NoLoc (M.fromList [("x", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8323" 16340}) []))]))), ("t_8321_8323", (3, TyVarFree NoLoc Lifted)), ("a_8321_8324", (4, TyVarFree NoLoc Unlifted)), ("x_8321_8325", (4, TyVarFree NoLoc Unlifted)), ("a_8321_8326", (4, TyVarFree NoLoc Lifted)), ("b_8321_8327", (4, TyVarFree NoLoc Lifted)), ("ft_8321_8328", (4, TyVarFree NoLoc Lifted)), ("rt_8321_8329", (4, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "ft_8321_8328" 16361}) []))]))), ("ft_8322_8320", (4, TyVarRecord NoLoc (M.fromList [("y", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8321_8327" 16360}) []))]))), ("t_8322_8327", (5, TyVarFree NoLoc Lifted)), ("a_8322_8328", (6, TyVarFree NoLoc Unlifted)), ("x_8322_8329", (6, TyVarFree NoLoc Unlifted)), ("a_8323_8320", (6, TyVarFree NoLoc Lifted)), ("b_8323_8321", (6, TyVarFree NoLoc Lifted)), ("ft_8323_8322", (6, TyVarFree NoLoc Lifted)), ("rt_8323_8323", (6, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "ft_8323_8322" 16381}) []))]))), ("ft_8323_8324", (6, TyVarRecord NoLoc (M.fromList [("z", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8323_8321" 16380}) []))]))), ("t_8324_8321", (7, TyVarFree NoLoc Lifted)), ("a_8324_8322", (8, TyVarFree NoLoc Unlifted)), ("x_8324_8323", (8, TyVarFree NoLoc Unlifted)), ("a_8324_8324", (8, TyVarFree NoLoc Lifted)), ("b_8324_8325", (8, TyVarFree NoLoc Lifted)), ("ft_8324_8326", (8, TyVarFree NoLoc Lifted)), ("rt_8324_8327", (8, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "ft_8324_8326" 16401}) []))]))), ("ft_8324_8328", (8, TyVarRecord NoLoc (M.fromList [("x", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8324_8325" 16400}) []))]))), ("t_8325_8325", (9, TyVarFree NoLoc Lifted)), ("a_8325_8326", (10, TyVarFree NoLoc Unlifted)), ("x_8325_8327", (10, TyVarFree NoLoc Unlifted)), ("a_8325_8328", (10, TyVarFree NoLoc Lifted)), ("b_8325_8329", (10, TyVarFree NoLoc Lifted)), ("ft_8326_8320", (10, TyVarFree NoLoc Lifted)), ("rt_8326_8321", (10, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "ft_8326_8320" 16421}) []))]))), ("ft_8326_8322", (10, TyVarRecord NoLoc (M.fromList [("y", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8325_8329" 16420}) []))]))), ("t_8326_8329", (11, TyVarFree NoLoc Lifted)), ("a_8327_8320", (12, TyVarFree NoLoc Unlifted)), ("x_8327_8321", (12, TyVarFree NoLoc Unlifted)), ("a_8327_8322", (12, TyVarFree NoLoc Lifted)), ("b_8327_8323", (12, TyVarFree NoLoc Lifted)), ("ft_8327_8324", (12, TyVarFree NoLoc Lifted)), ("rt_8327_8325", (12, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "ft_8327_8324" 16441}) []))]))), ("ft_8327_8326", (12, TyVarRecord NoLoc (M.fromList [("z", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "b_8327_8323" 16440}) []))]))), ("t_8328_8323", (13, TyVarFree NoLoc Lifted)), ("t_8328_8324", (15, TyVarFree NoLoc Lifted)), ("t_8328_8325", (15, TyVarFree NoLoc Lifted)), ("t_8328_8326", (15, TyVarFree NoLoc Lifted)), ("t_8328_8327", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8328_8328", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8323", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8322", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8323", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8328", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8321_8327", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8321_8328", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8322_8323", (16, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("a_8321_8323_8322", (14, TyVarFree NoLoc Lifted)), ("b_8321_8323_8323", (14, TyVarFree NoLoc Lifted)), ("c_8321_8323_8324", (14, TyVarFree NoLoc Lifted)), ("t_8321_8323_8329", (15, TyVarFree NoLoc Lifted)), ("t_8321_8324_8320", (16, TyVarFree NoLoc Unlifted)), ("k_8321_8324_8321", (16, TyVarFree NoLoc Unlifted)), ("t_8321_8324_8322", (17, TyVarFree NoLoc Lifted)), ("kt_8321_8324_8323", (18, TyVarFree NoLoc Lifted)), ("t_8321_8324_8324", (18, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8324_8323" 16528}) []))]))), ("arg_8321_8324_8325", (18, TyVarFree NoLoc Lifted)), ("res_8321_8324_8326", (18, TyVarFree NoLoc Lifted)), ("t_8321_8325_8327", (17, TyVarFree NoLoc Lifted)), ("a_8321_8325_8328", (18, TyVarFree NoLoc Unlifted)), ("x_8321_8325_8329", (18, TyVarFree NoLoc Unlifted)), ("t_8321_8326_8320", (19, TyVarFree NoLoc Lifted)), ("kt_8321_8326_8321", (20, TyVarFree NoLoc Lifted)), ("t_8321_8326_8322", (20, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8326_8321" 16552}) []))]))), ("arg_8321_8326_8323", (20, TyVarFree NoLoc Lifted)), ("res_8321_8326_8324", (20, TyVarFree NoLoc Lifted)), ("t_8321_8327_8321", (19, TyVarFree NoLoc Lifted)), ("t_8321_8327_8324", (21, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329", (23, TyVarFree NoLoc Lifted)), ("num_8321_8328_8320", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8328_8321", (24, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8321_8328_8322", (24, TyVarFree NoLoc Unlifted)), ("index_elem_8321_8328_8323", (24, TyVarFree NoLoc Unlifted)), ("kt_8321_8328_8324", (24, TyVarFree NoLoc Lifted)), ("t_8321_8328_8325", (24, TyVarRecord NoLoc (M.fromList [("delta_node", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8328_8324" 16585}) []))]))), ("t_8321_8328_8326", (25, TyVarFree NoLoc Lifted)), ("t_8321_8328_8327", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8328_8328", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321_8328_8329", (26, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8329_8328", (27, TyVarFree NoLoc Lifted)), ("t_8321_8329_8329", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8320", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8321", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8320_8322", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8320_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8321_8322", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8321_8327", (29, TyVarFree NoLoc Lifted)), ("t_8322_8321_8328", (30, TyVarFree NoLoc Lifted)), ("t_8322_8321_8329", (30, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64])), ("t_8322_8322_8320", (30, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8322_8321", (30, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8322_8326", (30, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("range_8322_8322_8327", (30, TyVarFree NoLoc Unlifted)), ("elem_8322_8322_8328", (30, TyVarFree NoLoc Unlifted)), ("t_8322_8322_8329", (30, TyVarFree NoLoc Lifted)), ("a_8322_8323_8320", (30, TyVarFree NoLoc Unlifted)), ("x_8322_8323_8321", (30, TyVarFree NoLoc Unlifted)), ("t_8322_8323_8322", (32, TyVarFree NoLoc Unlifted)), ("kt_8322_8323_8323", (32, TyVarFree NoLoc Lifted)), ("t_8322_8323_8324", (32, TyVarRecord NoLoc (M.fromList [("tree_level", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8323_8323" 16643}) []))]))), ("num_8322_8323_8329", (32, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8320", (33, TyVarFree NoLoc Lifted)), ("kt_8322_8324_8321", (34, TyVarFree NoLoc Lifted)), ("t_8322_8324_8322", (34, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8324_8321" 16654}) []))]))), ("t_8322_8324_8323", (35, TyVarFree NoLoc Lifted)), ("t_8322_8324_8324", (36, TyVarFree NoLoc Lifted)), ("t_8322_8324_8325", (36, TyVarFree NoLoc Lifted)), ("t_8322_8324_8326", (36, TyVarPrim NoLoc [Bool])), ("t_8322_8324_8327", (36, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8324_8328", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8325_8323", (36, TyVarFree NoLoc Unlifted)), ("kt_8322_8325_8324", (36, TyVarFree NoLoc Lifted)), ("t_8322_8325_8325", (36, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8325_8324" 16669}) []))]))), ("t_8322_8325_8326", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8325_8327", (36, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8325_8328", (36, TyVarFree NoLoc Unlifted)), ("num_8322_8325_8329", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8326_8320", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8326_8329", (36, TyVarFree NoLoc Lifted)), ("t_8322_8327_8320", (36, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8326_8329" 16687}) []))]))), ("t_8322_8327_8321", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8327_8322", (36, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8327_8323", (36, TyVarFree NoLoc Unlifted)), ("t_8322_8327_8324", (36, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8327_8325", (36, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8327_8326", (36, TyVarFree NoLoc Unlifted)), ("kt_8322_8327_8327", (36, TyVarFree NoLoc Lifted)), ("t_8322_8327_8328", (36, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8327_8327" 16695}) []))]))), ("t_8322_8327_8329", (37, TyVarFree NoLoc Lifted)), ("kt_8322_8328_8320", (38, TyVarFree NoLoc Lifted)), ("t_8322_8328_8321", (38, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8328_8320" 16698}) []))]))), ("kt_8322_8328_8322", (38, TyVarFree NoLoc Lifted)), ("t_8322_8328_8323", (38, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8328_8322" 16700}) []))]))), ("t_8322_8328_8328", (39, TyVarFree NoLoc Lifted)), ("t_8322_8328_8329", (40, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8329_8320", (40, TyVarFree NoLoc Lifted)), ("t_8322_8329_8321", (40, TyVarRecord NoLoc (M.fromList [("mass", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8329_8320" 16709}) []))]))), ("kt_8322_8329_8322", (40, TyVarFree NoLoc Lifted)), ("t_8322_8329_8323", (40, TyVarRecord NoLoc (M.fromList [("mass", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8329_8322" 16711}) []))]))), ("t_8322_8329_8328", (41, TyVarFree NoLoc Lifted)), ("kt_8322_8329_8329", (42, TyVarFree NoLoc Lifted)), ("t_8323_8320_8320", (42, TyVarRecord NoLoc (M.fromList [("velocity", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8329_8329" 16719}) []))]))), ("t_8323_8320_8321", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8320_8322", (42, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8320_8327", (37, TyVarFree NoLoc Lifted)), ("t_8323_8320_8328", (37, TyVarFree NoLoc Lifted)), ("ft_8323_8320_8329", (38, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "t_8323_8320_8327" 16731}) []))]))), ("if_t_8323_8321_8320", (32, TyVarFree NoLoc SizeLifted)), ("t_8323_8321_8325", (27, TyVarFree NoLoc Lifted)), ("et_8323_8321_8326", (28, TyVarFree NoLoc Unlifted)), ("t_8323_8321_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8322_8322", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8322_8327", (28, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8323_8324", (29, TyVarFree NoLoc Lifted)), ("t_8323_8321_8325_8323_8323_8326", (27, TyVarFree NoLoc Lifted)), ("t_8321_8325_8327_8323_8323_8327", (17, TyVarFree NoLoc Lifted)), ("t_8322_8321_8328_8323_8323_8328", (30, TyVarFree NoLoc Lifted)), ("t_8321_8327_8329_8323_8323_8329", (23, TyVarFree NoLoc Lifted)), ("kt_8322_8326_8329_8323_8324_8320", (36, TyVarFree NoLoc Lifted)), ("kt_8322_8325_8324_8323_8324_8321", (36, TyVarFree NoLoc Lifted)), ("range_8322_8322_8327_8323_8324_8322", (30, TyVarFree NoLoc Unlifted)), ("t_8321_8327_8324_8323_8324_8323", (21, TyVarFree NoLoc Lifted)), ("t_8321_8327_8321_8323_8324_8324", (19, TyVarFree NoLoc Lifted))]     ),     ( [ "t_8322_8326_8324" ~ "[]t_8322_8326_8324_8323_8322_8320",         "a_8322_8326_8325" ~ "[]a_8322_8326_8325_8323_8322_8321",@@ -1485,7 +1485,7 @@         "{x: f32, y: f32, z: f32}" ~ "t_8323_8321_8326"       ],       M.empty,-      M.fromList [("num_8320", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324", (5, TyVarFree NoLoc Lifted)), ("t_8325", (5, TyVarFree NoLoc Lifted)), ("t_8326", (5, TyVarFree NoLoc Lifted)), ("t_8327", (5, TyVarFree NoLoc Lifted)), ("t_8328", (5, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8329", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8324", (5, TyVarPrim NoLoc [Bool])), ("t_8321_8325", (5, TyVarFree NoLoc Unlifted)), ("num_8321_8326", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8322", (5, TyVarFree NoLoc Unlifted)), ("t_8322_8323", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8324", (5, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8325", (5, TyVarFree NoLoc Unlifted)), ("kt_8322_8326", (5, TyVarFree NoLoc Lifted)), ("t_8322_8327", (5, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8326" 17047}) []))]))), ("t_8323_8326", (6, TyVarFree NoLoc Lifted)), ("t_8323_8327", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8328", (7, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8329", (7, TyVarFree NoLoc Unlifted)), ("t_8324_8320", (8, TyVarFree NoLoc Lifted)), ("num_8324_8321", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8322", (9, TyVarFree NoLoc Lifted)), ("t_8324_8323", (9, TyVarFree NoLoc Unlifted)), ("kt_8324_8324", (9, TyVarFree NoLoc Lifted)), ("t_8324_8325", (9, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8324" 17068}) []))]))), ("t_8324_8326", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8327", (9, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8328", (9, TyVarFree NoLoc Unlifted)), ("t_8325_8323", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8324", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8329", (10, TyVarFree NoLoc Lifted)), ("t_8326_8320", (11, TyVarPrim NoLoc [Bool])), ("t_8326_8321", (11, TyVarFree NoLoc Unlifted)), ("num_8326_8322", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8327", (11, TyVarFree NoLoc Unlifted)), ("kt_8326_8328", (11, TyVarFree NoLoc Lifted)), ("t_8326_8329", (11, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8326_8328" 17095}) []))]))), ("t_8327_8320", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8327_8321", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8327_8326", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8327_8327", (11, TyVarFree NoLoc Unlifted)), ("index_elem_8327_8328", (11, TyVarFree NoLoc Unlifted)), ("num_8327_8329", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8328_8320", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8328_8329", (11, TyVarFree NoLoc Lifted)), ("t_8329_8320", (11, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8328_8329" 17119}) []))]))), ("kt_8329_8321", (11, TyVarFree NoLoc Lifted)), ("t_8329_8322", (11, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8329_8321" 17121}) []))]))), ("t_8329_8323", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8329_8324", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8329", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8321_8320_8320", (11, TyVarFree NoLoc Unlifted)), ("index_elem_8321_8320_8321", (11, TyVarFree NoLoc Unlifted)), ("if_t_8321_8320_8322", (11, TyVarFree NoLoc SizeLifted)), ("t_8321_8320_8323", (12, TyVarFree NoLoc Lifted)), ("t_8321_8320_8324", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8325", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8321_8320_8326", (9, TyVarFree NoLoc Lifted)), ("t_8321_8320_8327", (9, TyVarRecord NoLoc (M.fromList [("tree_level", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8320_8326" 17137}) []))]))), ("t_8321_8321_8328", (10, TyVarFree NoLoc Lifted)), ("kt_8321_8321_8329", (11, TyVarFree NoLoc Lifted)), ("t_8321_8322_8320", (11, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8321_8329" 17153}) []))]))), ("kt_8321_8322_8321", (11, TyVarFree NoLoc Lifted)), ("t_8321_8322_8322", (11, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8322_8321" 17155}) []))]))), ("t_8321_8322_8323", (12, TyVarFree NoLoc Lifted)), ("kt_8321_8322_8324", (13, TyVarFree NoLoc Lifted)), ("t_8321_8322_8325", (13, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8322_8324" 17158}) []))]))), ("kt_8321_8322_8326", (13, TyVarFree NoLoc Lifted)), ("t_8321_8322_8327", (13, TyVarRecord NoLoc (M.fromList [("mass", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8322_8326" 17160}) []))]))), ("t_8321_8322_8328", (14, TyVarFree NoLoc Lifted)), ("t_8321_8322_8329", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8328", (16, TyVarFree NoLoc Lifted)), ("kt_8321_8323_8329", (17, TyVarFree NoLoc Lifted)), ("t_8321_8324_8320", (17, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8323_8329" 17175}) []))]))), ("t_8321_8324_8321", (18, TyVarFree NoLoc Lifted)), ("t_8321_8324_8322", (19, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8321_8324_8323", (19, TyVarFree NoLoc Lifted)), ("t_8321_8324_8324", (19, TyVarRecord NoLoc (M.fromList [("x", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8324_8323" 17179}) []))]))), ("kt_8321_8324_8325", (19, TyVarFree NoLoc Lifted)), ("t_8321_8324_8326", (19, TyVarRecord NoLoc (M.fromList [("x", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8324_8325" 17181}) []))]))), ("t_8321_8325_8321", (20, TyVarFree NoLoc Lifted)), ("t_8321_8325_8322", (21, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8321_8325_8323", (21, TyVarFree NoLoc Lifted)), ("t_8321_8325_8324", (21, TyVarRecord NoLoc (M.fromList [("y", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8325_8323" 17190}) []))]))), ("kt_8321_8325_8325", (21, TyVarFree NoLoc Lifted)), ("t_8321_8325_8326", (21, TyVarRecord NoLoc (M.fromList [("y", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8325_8325" 17192}) []))]))), ("t_8321_8326_8321", (22, TyVarFree NoLoc Lifted)), ("t_8321_8326_8322", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8321_8326_8323", (23, TyVarFree NoLoc Lifted)), ("t_8321_8326_8324", (23, TyVarRecord NoLoc (M.fromList [("z", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8326_8323" 17201}) []))]))), ("kt_8321_8326_8325", (23, TyVarFree NoLoc Lifted)), ("t_8321_8326_8326", (23, TyVarRecord NoLoc (M.fromList [("z", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8326_8325" 17203}) []))]))), ("t_8321_8327_8321", (24, TyVarFree NoLoc Lifted)), ("t_8321_8327_8322", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327_8323", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327_8324", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327_8329", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8328_8328", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8329_8327", (20, TyVarFree NoLoc Lifted)), ("t_8321_8329_8328", (21, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8325", (22, TyVarFree NoLoc Lifted)), ("t_8322_8320_8326", (23, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8327", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8328", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8320_8329", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8321_8324", (23, TyVarFree NoLoc Lifted)), ("t_8322_8321_8325", (23, TyVarRecord NoLoc (M.fromList [("tree_level", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8321_8324" 17264}) []))]))), ("num_8322_8322_8320", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8322_8325", (24, TyVarFree NoLoc Lifted)), ("t_8322_8322_8326", (25, TyVarPrim NoLoc [Bool])), ("t_8322_8322_8327", (25, TyVarPrim NoLoc [Bool])), ("kt_8322_8322_8328", (25, TyVarFree NoLoc Lifted)), ("t_8322_8322_8329", (25, TyVarRecord NoLoc (M.fromList [("is_leaf", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8322_8328" 17280}) []))]))), ("t_8322_8323_8324", (25, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8329", (26, TyVarFree NoLoc Lifted)), ("kt_8322_8325_8324", (27, TyVarFree NoLoc Lifted)), ("t_8322_8325_8325", (27, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8325_8324" 17311}) []))]))), ("t_8322_8325_8326", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8325_8327", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8326_8322", (25, TyVarFree NoLoc Lifted)), ("t_8322_8326_8323", (25, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoUniqueness (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8326_8322" 17322}) []))]))), ("t_8322_8326_8324", (26, TyVarFree NoLoc Lifted)), ("a_8322_8326_8325", (27, TyVarFree NoLoc Lifted)), ("b_8322_8326_8326", (27, TyVarFree NoLoc Lifted)), ("a_8322_8326_8327", (27, TyVarFree NoLoc Unlifted)), ("x_8322_8326_8328", (27, TyVarFree NoLoc Unlifted)), ("a_8322_8326_8329", (27, TyVarFree NoLoc Lifted)), ("b_8322_8327_8320", (27, TyVarFree NoLoc Lifted)), ("c_8322_8327_8321", (27, TyVarFree NoLoc Lifted)), ("t_8322_8327_8322", (27, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8327_8323", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8327_8324", (27, TyVarFree NoLoc Lifted)), ("a_8322_8328_8327", (27, TyVarFree NoLoc Unlifted)), ("t_8322_8328_8328", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8328_8329", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8329_8328", (28, TyVarFree NoLoc Lifted)), ("num_8322_8329_8329", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8320_8320", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8320_8321", (29, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8320_8322", (29, TyVarFree NoLoc Unlifted)), ("t_8323_8320_8323", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8320_8324", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8320_8329", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8323_8321_8324", (25, TyVarFree NoLoc SizeLifted)), ("if_t_8323_8321_8325", (9, TyVarFree NoLoc SizeLifted)), ("t_8323_8321_8326", (6, TyVarFree NoLoc Lifted)), ("t_8323_8321_8327", (6, TyVarFree NoLoc Lifted)), ("t_8323_8321_8328", (6, TyVarFree NoLoc Lifted)), ("t_8323_8321_8329", (6, TyVarFree NoLoc Lifted)), ("t_8322_8326_8324_8323_8322_8320", (26, TyVarFree NoLoc Lifted)), ("a_8322_8326_8325_8323_8322_8321", (27, TyVarFree NoLoc Lifted)), ("kt_8322_8326_8322_8323_8322_8322", (25, TyVarFree NoLoc Lifted)), ("kt_8329_8321_8323_8322_8323", (11, TyVarFree NoLoc Lifted)), ("kt_8326_8328_8323_8322_8324", (11, TyVarFree NoLoc Lifted)), ("kt_8324_8324_8323_8322_8325", (9, TyVarFree NoLoc Lifted))]+      M.fromList [("num_8320", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8321", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324", (5, TyVarFree NoLoc Lifted)), ("t_8325", (5, TyVarFree NoLoc Lifted)), ("t_8326", (5, TyVarFree NoLoc Lifted)), ("t_8327", (5, TyVarFree NoLoc Lifted)), ("t_8328", (5, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8329", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8324", (5, TyVarPrim NoLoc [Bool])), ("t_8321_8325", (5, TyVarFree NoLoc Unlifted)), ("num_8321_8326", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8322", (5, TyVarFree NoLoc Unlifted)), ("t_8322_8323", (5, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8322_8324", (5, TyVarFree NoLoc Unlifted)), ("index_elem_8322_8325", (5, TyVarFree NoLoc Unlifted)), ("kt_8322_8326", (5, TyVarFree NoLoc Lifted)), ("t_8322_8327", (5, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8326" 17047}) []))]))), ("t_8323_8326", (6, TyVarFree NoLoc Lifted)), ("t_8323_8327", (7, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8328", (7, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8329", (7, TyVarFree NoLoc Unlifted)), ("t_8324_8320", (8, TyVarFree NoLoc Lifted)), ("num_8324_8321", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8324_8322", (9, TyVarFree NoLoc Lifted)), ("t_8324_8323", (9, TyVarFree NoLoc Unlifted)), ("kt_8324_8324", (9, TyVarFree NoLoc Lifted)), ("t_8324_8325", (9, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8324_8324" 17068}) []))]))), ("t_8324_8326", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8324_8327", (9, TyVarFree NoLoc Unlifted)), ("index_elem_8324_8328", (9, TyVarFree NoLoc Unlifted)), ("t_8325_8323", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8325_8324", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8325_8329", (10, TyVarFree NoLoc Lifted)), ("t_8326_8320", (11, TyVarPrim NoLoc [Bool])), ("t_8326_8321", (11, TyVarFree NoLoc Unlifted)), ("num_8326_8322", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8326_8327", (11, TyVarFree NoLoc Unlifted)), ("kt_8326_8328", (11, TyVarFree NoLoc Lifted)), ("t_8326_8329", (11, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8326_8328" 17095}) []))]))), ("t_8327_8320", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8327_8321", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8327_8326", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8327_8327", (11, TyVarFree NoLoc Unlifted)), ("index_elem_8327_8328", (11, TyVarFree NoLoc Unlifted)), ("num_8327_8329", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8328_8320", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8328_8329", (11, TyVarFree NoLoc Lifted)), ("t_8329_8320", (11, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8328_8329" 17119}) []))]))), ("kt_8329_8321", (11, TyVarFree NoLoc Lifted)), ("t_8329_8322", (11, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8329_8321" 17121}) []))]))), ("t_8329_8323", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8329_8324", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8329_8329", (11, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8321_8320_8320", (11, TyVarFree NoLoc Unlifted)), ("index_elem_8321_8320_8321", (11, TyVarFree NoLoc Unlifted)), ("if_t_8321_8320_8322", (11, TyVarFree NoLoc SizeLifted)), ("t_8321_8320_8323", (12, TyVarFree NoLoc Lifted)), ("t_8321_8320_8324", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8320_8325", (9, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8321_8320_8326", (9, TyVarFree NoLoc Lifted)), ("t_8321_8320_8327", (9, TyVarRecord NoLoc (M.fromList [("tree_level", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8320_8326" 17137}) []))]))), ("t_8321_8321_8328", (10, TyVarFree NoLoc Lifted)), ("kt_8321_8321_8329", (11, TyVarFree NoLoc Lifted)), ("t_8321_8322_8320", (11, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8321_8329" 17153}) []))]))), ("kt_8321_8322_8321", (11, TyVarFree NoLoc Lifted)), ("t_8321_8322_8322", (11, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8322_8321" 17155}) []))]))), ("t_8321_8322_8323", (12, TyVarFree NoLoc Lifted)), ("kt_8321_8322_8324", (13, TyVarFree NoLoc Lifted)), ("t_8321_8322_8325", (13, TyVarRecord NoLoc (M.fromList [("body", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8322_8324" 17158}) []))]))), ("kt_8321_8322_8326", (13, TyVarFree NoLoc Lifted)), ("t_8321_8322_8327", (13, TyVarRecord NoLoc (M.fromList [("mass", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8322_8326" 17160}) []))]))), ("t_8321_8322_8328", (14, TyVarFree NoLoc Lifted)), ("t_8321_8322_8329", (15, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8323_8328", (16, TyVarFree NoLoc Lifted)), ("kt_8321_8323_8329", (17, TyVarFree NoLoc Lifted)), ("t_8321_8324_8320", (17, TyVarRecord NoLoc (M.fromList [("position", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8323_8329" 17175}) []))]))), ("t_8321_8324_8321", (18, TyVarFree NoLoc Lifted)), ("t_8321_8324_8322", (19, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8321_8324_8323", (19, TyVarFree NoLoc Lifted)), ("t_8321_8324_8324", (19, TyVarRecord NoLoc (M.fromList [("x", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8324_8323" 17179}) []))]))), ("kt_8321_8324_8325", (19, TyVarFree NoLoc Lifted)), ("t_8321_8324_8326", (19, TyVarRecord NoLoc (M.fromList [("x", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8324_8325" 17181}) []))]))), ("t_8321_8325_8321", (20, TyVarFree NoLoc Lifted)), ("t_8321_8325_8322", (21, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8321_8325_8323", (21, TyVarFree NoLoc Lifted)), ("t_8321_8325_8324", (21, TyVarRecord NoLoc (M.fromList [("y", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8325_8323" 17190}) []))]))), ("kt_8321_8325_8325", (21, TyVarFree NoLoc Lifted)), ("t_8321_8325_8326", (21, TyVarRecord NoLoc (M.fromList [("y", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8325_8325" 17192}) []))]))), ("t_8321_8326_8321", (22, TyVarFree NoLoc Lifted)), ("t_8321_8326_8322", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8321_8326_8323", (23, TyVarFree NoLoc Lifted)), ("t_8321_8326_8324", (23, TyVarRecord NoLoc (M.fromList [("z", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8326_8323" 17201}) []))]))), ("kt_8321_8326_8325", (23, TyVarFree NoLoc Lifted)), ("t_8321_8326_8326", (23, TyVarRecord NoLoc (M.fromList [("z", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8321_8326_8325" 17203}) []))]))), ("t_8321_8327_8321", (24, TyVarFree NoLoc Lifted)), ("t_8321_8327_8322", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327_8323", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327_8324", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8327_8329", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8328_8328", (25, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8321_8329_8327", (20, TyVarFree NoLoc Lifted)), ("t_8321_8329_8328", (21, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8325", (22, TyVarFree NoLoc Lifted)), ("t_8322_8320_8326", (23, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8327", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8320_8328", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8320_8329", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8321_8324", (23, TyVarFree NoLoc Lifted)), ("t_8322_8321_8325", (23, TyVarRecord NoLoc (M.fromList [("tree_level", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8321_8324" 17264}) []))]))), ("num_8322_8322_8320", (23, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8322_8325", (24, TyVarFree NoLoc Lifted)), ("t_8322_8322_8326", (25, TyVarPrim NoLoc [Bool])), ("t_8322_8322_8327", (25, TyVarPrim NoLoc [Bool])), ("kt_8322_8322_8328", (25, TyVarFree NoLoc Lifted)), ("t_8322_8322_8329", (25, TyVarRecord NoLoc (M.fromList [("is_leaf", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8322_8328" 17280}) []))]))), ("t_8322_8323_8324", (25, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8324_8329", (26, TyVarFree NoLoc Lifted)), ("kt_8322_8325_8324", (27, TyVarFree NoLoc Lifted)), ("t_8322_8325_8325", (27, TyVarRecord NoLoc (M.fromList [("parent", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8325_8324" 17311}) []))]))), ("t_8322_8325_8326", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8325_8327", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("kt_8322_8326_8322", (25, TyVarFree NoLoc Lifted)), ("t_8322_8326_8323", (25, TyVarRecord NoLoc (M.fromList [("children", Scalar (TypeVar NoMode (QualName {qualQuals = [], qualLeaf = VName "kt_8322_8326_8322" 17322}) []))]))), ("t_8322_8326_8324", (26, TyVarFree NoLoc Lifted)), ("a_8322_8326_8325", (27, TyVarFree NoLoc Lifted)), ("b_8322_8326_8326", (27, TyVarFree NoLoc Lifted)), ("a_8322_8326_8327", (27, TyVarFree NoLoc Unlifted)), ("x_8322_8326_8328", (27, TyVarFree NoLoc Unlifted)), ("a_8322_8326_8329", (27, TyVarFree NoLoc Lifted)), ("b_8322_8327_8320", (27, TyVarFree NoLoc Lifted)), ("c_8322_8327_8321", (27, TyVarFree NoLoc Lifted)), ("t_8322_8327_8322", (27, TyVarPrim NoLoc [Bool, Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8327_8323", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8327_8324", (27, TyVarFree NoLoc Lifted)), ("a_8322_8328_8327", (27, TyVarFree NoLoc Unlifted)), ("t_8322_8328_8328", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8322_8328_8329", (27, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8322_8329_8328", (28, TyVarFree NoLoc Lifted)), ("num_8322_8329_8329", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8320_8320", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64])), ("index_8323_8320_8321", (29, TyVarFree NoLoc Unlifted)), ("index_elem_8323_8320_8322", (29, TyVarFree NoLoc Unlifted)), ("t_8323_8320_8323", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("t_8323_8320_8324", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("num_8323_8320_8329", (29, TyVarPrim NoLoc [Signed Int8, Signed Int16, Signed Int32, Signed Int64, Unsigned Int8, Unsigned Int16, Unsigned Int32, Unsigned Int64, FloatType Float16, FloatType Float32, FloatType Float64])), ("if_t_8323_8321_8324", (25, TyVarFree NoLoc SizeLifted)), ("if_t_8323_8321_8325", (9, TyVarFree NoLoc SizeLifted)), ("t_8323_8321_8326", (6, TyVarFree NoLoc Lifted)), ("t_8323_8321_8327", (6, TyVarFree NoLoc Lifted)), ("t_8323_8321_8328", (6, TyVarFree NoLoc Lifted)), ("t_8323_8321_8329", (6, TyVarFree NoLoc Lifted)), ("t_8322_8326_8324_8323_8322_8320", (26, TyVarFree NoLoc Lifted)), ("a_8322_8326_8325_8323_8322_8321", (27, TyVarFree NoLoc Lifted)), ("kt_8322_8326_8322_8323_8322_8322", (25, TyVarFree NoLoc Lifted)), ("kt_8329_8321_8323_8322_8323", (11, TyVarFree NoLoc Lifted)), ("kt_8326_8328_8323_8322_8324", (11, TyVarFree NoLoc Lifted)), ("kt_8324_8324_8323_8322_8325", (9, TyVarFree NoLoc Lifted))]     ),     ( [ "t_8326_8327" ~ "[]t_8326_8327_8327_8328",         "t_8326_8328" ~ "[]t_8326_8328_8327_8329",
src-testing/Language/Futhark/SyntaxTests.hs view
@@ -26,8 +26,8 @@ instance Arbitrary BinOp where   arbitrary = elements [minBound .. maxBound] -instance Arbitrary Uniqueness where-  arbitrary = elements [Unique, Nonunique]+instance Arbitrary Freshness where+  arbitrary = elements [Fresh, Nonfresh]  instance Arbitrary PrimType where   arbitrary =@@ -119,8 +119,8 @@   where     f t = keyword (prettyText t) $> t -pUniqueness :: Parser Uniqueness-pUniqueness = choice [lexeme "*" $> Unique, pure Nonunique]+pFreshness :: Parser Freshness+pFreshness = choice [lexeme "*" $> Fresh, pure Nonfresh]  pSize :: Parser Size pSize =@@ -130,7 +130,7 @@         flip sizeFromName mempty <$> pQualVName       ] -pScalarNonFun :: Parser d -> Parser (ScalarTypeBase d Uniqueness)+pScalarNonFun :: Parser d -> Parser (ScalarTypeBase d Freshness) pScalarNonFun pd =   choice     [ Prim <$> pPrimType,@@ -140,11 +140,11 @@     ]   where     pField = (,) <$> pName <* lexeme ":" <*> pType pd-    pTypeVar = TypeVar <$> pUniqueness <*> pQualVName <*> many pTypeArg+    pTypeVar = TypeVar <$> pFreshness <*> pQualVName <*> many pTypeArg     pTypeArg =       choice         [ TypeArgDim <$> pd,-          TypeArgType . second (const NoUniqueness) <$> pTypeArgType+          TypeArgType . second (const NoMode) <$> pTypeArgType         ]     pTypeArgType =       choice@@ -152,14 +152,14 @@           parens $ pType pd         ] -pArrayType :: Parser d -> Parser (TypeBase d Uniqueness)+pArrayType :: Parser d -> Parser (TypeBase d Freshness) pArrayType pd =   Array-    <$> pUniqueness+    <$> pFreshness     <*> (Shape <$> some pd)-    <*> (second (const NoUniqueness) <$> pScalarNonFun pd)+    <*> (second (const NoMode) <$> pScalarNonFun pd) -pNonFunType :: Parser d -> Parser (TypeBase d Uniqueness)+pNonFunType :: Parser d -> Parser (TypeBase d Freshness) pNonFunType pd =   choice     [ try $ pArrayType pd,@@ -167,11 +167,11 @@       Scalar <$> pScalarNonFun pd     ] -uniquenessToDiet :: Uniqueness -> Diet-uniquenessToDiet Unique = Consume-uniquenessToDiet Nonunique = Observe+freshnessToDiet :: Freshness -> Diet+freshnessToDiet Fresh = Consume+freshnessToDiet Nonfresh = Observe -pScalarType :: Parser d -> Parser (ScalarTypeBase d Uniqueness)+pScalarType :: Parser d -> Parser (ScalarTypeBase d Freshness) pScalarType pd = choice [try pFun, pScalarNonFun pd]   where     pFun =@@ -181,21 +181,21 @@         [ try pNamedParam,           do             t <- pNonFunType pd-            pure $ Arrow Nonunique Unnamed (diet $ second uniquenessToDiet t) (toStruct t)+            pure $ Arrow Nonfresh Unnamed (diet $ second freshnessToDiet t) (toStruct t)         ]     pNamedParam = parens $ do       v <- pVName <* lexeme ":"       t <- pType pd-      pure $ Arrow Nonunique (Named v) (diet $ second uniquenessToDiet t) (toStruct t)+      pure $ Arrow Nonfresh (Named v) (diet $ second freshnessToDiet t) (toStruct t) -pRetType :: Parser d -> Parser (RetTypeBase d Uniqueness)+pRetType :: Parser d -> Parser (RetTypeBase d Freshness) pRetType pd =   choice     [ lexeme "?" *> (RetType <$> some (brackets pVName) <* lexeme "." <*> pType pd),       RetType [] <$> pType pd     ] -pType :: Parser d -> Parser (TypeBase d Uniqueness)+pType :: Parser d -> Parser (TypeBase d Freshness) pType pd =   choice [try $ Scalar <$> pScalarType pd, pArrayType pd, parens (pType pd)] @@ -206,27 +206,27 @@     onError e =       error $ "not a " <> what <> ": " <> s <> "\n" <> errorBundlePretty e -instance IsString (ScalarTypeBase Size NoUniqueness) where+instance IsString (ScalarTypeBase Size NoMode) where   fromString =     fromStringParse-      (second (const NoUniqueness) <$> pScalarType pSize)+      (second (const NoMode) <$> pScalarType pSize)       "ScalarType" -instance IsString (ScalarTypeBase () NoUniqueness) where+instance IsString (ScalarTypeBase () NoMode) where   fromString =     fromStringParse-      (second (const NoUniqueness) <$> pScalarType (pure ()))+      (second (const NoMode) <$> pScalarType (pure ()))       "ScalarType" -instance IsString (TypeBase () NoUniqueness) where+instance IsString (TypeBase () NoMode) where   fromString =     fromStringParse-      (second (const NoUniqueness) <$> pType (brackets $ pure ()))+      (second (const NoMode) <$> pType (brackets $ pure ()))       "Type"  instance IsString StructType where   fromString =-    fromStringParse (second (const NoUniqueness) <$> pType pSize) "StructType"+    fromStringParse (second (const NoMode) <$> pType pSize) "StructType"  instance IsString ParamType where   fromString =@@ -238,7 +238,7 @@  instance IsString StructRetType where   fromString =-    fromStringParse (second (pure NoUniqueness) <$> pRetType pSize) "StructRetType"+    fromStringParse (second (pure NoMode) <$> pRetType pSize) "StructRetType"  instance IsString ResRetType where   fromString = fromStringParse (pRetType pSize) "ResRetType"
src-testing/Language/Futhark/TypeChecker/ConsumptionTests.hs view
@@ -16,48 +16,51 @@   testGroup     "ConsumptionTests"     [ testGroup-        "inferReturnUniqueness"+        "inferReturnFreshness"         [ testCase "*[]i32" $-            inferReturnUniqueness+            inferReturnFreshness               [Id "x_1" (Info "[2]i32") mempty]               "[2]i32"               (second (const mempty) ("[2]i32" :: StructType))               @?= "*[2]i32",           --           testCase "[]i32" $-            inferReturnUniqueness+            inferReturnFreshness               [Id "x_1" (Info "[2]i32") mempty]               "[2]i32"               ( second-                  (const (S.singleton (AliasBound "x_1" [])))+                  (const (S.singleton (AliasBound ("x_1", []))))                   ("[2]i32" :: StructType)               )               @?= "[2]i32",           --           testCase "([]i32,[]i32)" $-            inferReturnUniqueness+            inferReturnFreshness               [Id "x_1" (Info "[2]i32") mempty]               "([2]i32, [2]i32)"               ( second-                  (const (S.singleton (AliasFree "y_2" [])))+                  (const (S.singleton (AliasFree ("y_2", []))))                   ("([2]i32,[2]i32)" :: StructType)               )               @?= "([2]i32, [2]i32)",           --+          -- An opaque value that may have internal aliasing cannot be given+          -- a fresh type.  See Note [Parametric results] in+          -- Language.Futhark.TypeChecker.Consumption.           testCase "opaque" $-            let t = Scalar (TypeVar Nonunique (qualName "t_2") [])-             in inferReturnUniqueness+            let t = Scalar (TypeVar Nonfresh (qualName "t_2") [])+             in inferReturnFreshness                   [Id "n_1" (Info "i64") mempty]                   t-                  (second (const (S.singleton (AliasFree "y_3" []))) t)-                  @?= (t `setUniqueness` Nonunique),+                  (second (const (S.singleton AliasSelf)) t)+                  @?= (t `setMode` Nonfresh),           --           testCase "*opaque" $-            let t = Scalar (TypeVar Nonunique (qualName "t_2") [])-             in inferReturnUniqueness+            let t = Scalar (TypeVar Nonfresh (qualName "t_2") [])+             in inferReturnFreshness                   [Id "n_1" (Info "i64") mempty]                   t                   (second (const mempty) t)-                  @?= (t `setUniqueness` Unique)+                  @?= (t `setMode` Fresh)         ]     ]
src-testing/Language/Futhark/TypeChecker/TySolveBenchmarks.hs view
@@ -17,7 +17,7 @@ import Language.Futhark.TypeChecker.Monad (TypeError (..)) import Language.Futhark.TypeChecker.TySolve as N (Solution, UnconTyVar, solve) -(~) :: TypeBase () NoUniqueness -> TypeBase () NoUniqueness -> CtTy ()+(~) :: TypeBase () NoMode -> TypeBase () NoMode -> CtTy () t1 ~ t2 = CtEq (Reason mempty) t1 t2  tv :: VName -> Level -> (VName, (Level, TyVarInfo ()))@@ -47,8 +47,8 @@            ty_vars = M.fromList $ map (`tv` 0) var_names -          mkTy :: VName -> TypeBase () NoUniqueness-          mkTy v = Scalar (TypeVar NoUniqueness (qualName v) [])+          mkTy :: VName -> TypeBase () NoMode+          mkTy v = Scalar (TypeVar NoMode (qualName v) [])            cts =             zipWith
src-testing/Language/Futhark/TypeChecker/TySolveTests.hs view
@@ -47,13 +47,13 @@ -- the numbers are distinct. These are all that actually matter for -- determining identity. -(~) :: TypeBase () NoUniqueness -> TypeBase () NoUniqueness -> CtTy ()+(~) :: TypeBase () NoMode -> TypeBase () NoMode -> CtTy () t1 ~ t2 = CtEq (Reason mempty) t1 t2  tvFree :: VName -> Level -> (VName, (Level, TyVarInfo ())) tvFree v lvl = (v, (lvl, TyVarFree mempty Unlifted)) -tvRecord :: VName -> Level -> M.Map Name (TypeBase () NoUniqueness) -> (VName, (Level, TyVarInfo ()))+tvRecord :: VName -> Level -> M.Map Name (TypeBase () NoMode) -> (VName, (Level, TyVarInfo ())) tvRecord v lvl fields = (v, (lvl, TyVarRecord mempty fields))  typaram :: VName -> Level -> Liftedness -> (VName, (Level, Liftedness, Loc))
src/Futhark/AD/Derivatives.hs view
@@ -77,7 +77,7 @@   intBinOp derivs derivs derivs derivs it a b   where     derivs x y = (1 `quot` y, negate (x `quot` (y * y)))-pdBinOp (SDivUp it _) a b =+pdBinOp (SCeilDiv it _) a b =   intBinOp derivs derivs derivs derivs it a b   where     derivs x y = (1 `quot` y, negate (x `quot` (y * y)))@@ -89,7 +89,7 @@   intBinOp derivs derivs derivs derivs it a b   where     derivs x y = (1 `quot` y, negate (x `quot` (y * y)))-pdBinOp (UDivUp it _) a b =+pdBinOp (UCeilDiv it _) a b =   intBinOp derivs derivs derivs derivs it a b   where     derivs x y = (1 `quot` y, negate (x `quot` (y * y)))
src/Futhark/AD/Fwd.hs view
@@ -36,17 +36,17 @@ instance FromShape ExtShape where   fromShape = fmap Free -tanType :: (FromShape s, Monoid u) => TypeBase s u -> ADM (TypeBase s u)-tanType (Acc acc ispace ts u) = do+tanType :: (FromShape s, Monoid o) => TypeBase s o -> ADM (TypeBase s o)+tanType (Acc acc ispace ts) = do   acc_tan <- tangent acc   tan_shape <- askShape-  pure $ Acc acc_tan (tan_shape <> ispace) ts u+  pure $ Acc acc_tan (tan_shape <> ispace) ts tanType t = do   shape <- askShape-  pure $ arrayOf (Prim (elemType t)) (fromShape shape <> arrayShape t) u+  pure $ arrayOf (Prim (elemType t)) (fromShape shape <> arrayShape t) o   where-    u = case t of-      Array _ _ u' -> u'+    o = case t of+      Array _ _ o' -> o'       _ -> mempty  slocal' :: ADM a -> ADM a@@ -123,7 +123,7 @@ bundleNewList :: (TanBuilder a) => [a] -> ADM [a] bundleNewList = fmap (uncurry interleave . unzip) . mapM bundleNew -instance (FromShape s, Monoid u) => TanBuilder (PatElem (TypeBase s u)) where+instance (FromShape s, Monoid o) => TanBuilder (PatElem (TypeBase s o)) where   newTan (PatElem p t) = do     p' <- tanVName p     insertTan p p'@@ -139,7 +139,7 @@ bundleNewPat :: (TanBuilder (PatElem t)) => Pat t -> ADM (Pat t) bundleNewPat (Pat pes) = Pat <$> bundleNewList pes -instance (FromShape s, Monoid u) => TanBuilder (Param (TypeBase s u)) where+instance (FromShape s, Monoid o) => TanBuilder (Param (TypeBase s o)) where   newTan (Param _ p t) = do     PatElem p' t' <- newTan $ PatElem p t     pure $ Param mempty p' t'@@ -158,7 +158,7 @@   tangent :: a -> ADM a   bundleTan :: a -> ADM (a, a) -instance (FromShape s, Monoid u) => Tangent (TypeBase s u) where+instance (FromShape s, Monoid o) => Tangent (TypeBase s o) where   tangent = tanType   bundleTan t = do     t' <- tangent t@@ -426,7 +426,7 @@     mkAccParam c (shape, arrs, _) = do       tan_shape <- askShape       ts <- map (stripArray (shapeRank shape)) <$> mapM lookupType arrs-      newParam "acc_p_tan" $ Acc c (tan_shape <> shape) ts NoUniqueness+      newParam "acc_p_tan" $ Acc c (tan_shape <> shape) ts  fwdStreamLambda :: Int -> Lambda SOACS -> ADM (Lambda SOACS) fwdStreamLambda num_accs (Lambda params _ body) = do@@ -628,7 +628,7 @@                 where                   e_t = primExpType e -          auxing aux . letBind pat_tan <=< withAnyTans (map fst args) $+          bindTanPat pat_tan aux <=< withAnyTans (map fst args) $             \arg_tans' ->               foldl1 (~+~) $ zipWith (~*~) (map (convertTo ret) arg_tans') derivs fwdStm (Let pat aux (Match ses cases defbody (MatchDec ret ifsort))) = do
src/Futhark/AD/Rev/Acc.hs view
@@ -231,7 +231,7 @@             }     onStms = fmap onStm     onStm (Let (Pat [pe]) aux (BasicOp (UpdateAcc safety acc is _)))-      | Acc c _ _ _ <- patElemType pe,+      | Acc c _ _ <- patElemType pe,         Just zero <- lookup c certs_to_zeroes =           Let (Pat [pe]) aux (BasicOp (UpdateAcc safety acc is zero))     onStm (Let pat aux e) = Let pat aux $ onExp e@@ -262,9 +262,9 @@       p {paramDec = updateAccType certs (paramDec p)}      updateAccType :: [VName] -> Type -> Type-    updateAccType certs (Acc cert acc_shape ts u)+    updateAccType certs (Acc cert acc_shape ts)       | cert `elem` certs =-          Acc cert acc_shape (map (`arrayOfShape` adj_sh) ts) u+          Acc cert acc_shape (map (`arrayOfShape` adj_sh) ts)     updateAccType _ t = t      updateBody :: [VName] -> Body SOACS -> Body SOACS@@ -435,7 +435,7 @@     -- An accumulator with a combining operator does not overwrite, so the     -- incoming value of the updated cell retains its full sensitivity.     overwrites <- case acc_t of-      Acc cert _ _ _ -> not <$> isOperatorAcc cert+      Acc cert _ _ -> not <$> isOperatorAcc cert       _ -> pure True     let elem_t = stripArray (length is) adj_t         slice = fullSlice adj_t $ map DimFix is
src/Futhark/AD/Rev/Hist.hs view
@@ -68,7 +68,7 @@ nestedmap :: [SubExp] -> [PrimType] -> Lambda SOACS -> ADM (Lambda SOACS) nestedmap [] _ lam = pure lam nestedmap s@(h : r) pt lam = do-  params <- traverse (\tp -> newParam "x" $ Array tp (Shape s) NoUniqueness) pt+  params <- traverse (\tp -> newParam "x" $ Array tp (Shape s) NoMode) pt   body <- nestedmap r pt lam   mkLambda params $     fmap varsRes . letTupExp "res" . Op . Screma h (map paramName params)@@ -232,7 +232,7 @@         letExp "res" . Op . Screma n [iota_n] =<< mapSOAC lam    let hist_op = HistOp (Shape [w]) rf [dst_cpy, dst_minus_ones] [ne, if nr_dims == 1 then intConst Int64 (-1) else ne_minus_ones] hist_lam-  f' <- mkIdentityLambda [Prim int64, rowType vs_type, rowType $ Array int64 (Shape vs_dims) NoUniqueness]+  f' <- mkIdentityLambda [Prim int64, rowType vs_type, rowType $ Array int64 (Shape vs_dims) NoMode]   x_inds <- newVName (baseName x <> "_inds")   auxing aux $     letBindNames [x, x_inds] $@@ -389,7 +389,7 @@   zrn_ne <- letSubExp "zr_ne" $ BasicOp $ Replicate (Shape inner_dims) (intConst Int64 0)   let hist_zrn = HistOp (Shape [w]) rf [zr_counts0] [if length vs_dims == 1 then intConst Int64 0 else zrn_ne] lam_add -  f' <- mkIdentityLambda [Prim int64, Prim int64, rowType vs_type, rowType $ Array int64 (Shape vs_dims) NoUniqueness]+  f' <- mkIdentityLambda [Prim int64, Prim int64, rowType vs_type, rowType $ Array int64 (Shape vs_dims) NoMode]   nz_prods <- newVName "non_zero_prod"   zr_counts <- newVName "zero_count"   auxing aux $@@ -563,7 +563,7 @@     f <- mkIdentityLambda (Prim int64 : lambdaReturnType op)     map_lam <-       mkLambda [dst_col, vss_col, ne] $ do-        -- TODO Have to copy dst_col, but isn't it already unique?+        -- TODO Have to copy dst_col, but isn't it already fresh?         dst_col_cpy <-           letExp "dst_col_cpy" . BasicOp $             Replicate mempty (Var $ paramName dst_col)@@ -696,7 +696,7 @@   iters <- letSubExp "iters" =<< toExp (untyped (pe64 logw + 1) ~/~ untyped (pe64 (intConst Int64 2)))    types <- traverse lookupType xs-  params <- zipWithM (\x -> newParam (baseName x) . flip toDecl Nonunique) xs types+  params <- zipWithM (\x -> newParam (baseName x) . flip toDecl Observe) xs types   i <- newVName "i"   loopbody <- buildBody_ . localScope (scopeOfFParams params) $     fmap varsRes $ do
src/Futhark/AD/Rev/Loop.hs view
@@ -204,7 +204,7 @@     empty_saved_array <-       forM loop_params_to_copy $ \p ->         letSubExp (baseName (paramName p) <> "_empty_saved")-          =<< eBlank (arrayOf (paramDec p) (Shape [bound64]) NoUniqueness)+          =<< eBlank (arrayOf (paramDec p) (Shape [bound64]) NoMode)      (body', (saved_pats, saved_params)) <- buildBody $       localScope (scopeOfFParams loop_params) $@@ -219,8 +219,8 @@               saved_param_v <- newVName $ baseName v <> "_saved"               saved_pat_v <- newVName $ baseName v <> "_saved"               setLoopTape v saved_pat_v-              let saved_param = Param mempty saved_param_v $ arrayOf t (Shape [bound64]) Unique-                  saved_pat = PatElem saved_pat_v $ arrayOf t (Shape [bound64]) NoUniqueness+              let saved_param = Param mempty saved_param_v $ arrayOf t (Shape [bound64]) Consume+                  saved_pat = PatElem saved_pat_v $ arrayOf t (Shape [bound64]) NoMode               saved_update <-                 localScope (scopeOfFParams [saved_param])                   $ letInPlace@@ -245,7 +245,7 @@   v_adj <- adjVName v   init_adj <- lookupAdjVal v   t <- lookupType init_adj-  pure (Param mempty v_adj (toDecl t Unique), Var init_adj)+  pure (Param mempty v_adj (toDecl t Consume), Var init_adj)  valPatAdjs :: LoopInfo [VName] -> ADM (LoopInfo [(Param DeclType, SubExp)]) valPatAdjs = (mapM . mapM) valPatAdj
src/Futhark/AD/Rev/Map.hs view
@@ -74,7 +74,7 @@     forM inputs $ \(shape, arrs, _) -> do       cert_param <- newParam "acc_cert_p" $ Prim Unit       ts <- mapM (fmap (stripArray (shapeRank shape)) . lookupType) arrs-      acc_param <- newParam "acc_p" $ Acc (paramName cert_param) shape ts NoUniqueness+      acc_param <- newParam "acc_p" $ Acc (paramName cert_param) shape ts       pure (cert_param, acc_param)   acc_lam <-     subAD $ mkLambda (cert_params ++ acc_params) $ m $ map paramName acc_params
src/Futhark/AD/Rev/Monad.hs view
@@ -429,8 +429,8 @@     Nothing -> do       v_t <- lookupType v       case v_t of-        Acc _ shape [Prim t] _ -> pure $ AdjZero shape t-        Acc _ shape [t] _ -> pure $ AdjZero (shape <> arrayShape t) (elemType t)+        Acc _ shape [Prim t] -> pure $ AdjZero shape t+        Acc _ shape [t] -> pure $ AdjZero (shape <> arrayShape t) (elemType t)         Acc {} -> error $ "lookupAdj: Non-singleton accumulator adjoint: " <> prettyString v_t         _ -> pure $ AdjZero (adj_shape <> arrayShape v_t) (elemType v_t)     Just v_adj -> pure v_adj@@ -683,11 +683,10 @@ -- --  let ys_copy = copy ys ----- Then we generate code for the return sweep as normal, but replace--- _every instance_ of 'ys' in the generated code with 'ys_copy'.--- This works because Futhark does not have *semantic* in-place--- updates - any uniqueness violation can be replaced with copies (on--- arrays, anyway).+-- Then we generate code for the return sweep as normal, but replace _every+-- instance_ of 'ys' in the generated code with 'ys_copy'. This works because+-- Futhark does not have *semantic* in-place updates - any consumption violation+-- can be replaced with copies (on arrays, anyway). -- -- If we are lucky, the uses of 'ys_copy' will be removed by -- simplification, and there will be no overhead.  But even if not,
src/Futhark/AD/Rev/Scan.hs view
@@ -247,6 +247,10 @@ -- Jacobian of the scan op. Figure out if the Jacobian has some -- special shape, discarding the temporary lambda. identifyCase :: VjpOps -> Lambda SOACS -> ADM ScanAlgo+identifyCase _ lam+  -- The IFL23 specialisation represents Jacobian entries as scalars.+  -- Use PPAD for array results, before constructing the Jacobian.+  | any ((> 0) . arrayRank) (lambdaReturnType lam) = pure GenericPPAD identifyCase ops lam = do   let t = lambdaReturnType lam   let d = length t
src/Futhark/AD/Shared.hs view
@@ -18,7 +18,7 @@ -- | A permutation for transposing the vector shape past the next dimension. -- -- That is, converts @[vec...][d][elem...]@ to @[d][vec...][elem...]@.-vecPerm :: (ArrayShape s) => Shape -> TypeBase s u -> [Int]+vecPerm :: (ArrayShape s) => Shape -> TypeBase s o -> [Int] vecPerm vec_shape t =   [shapeRank vec_shape]     ++ [0 .. shapeRank vec_shape - 1]
src/Futhark/Actions.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fomit-interface-pragmas #-}+ -- | All (almost) compiler pipelines end with an 'Action', which does -- something with the result of the pipeline. module Futhark.Actions@@ -582,7 +584,7 @@         _ -> do           -- Non-server executables are not supported.           writeLibs cprog jsprog-          liftIO $ T.appendFile classpath SequentialWASM.runServer+          liftIO $ T.appendFile classpath $ SequentialWASM.runServer $ SequentialWASM.cManifest cprog           runEMCC cpath outpath classpath ["-O3", "-msimd128"] ["-lm"] exps False     writeLibs cprog jsprog = do       let (h, imp, _) = SequentialC.asLibrary cprog@@ -616,7 +618,7 @@         _ -> do           -- Non-server executables are not supported.           writeLibs cprog jsprog-          liftIO $ T.appendFile classpath MulticoreWASM.runServer+          liftIO $ T.appendFile classpath $ MulticoreWASM.runServer $ MulticoreWASM.cManifest cprog           runEMCC cpath outpath classpath ["-O3", "-msimd128"] ["-lm", "-pthread"] exps False      writeLibs cprog jsprog = do
src/Futhark/Analysis/AccessPattern.hs view
@@ -298,29 +298,35 @@         }      -- Recursively looks up dependencies, until they're in scope or empty set.+    -- The set of already-expanded names is threaded through; see Note+    -- [Expanding dependencies only once].     rmOutOfScopeDeps :: Context rep -> M.Map VName (VariableInfo rep) -> Names-    rmOutOfScopeDeps ctx' new_assignments =-      let throwaway_assignments = assignments ctx'-          local_assignments = assignments ctx-          f result a var_info =-            -- if the VName of the assignment exists in the context, we are good-            if a `M.member` local_assignments-              then result <> oneName a-              else -- Otherwise, recurse on its dependencies;-              -- 0. Add dependencies in ctx to result-                let (deps_in_ctx, deps_not_in_ctx) =-                      L.partition (`M.member` local_assignments) $-                        namesToList (deps var_info)-                    deps_not_in_ctx' =-                      M.fromList $-                        mapMaybe-                          (\d -> (d,) <$> M.lookup d throwaway_assignments)-                          deps_not_in_ctx-                 in result-                      <> namesFromList deps_in_ctx-                      <> rmOutOfScopeDeps ctx' deps_not_in_ctx'-       in M.foldlWithKey f mempty new_assignments+    rmOutOfScopeDeps ctx' = snd . expand mempty+      where+        throwaway_assignments = assignments ctx'+        local_assignments = assignments ctx +        expand seen = M.foldlWithKey f (seen, mempty)++        f (seen, result) a var_info+          | a `nameIn` seen = (seen, result)+          -- if the VName of the assignment exists in the context, we are good+          | a `M.member` local_assignments =+              (seen <> oneName a, result <> oneName a)+          -- Otherwise, recurse on its dependencies, adding the ones already in+          -- ctx to the result.+          | otherwise =+              let (deps_in_ctx, deps_not_in_ctx) =+                    L.partition (`M.member` local_assignments) $+                      namesToList (deps var_info)+                  deps_not_in_ctx' =+                    M.fromList $+                      mapMaybe+                        (\d -> (d,) <$> M.lookup d throwaway_assignments)+                        deps_not_in_ctx+                  (seen', sub) = expand (seen <> oneName a) deps_not_in_ctx'+               in (seen', result <> namesFromList deps_in_ctx <> sub)+ -- | Analyse a rep statement and return the updated context and array index -- descriptors. analyseStm :: (Analyse rep) => Context rep -> Stm rep -> (Context rep, IndexTable rep)@@ -723,3 +729,17 @@   pretty Variable = "var"   pretty ThreadID = "tid"   pretty LoopVar = "iter"++-- Note [Expanding dependencies only once]+--+-- 'rmOutOfScopeDeps' replaces each out-of-scope name by the in-scope names it+-- transitively depends on. The dependency graph is shared, so a name reachable+-- along several paths would, without memoisation, be expanded once per path, so+-- the work is exponential in the depth of the graph rather than linear in its+-- size.+--+-- Threading a set of already-expanded names through the traversal fixes that.+-- It cannot change the answer, because the result is a union of name sets and+-- re-expanding a name contributes exactly what its first expansion did.+--+-- This matters for programs with long chains of scalar definitions.
src/Futhark/Analysis/HORep/MapNest.hs view
@@ -224,17 +224,21 @@       pure (param', SOAC.Input (ts SOAC.|> SOAC.Replicate mempty (Shape [w])) a t)  -- | Reshape a map nest. It is assumed that any validity tests have--- already been done. Will automatically reshape the inputs+-- already been done, and in particular that the result of the map nest+-- has the same rank as its depth. Will automatically reshape the inputs -- appropriately.-reshape :: (MonadFreshNames m) => StmAux () -> Shape -> MapNest -> m MapNest-reshape aux shape (MapNest _ map_lam _ inps) =+reshape :: (MonadFreshNames m) => StmAux () -> NewShape SubExp -> MapNest -> m MapNest+reshape aux (NewShape splices shape) (MapNest _ map_lam _ inps) =   descend [] $ stripDims 1 shape   where     w = shapeSize 0 shape+    -- The splices only affect the dimensions of the nest, which are the+    -- outer dimensions of every input, so we can apply them to the inputs+    -- unchanged. This preserves the structure of the reshape (e.g. that it+    -- merely unflattens a dimension), rather than turning it into a+    -- reshape of the entire input.     transform p inp =-      let shape' = shape <> arrayShape p-          inp_shape = arrayShape (SOAC.inputType inp)-          tr = SOAC.Reshape aux $ reshapeAll inp_shape shape'+      let tr = SOAC.Reshape aux $ NewShape splices $ shape <> arrayShape p        in SOAC.addTransform tr inp     inps' = zipWith transform (map paramType $ lambdaParams map_lam) inps
src/Futhark/Analysis/HORep/SOAC.hs view
@@ -441,7 +441,7 @@ typeOf (Stream w _ nes lam) =   let accrtps = take (length nes) $ lambdaReturnType lam       arrtps =-        [ arrayOf (stripArray 1 t) (Shape [w]) NoUniqueness+        [ arrayOf (stripArray 1 t) (Shape [w]) NoMode         | t <- drop (length nes) (lambdaReturnType lam)         ]    in accrtps ++ arrtps
src/Futhark/Analysis/PrimExp.hs view
@@ -460,8 +460,8 @@         TPrimExp $ constFoldPrimExp z     | otherwise = numBad "rem" (x, y) -  TPrimExp x `divUp` TPrimExp y-    | Just z <- msum [asIntOp (`SDivUp` Unsafe) x y] =+  TPrimExp x `ceilDiv` TPrimExp y+    | Just z <- msum [asIntOp (`SCeilDiv` Unsafe) x y] =         TPrimExp $ constFoldPrimExp z     | otherwise = numBad "divRoundingUp" (x, y)
src/Futhark/Analysis/PrimExp/Convert.hs view
@@ -78,7 +78,7 @@   primExpFromSubExpM f se primExpFromExp f (Apply fname args ts _)   | isBuiltInFunction fname,-    [Prim t] <- map (declExtTypeOf . fst) ts =+    [Prim t] <- map (extTypeOf . fst) ts =       FunExp (nameToText fname) <$> mapM (primExpFromSubExpM f . fst) args <*> pure t primExpFromExp _ _ = fail "Not a PrimExp"
src/Futhark/Analysis/SymbolTable.hs view
@@ -57,10 +57,10 @@  import Control.Arrow ((&&&)) import Control.Monad+import Data.IntMap.Strict qualified as IM import Data.List (elemIndex) import Data.Map.Strict qualified as M import Data.Maybe-import Data.Ord import Futhark.Analysis.PrimExp.Convert import Futhark.IR hiding (FParam, lookupType) import Futhark.IR qualified as AST@@ -69,7 +69,8 @@  data SymbolTable rep = SymbolTable   { loopDepth :: Int,-    bindings :: M.Map VName (Entry rep),+    -- | Keyed by 'baseTag'; see Note [Symbol table indexing].+    bindings :: IM.IntMap (Entry rep),     -- | Which names are available just before the most enclosing     -- loop?     availableAtClosestLoop :: Names,@@ -80,7 +81,7 @@   }  empty :: SymbolTable rep-empty = SymbolTable 0 M.empty mempty False+empty = SymbolTable 0 IM.empty mempty False  -- | Construct a symbol table from a scope. All names in the scope are -- considered as free variables. Equivalent to 'insertScope' on 'empty'.@@ -89,13 +90,14 @@  -- | Construct a Scope from a symbol table. toScope :: SymbolTable rep -> Scope rep-toScope = M.map entryInfo . bindings+toScope =+  M.fromDistinctAscList . map (entryName &&& entryInfo) . IM.elems . bindings  deepen :: SymbolTable rep -> SymbolTable rep deepen vtable =   vtable     { loopDepth = loopDepth vtable + 1,-      availableAtClosestLoop = namesFromList $ M.keys $ bindings vtable+      availableAtClosestLoop = namesFromList $ map entryName $ IM.elems $ bindings vtable     }  -- | The result of indexing a delayed array.@@ -119,7 +121,10 @@ type IndexArray = [TPrimExp Int64 VName] -> Maybe Indexed  data Entry rep = Entry-  { -- | True if consumed.+  { -- | The name this entry is for.  Also the key (via 'baseTag') under+    -- which it is stored.+    entryName :: VName,+    -- | True if consumed.     entryConsumed :: Bool,     entryDepth :: Int,     -- | True if this name has been used as an array size,@@ -216,7 +221,7 @@ elem name = isJust . lookup name  lookup :: VName -> SymbolTable rep -> Maybe (Entry rep)-lookup name = M.lookup name . bindings+lookup name = IM.lookup (baseTag name) . bindings  lookupStm :: VName -> SymbolTable rep -> Maybe (Stm rep) lookupStm name vtable = entryStm =<< lookup name vtable@@ -240,20 +245,20 @@  lookupSubExp :: VName -> SymbolTable rep -> Maybe (SubExp, Certs) lookupSubExp name vtable = do-  (e, cs) <- lookupExp name vtable-  case e of-    BasicOp (SubExp se) -> Just (se, cs)+  stm <- lookupStm name vtable+  case stmExp stm of+    BasicOp (SubExp se) -> Just (se, stmCerts stm)     _ -> Nothing  lookupAliases :: VName -> SymbolTable rep -> Names lookupAliases name vtable =-  maybe mempty (entryAliases . entryType) $ M.lookup name (bindings vtable)+  maybe mempty (entryAliases . entryType) $ IM.lookup (baseTag name) (bindings vtable)  -- | If the given variable name is the name of a 'ForLoop' parameter, -- then return the bound of that loop. lookupLoopVar :: VName -> SymbolTable rep -> Maybe SubExp lookupLoopVar name vtable = do-  LoopVar e <- entryType <$> M.lookup name (bindings vtable)+  LoopVar e <- entryType <$> IM.lookup (baseTag name) (bindings vtable)   pure $ loopVarBound e  -- | Look up the initial value and eventual result of a loop@@ -261,7 +266,7 @@ -- something that is not part of the symbol table. lookupLoopParam :: VName -> SymbolTable rep -> Maybe (SubExp, SubExp) lookupLoopParam name vtable = do-  FParam e <- entryType <$> M.lookup name (bindings vtable)+  FParam e <- entryType <$> IM.lookup (baseTag name) (bindings vtable)   fparamMerge e  -- | Do these two names alias each other?  This is expected to be a@@ -272,7 +277,7 @@  -- | In symbol table and not consumed. available :: VName -> SymbolTable rep -> Bool-available name = maybe False (not . entryConsumed) . M.lookup name . bindings+available name = maybe False (not . entryConsumed) . IM.lookup (baseTag name) . bindings  -- | Constant or 'available' subExpAvailable :: SubExp -> SymbolTable rep -> Bool@@ -353,14 +358,12 @@   guard $ v `available` table   Just $ indexNext v (drop (shapeRank s) is) table indexExp table (BasicOp (Reshape v newshape)) _ is-  | Just oldshape <- arrayDims <$> lookupType v table =-      -- TODO: handle coercions more efficiently.-      let is' =-            reshapeIndex-              (map pe64 oldshape)-              (map pe64 $ shapeDims $ newShape newshape)-              is-       in Just $ indexNext v is' table+  | Just oldshape <- arrayShape <$> lookupType v table,+    -- Map the indices to the old index space, one splice at a time.+    Just is' <-+      mapM dimFix+        =<< unreshapeSlice (pe64 <$> oldshape) (pe64 <$> newshape) (map DimFix is) =+      Just $ indexNext v is' table indexExp table (BasicOp (Rearrange v perm)) _ is =   Just $ indexNext v (rearrangeShape (rearrangeInverse perm) is) table indexExp table (BasicOp (Index v slice)) _ is = do@@ -402,8 +405,8 @@   pat_elem <- patElems pat   pure $ defBndEntry vtable pat_elem (expandAliases (Aliases.aliasesOf pat_elem) vtable) stm -adjustSeveral :: (Ord k) => (v -> v) -> [k] -> M.Map k v -> M.Map k v-adjustSeveral f = flip $ foldl' $ flip $ M.adjust f+adjustSeveral :: (v -> v) -> [VName] -> IM.IntMap v -> IM.IntMap v+adjustSeveral f = flip $ foldl' $ \m -> flip (IM.adjust f) m . baseTag  insertEntry ::   (ASTRep rep) =>@@ -414,7 +417,8 @@ insertEntry name entry vtable =   let entry' =         Entry-          { entryConsumed = False,+          { entryName = name,+            entryConsumed = False,             entryDepth = loopDepth vtable,             entryIsSize = False,             entryAccInput = Nothing,@@ -425,7 +429,7 @@    in vtable         { bindings =             adjustSeveral isSize dims $-              M.insert name entry' $+              IM.insert (baseTag name) entry' $                 bindings vtable         } @@ -584,12 +588,12 @@       expandAliases (oneName consumee) vtable   where     consume' vtable' v =-      vtable' {bindings = M.adjust consume'' v $ bindings vtable'}+      vtable' {bindings = IM.adjust consume'' (baseTag v) $ bindings vtable'}     consume'' e = e {entryConsumed = True}  -- | Hide definitions of those entries that satisfy some predicate. hideIf :: (Entry rep -> Bool) -> SymbolTable rep -> SymbolTable rep-hideIf hide vtable = vtable {bindings = M.map maybeHide $ bindings vtable}+hideIf hide vtable = vtable {bindings = IM.map maybeHide $ bindings vtable}   where     maybeHide entry       | hide entry =@@ -621,10 +625,24 @@ noteAccTokens = flip (foldl' f)   where     f vtable (v, accum) =-      case M.lookup v $ bindings vtable of+      case IM.lookup (baseTag v) $ bindings vtable of         Nothing -> vtable         Just e ->           vtable             { bindings =-                M.insert v (e {entryAccInput = Just accum}) $ bindings vtable+                IM.insert (baseTag v) (e {entryAccInput = Just accum}) $ bindings vtable             }++-- Note [Symbol table indexing]+--+-- The bindings are indexed by 'baseTag' in an 'IM.IntMap' rather than by+-- 'VName' in an 'M.Map', because looking up entries here is extremely frequent+-- in the simplifier, and this saves a pointer lookup.+--+-- The price is that the keys no longer carry the names, so 'Entry' records its+-- own 'entryName', and 'toScope' has to rebuild a 'Scope' in linear time rather+-- than mapping lazily over the bindings. That is a good trade only because+-- 'toScope' is essentially never forced: the simplifier's 'HasScope' instance+-- answers 'lookupType' from the symbol table directly, and the 'Scope' handed+-- to a simplification rule is examined only by the rare rule that asks for the+-- whole scope.
src/Futhark/Analysis/UsageTable.hs view
@@ -66,12 +66,14 @@ expand :: (VName -> Names) -> UsageTable -> UsageTable expand look (UsageTable m) = UsageTable $ L.foldl' grow m $ IM.toList m   where+    -- The name is irrelevant; only the tag is used for lookup.+    dummy = nameFromString ""     grow m' (k, v) =-      L.foldl'+      IM.foldlWithKey'         (grow'' $ v `withoutU` presentU)         m'-        (namesIntMap $ look $ VName (nameFromString "") k)-    grow'' v m'' k = IM.insertWith (<>) (baseTag k) v m''+        (namesIntMap $ look $ VName dummy k)+    grow'' v m'' k _ = IM.insertWith (<>) k v m''  is :: Usages -> VName -> UsageTable -> Bool is = lookupPred . matches
src/Futhark/Bench.hs view
@@ -4,8 +4,10 @@   ( RunResult (..),     DataResult (..),     BenchResult (..),+    BenchMetadata (..),     Result (..),     encodeBenchResults,+    encodeBenchResultsWithMetadata,     decodeBenchResults,     binaryName,     benchmarkDataset,@@ -34,7 +36,7 @@ import Futhark.Profile import Futhark.Server import Futhark.Test-import Futhark.Util (showText)+import Futhark.Util (nubOrd, showText) import Statistics.Autocorrelation (autocorrelation) import Statistics.Sample (fastStdDev, mean) import System.Exit@@ -75,9 +77,22 @@   }   deriving (Eq, Show) +-- | Information about the environment and invocation that produced a+-- benchmark result file.+data BenchMetadata = BenchMetadata+  { benchStartTime :: UTCTime,+    benchEndTime :: UTCTime,+    benchHostname :: Maybe T.Text,+    benchCompilerVersion :: Maybe T.Text,+    benchBackend :: T.Text,+    benchCompilerOptions :: [T.Text],+    benchRuntimeOptions :: [T.Text]+  }+  deriving (Eq, Show)+ newtype DataResults = DataResults {unDataResults :: [DataResult]} -newtype BenchResults = BenchResults {unBenchResults :: [BenchResult]}+data BenchResults = BenchResults (Maybe BenchMetadata) [BenchResult]  instance JSON.ToJSON Result where   toJSON (Result runres memmap err profiling) =@@ -131,19 +146,33 @@           Just profiling -> [("profiling", JSON.toJSON profiling)]   ) -benchResultJSON :: BenchResult -> (JSON.Key, JSON.Value)-benchResultJSON (BenchResult prog r) =+benchMetadataJSON :: BenchMetadata -> JSON.Value+benchMetadataJSON metadata =+  JSON.object+    [ ("start_time", JSON.toJSON $ benchStartTime metadata),+      ("end_time", JSON.toJSON $ benchEndTime metadata),+      ("hostname", JSON.toJSON $ benchHostname metadata),+      ("compiler_version", JSON.toJSON $ benchCompilerVersion metadata),+      ("backend", JSON.toJSON $ benchBackend metadata),+      ("compiler_options", JSON.toJSON $ benchCompilerOptions metadata),+      ("runtime_options", JSON.toJSON $ benchRuntimeOptions metadata)+    ]++benchResultJSON :: Maybe BenchMetadata -> BenchResult -> (JSON.Key, JSON.Value)+benchResultJSON metadata (BenchResult prog r) =   ( JSON.fromString prog,-    JSON.object [("datasets", JSON.toJSON $ DataResults r)]+    JSON.object $+      [("datasets", JSON.toJSON $ DataResults r)]+        <> maybe [] (pure . ("metadata",) . benchMetadataJSON) metadata   )  instance JSON.ToJSON BenchResults where-  toJSON (BenchResults rs) =-    JSON.object $ map benchResultJSON rs+  toJSON (BenchResults metadata rs) =+    JSON.object $ map (benchResultJSON metadata) rs  instance JSON.FromJSON BenchResults where   parseJSON = JSON.withObject "benchmarks" $ \o ->-    BenchResults <$> mapM onBenchmark (JSON.toList o)+    BenchResults Nothing <$> mapM onBenchmark (JSON.toList o)     where       onBenchmark (k, v) =         BenchResult (JSON.toString k)@@ -153,11 +182,22 @@  -- | Transform benchmark results to a JSON bytestring. encodeBenchResults :: [BenchResult] -> LBS.ByteString-encodeBenchResults = JSON.encode . BenchResults+encodeBenchResults = JSON.encode . BenchResults Nothing +-- | Transform benchmark results and their provenance metadata to a JSON+-- bytestring.  Metadata is stored inside each benchmark object so existing+-- consumers that iterate the top-level program keys remain compatible.+encodeBenchResultsWithMetadata ::+  BenchMetadata ->+  [BenchResult] ->+  LBS.ByteString+encodeBenchResultsWithMetadata = (JSON.encode .) . BenchResults . Just+ -- | Decode benchmark results from a JSON bytestring. decodeBenchResults :: LBS.ByteString -> Either String [BenchResult] decodeBenchResults = fmap unBenchResults . JSON.eitherDecode'+  where+    unBenchResults (BenchResults _ results) = results  --- Running benchmarks @@ -312,12 +352,13 @@   cmdMaybe . liftIO $ cmdPauseProfiling server    let freeOut = cmdMaybe (cmdFree server [out])-      freeIns = cmdMaybe (cmdFree server ins)-      loadInput = valuesAsVars server (zip ins $ map inputType input_types) futhark dir input_spec-      reloadInput = freeIns >> loadInput+      loadInput = valuesAsVars server entry (zip ins $ map inputType input_types) futhark program input_spec -  loadInput+  ins' <- loadInput +  let freeIns = cmdMaybe (cmdFree server (nubOrd ins'))+      reloadInput = freeIns >> void loadInput+   let runtime l         | Just l' <- T.stripPrefix "runtime: " l,           [(x, "")] <- reads $ T.unpack l' =@@ -329,7 +370,7 @@         when (any inputConsumed input_types) reloadInput        doRun = do-        call_lines <- cmdEither (cmdCall server entry out ins)+        call_lines <- cmdEither (cmdCall server entry out ins')         case mapMaybe runtime call_lines of           [call_runtime] -> pure (RunResult call_runtime, call_lines)           [] -> throwError "Could not find runtime in output."@@ -337,7 +378,7 @@    maybe_call_logs <- liftIO . timeout (runTimeout opts * 1000000) . runExceptT $ do     -- First one uncounted warmup run.-    void $ cmdEither $ cmdCall server entry out ins+    void $ cmdEither $ cmdCall server entry out ins'      ys <- runMinimum (freeOut *> doRun <* maybeReload) opts 0 0 mempty
src/Futhark/Builder/Class.hs view
@@ -36,7 +36,7 @@   ( ASTRep rep,     FParamInfo rep ~ DeclType,     LParamInfo rep ~ Type,-    RetType rep ~ DeclExtType,+    RetType rep ~ ExtType,     BranchType rep ~ ExtType   ) =>   Buildable rep
src/Futhark/CLI/Bench.hs view
@@ -34,6 +34,7 @@ import System.Exit import System.FilePath import System.IO+import System.Process.ByteString (readProcessWithExitCode) import System.Random.MWC (create) import Text.Printf import Text.Regex.TDFA@@ -115,6 +116,7 @@   -- Otherwise, CI tools and the like may believe we are hung and kill   -- us.   hSetBuffering stdout LineBuffering+  start_time <- getCurrentTime    benchmarks <- filter (not . ignored . fst) <$> testSpecsFromPathsOrDie paths   -- Try to avoid concurrency at both program and data set level.@@ -147,13 +149,37 @@   let results = concat $ catMaybes maybe_results   case optJSON opts of     Nothing -> pure ()-    Just file ->+    Just file -> do+      end_time <- getCurrentTime+      hostname <- commandOutput "hostname" []+      compile_opts <- compileOptions opts+      compiler_version <- commandOutput (compFuthark compile_opts) ["--version"]+      let metadata =+            BenchMetadata+              { benchStartTime = start_time,+                benchEndTime = end_time,+                benchHostname = hostname,+                benchCompilerVersion = compiler_version,+                benchBackend = T.pack $ optBackend opts,+                benchCompilerOptions = map T.pack $ optCompilerOptions opts,+                benchRuntimeOptions = map T.pack $ optExtraOptions opts+              }       LBS.writeFile file $-        encodeBenchResults $+        encodeBenchResultsWithMetadata metadata $           combineDuplicates results   when (any isNothing maybe_results || anyFailed results) exitFailure   where     ignored f = any (`match` f) $ optIgnoreFiles opts++commandOutput :: FilePath -> [String] -> IO (Maybe T.Text)+commandOutput command args = do+  result <-+    try (readProcessWithExitCode command args SBS.empty) ::+      IO (Either SomeException (ExitCode, SBS.ByteString, SBS.ByteString))+  pure $ case result of+    Right (ExitSuccess, output, _) ->+      Just $ T.strip $ T.pack $ SBS.unpack output+    _ -> Nothing  anyFailed :: [BenchResult] -> Bool anyFailed = any failedBenchResult
src/Futhark/CLI/Dataset.hs view
@@ -192,7 +192,7 @@ toValueType TESum {} = Left "Cannot handle sumtypes yet." toValueType TEDim {} = Left "Cannot handle existential sizes." toValueType (TEParens t _) = toValueType t-toValueType (TEUnique t _) = toValueType t+toValueType (TEStar t _) = toValueType t toValueType (TEArray d t _) = do   d' <- constantDim d   V.ValueType ds t' <- toValueType t
src/Futhark/CLI/Dev.hs view
@@ -6,6 +6,7 @@ import Control.Monad.State import Data.Kind qualified import Data.List (intersperse)+import Data.List.Split (splitOn) import Data.Maybe import Data.Text qualified as T import Data.Text.IO qualified as T@@ -14,7 +15,7 @@ import Futhark.Analysis.Alias qualified as Alias import Futhark.Analysis.Metrics (OpMetrics) import Futhark.Compiler.CLI hiding (compilerMain)-import Futhark.IR (Op, Prog, prettyString)+import Futhark.IR (Name, Op, Prog, prettyString) import Futhark.IR.Aliases (AliasableRep) import Futhark.IR.GPU qualified as GPU import Futhark.IR.GPUMem qualified as GPUMem@@ -496,6 +497,11 @@   [(n, "")] -> Right (Just n)   _any -> Left $ "Invalid gas value: " <> s +parseAttrs :: Maybe String -> Either String [Name]+parseAttrs Nothing = Right []+parseAttrs (Just s) =+  Right $ map nameFromString $ filter (not . null) $ splitOn "," s+ commandLineOptions :: [FutharkOption] commandLineOptions =   [ Option@@ -729,7 +735,14 @@     unstreamOption [],     sinkOption [],     kernelsPassOption reduceDeviceSyncs [],-    typedPassOption soacsProg GPU flattenSOACs [],+    typedPassOptionWithArg+      soacsProg+      GPU+      (fmap flattenSOACs . parseAttrs)+      []+      ["flatten"]+      "ATTRS"+      "comma-separated flattening attributes",     typedPassOption soacsProg MC extractMulticore [],     allocateOption "a",     kernelsMemPassOption doubleBufferGPU [],
src/Futhark/CLI/Eval.hs view
@@ -7,9 +7,10 @@ import Data.Map qualified as M import Data.Text qualified as T import Futhark.Eval-  ( InterpreterConfig (..),-    interpreterConfig,-    newFutharkiState,+  ( EvalConfig (..),+    evalConfig,+    evalServerOptions,+    newInterpreterState,     runExpr,   ) import Futhark.Util.Options@@ -27,15 +28,14 @@  -- | Run @futhark eval@. main :: String -> [String] -> IO ()-main = mainWithOptions interpreterConfig options "options... <exprs...>" run+main = mainWithOptions evalConfig options "options... <exprs...>" run   where     run [] _ = Nothing     run exprs config = Just $ runExprs exprs config -runExprs :: [String] -> InterpreterConfig -> IO ()+runExprs :: [String] -> EvalConfig -> IO () runExprs exprs cfg = do-  let InterpreterConfig _ file = cfg-  maybe_new_state <- newFutharkiState cfg file M.empty+  maybe_new_state <- newInterpreterState cfg M.empty   interpreter_state <- case maybe_new_state of     Left reason -> do       hPutDocLn stderr reason@@ -43,21 +43,20 @@     Right s -> pure s   forM_ exprs $ \expr -> putDocLn =<< runExpr interpreter_state (T.pack expr) -options :: [FunOptDescr InterpreterConfig]+options :: [FunOptDescr EvalConfig] options =   [ Option       "f"       ["file"]       ( ReqArg-          ( \entry -> Right $ \config ->-              config {interpreterFile = Just entry}-          )+          (\entry -> Right $ \config -> config {evalFile = Just entry})           "NAME"       )       "The file to load before evaluating expressions.",     Option       "w"       ["no-warnings"]-      (NoArg $ Right $ \config -> config {interpreterPrintWarnings = False})+      (NoArg $ Right $ \config -> config {evalPrintWarnings = False})       "Do not print warnings."   ]+    ++ evalServerOptions
src/Futhark/CLI/Literate.hs view
@@ -1,26 +1,18 @@ -- | @futhark literate@------ Also contains various utility definitions used by "Futhark.CLI.Script".-module Futhark.CLI.Literate-  ( main,-    Options (..),-    initialOptions,-    scriptCommandLineOptions,-    prepareServer,-  )-where+module Futhark.CLI.Literate (main) where  import Codec.BMP qualified as BMP import Control.Monad import Control.Monad.Except+import Control.Monad.Free.Church (F) import Control.Monad.State hiding (State)+import Control.Monad.Trans.Maybe (MaybeT (..), hoistMaybe)+import Data.Array qualified as A import Data.Bifunctor (first, second) import Data.Bits-import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Char import Data.Functor (($>))-import Data.Int (Int64) import Data.List qualified as L import Data.Map qualified as M import Data.Maybe@@ -28,16 +20,23 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T-import Data.Text.Read qualified as T import Data.Vector.Storable qualified as SVec import Data.Vector.Storable.ByteString qualified as SVec import Data.Void import Data.Word (Word32, Word8)+import Futhark.Compiler (readProgramFilesExceptKnown) import Futhark.Data-import Futhark.Script+import Futhark.Error (prettyCompilerError)+import Futhark.Eval+  ( EvalConfig (..),+    evalConfig,+    forceValue,+    initialiseInterpreter,+    runInterpreterWith,+  )+import Futhark.FreshNames (VNameSource) import Futhark.Server import Futhark.Test-import Futhark.Test.Values import Futhark.Util   ( directoryContents,     ensureCacheDirectory,@@ -51,6 +50,16 @@ import Futhark.Util.Pretty (prettyText, prettyTextOneLine) import Futhark.Util.Pretty qualified as PP import Futhark.Util.ProgressBar+import Language.Futhark.Interpreter qualified as I+import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI+import Language.Futhark.Interpreter.Values qualified as IV+import Language.Futhark.Pretty ()+import Language.Futhark.Primitive qualified as P+import Language.Futhark.Prop (UncheckedExp, typeOf)+import Language.Futhark.Semantic qualified as T+import Language.Futhark.Syntax qualified as F+import Language.Futhark.Tuple (areTupleFields)+import Language.Futhark.TypeChecker qualified as T import System.Directory   ( copyFile,     doesFileExist,@@ -110,26 +119,16 @@     }  data Directive-  = DirectiveRes Exp+  = DirectiveRes UncheckedExp   | DirectiveBrief Directive   | DirectiveCovert Directive-  | DirectiveImg Exp ImgParams-  | DirectivePlot Exp (Maybe (Int, Int))-  | DirectiveGnuplot Exp T.Text-  | DirectiveVideo Exp VideoParams-  | DirectiveAudio Exp AudioParams+  | DirectiveImg UncheckedExp ImgParams+  | DirectivePlot UncheckedExp (Maybe (Int, Int))+  | DirectiveGnuplot UncheckedExp T.Text+  | DirectiveVideo UncheckedExp VideoParams+  | DirectiveAudio UncheckedExp AudioParams   deriving (Show) -varsInDirective :: Directive -> S.Set EntryName-varsInDirective (DirectiveRes e) = varsInExp e-varsInDirective (DirectiveBrief d) = varsInDirective d-varsInDirective (DirectiveCovert d) = varsInDirective d-varsInDirective (DirectiveImg e _) = varsInExp e-varsInDirective (DirectivePlot e _) = varsInExp e-varsInDirective (DirectiveGnuplot e _) = varsInExp e-varsInDirective (DirectiveVideo e _) = varsInExp e-varsInDirective (DirectiveAudio e _) = varsInExp e- pprDirective :: Bool -> Directive -> PP.Doc a pprDirective _ (DirectiveRes e) =   "> " <> PP.align (PP.pretty e)@@ -198,13 +197,6 @@   | BlockDirective Directive T.Text   deriving (Show) -varsInScripts :: [Block] -> S.Set EntryName-varsInScripts = foldMap varsInBlock-  where-    varsInBlock (BlockDirective d _) = varsInDirective d-    varsInBlock BlockCode {} = mempty-    varsInBlock BlockComment {} = mempty- type Parser = Parsec Void T.Text  postlexeme :: Parser ()@@ -225,7 +217,7 @@ parseBlockComment :: Parser T.Text parseBlockComment = T.unlines <$> some line   where-    line = "--" *> optional " " *> restOfLine+    line = try $ hspace *> "--" *> optional " " *> restOfLine  parseTestBlock :: Parser T.Text parseTestBlock =@@ -238,7 +230,7 @@ parseBlockCode = T.unlines . noblanks <$> some line   where     noblanks = reverse . dropWhile T.null . reverse . dropWhile T.null-    line = try (notFollowedBy "--") *> notFollowedBy eof *> restOfLine+    line = try (notFollowedBy (hspace *> "--")) *> notFollowedBy eof *> restOfLine  parsePlotParams :: Parser (Maybe (Int, Int)) parsePlotParams =@@ -334,14 +326,6 @@       s <- lexeme $ takeWhileP Nothing (not . isSpace)       pure params {audioCodec = Just s} -atStartOfLine :: Parser ()-atStartOfLine = do-  col <- sourceColumn <$> getSourcePos-  when (col /= pos1) empty--afterExp :: Parser ()-afterExp = choice [atStartOfLine, choice [void eol, eof]]- withParsedSource :: Parser a -> (a -> T.Text -> b) -> Parser b withParsedSource p f = do   s <- getInput@@ -357,6 +341,37 @@       | "-- " `T.isPrefixOf` s = T.drop 3 s       | otherwise = T.drop 2 s +-- | A directive expression extends to the end of the enclosing comment block,+-- or to the ';' that introduces directive parameters.+parseDirectiveExp :: Parser UncheckedExp+parseDirectiveExp = parseEmbeddedExp expText+  where+    expText = do+      more <- expLine+      -- A line that starts a new directive does not continue this one. The line+      -- break is consumed only if the expression does continue, as the+      -- directive parsers expect to find it.+      cont <- optional $ try $ eol *> notFollowedBy "-- >" *> lookAhead "--"+      when (more && isJust cont) expText++    -- Consume the expression text on this line (but not the line+    -- break), returning whether it may continue on the next one.+    expLine = do+      l <- lookAhead $ takeWhileP Nothing (/= '\n')+      case paramsIn l of+        Just n -> False <$ takeP Nothing n+        Nothing -> True <$ takeP Nothing (T.length l)++    -- Parameters are introduced by a ';' at the end of a line.  If+    -- this line has one, how much of it belongs to the expression?+    paramsIn l =+      case T.breakOnEnd ";" l of+        (before, after)+          | not $ T.null before,+            T.all isSpace after ->+              Just $ T.length before - 1+        _ -> Nothing+ parseBlock :: Parser Block parseBlock =   choice@@ -369,8 +384,7 @@   where     parseDirective =       choice-        [ DirectiveRes <$> parseExp postlexeme <* afterExp,-          directiveName "covert"+        [ directiveName "covert"             $> DirectiveCovert             <*> parseDirective,           directiveName "brief"@@ -378,28 +392,29 @@             <*> parseDirective,           directiveName "img"             $> DirectiveImg-            <*> parseExp postlexeme+            <*> parseDirectiveExp             <*> parseImgParams             <* choice [void eol, eof],           directiveName "plot2d"             $> DirectivePlot-            <*> parseExp postlexeme+            <*> parseDirectiveExp             <*> parsePlotParams             <* choice [void eol, eof],           directiveName "gnuplot"             $> DirectiveGnuplot-            <*> parseExp postlexeme+            <*> parseDirectiveExp             <*> (";" *> hspace *> eol *> parseBlockComment),           (directiveName "video" <|> directiveName "video")             $> DirectiveVideo-            <*> parseExp postlexeme+            <*> parseDirectiveExp             <*> parseVideoParams             <* eol,           directiveName "audio"             $> DirectiveAudio-            <*> parseExp postlexeme+            <*> parseDirectiveExp             <*> parseAudioParams-            <* choice [void eol, eof]+            <* choice [void eol, eof],+          DirectiveRes <$> parseDirectiveExp <* choice [void eol, eof]         ]     directiveName s = try $ token (":" <> s) @@ -424,7 +439,9 @@  newtype State = State {stateFiles :: Files} -newtype ScriptM a = ScriptM (ExceptT T.Text (StateT State IO) a)+-- | The monad in which 'futhark literate' runs. Just does error propagation and+-- state management on top of IO.+newtype LiterateM a = LiterateM (ExceptT T.Text (StateT State IO) a)   deriving     ( Functor,       Applicative,@@ -435,24 +452,24 @@       MonadState State     ) -runScriptM :: ScriptM a -> IO (Either T.Text a, Files)-runScriptM (ScriptM m) = second stateFiles <$> runStateT (runExceptT m) s+runLiterateM :: LiterateM a -> IO (Either T.Text a, Files)+runLiterateM (LiterateM m) = second stateFiles <$> runStateT (runExceptT m) s   where     s = State mempty -withTempFile :: (FilePath -> ScriptM a) -> ScriptM a+withTempFile :: (FilePath -> LiterateM a) -> LiterateM a withTempFile f =   join . liftIO . withSystemTempFile "futhark-literate" $ \tmpf tmpf_h -> do     hClose tmpf_h-    (res, files) <- runScriptM (f tmpf)+    (res, files) <- runLiterateM (f tmpf)     pure $ do       modify $ \s -> s {stateFiles = files <> stateFiles s}       either throwError pure res -withTempDir :: (FilePath -> ScriptM a) -> ScriptM a+withTempDir :: (FilePath -> LiterateM a) -> LiterateM a withTempDir f =   join . liftIO . withSystemTempDirectory "futhark-literate" $ \dir -> do-    (res, files) <- runScriptM (f dir)+    (res, files) <- runLiterateM (f dir)     pure $ do       modify $ \s -> s {stateFiles = files <> stateFiles s}       either throwError pure res@@ -560,116 +577,54 @@     loop = boolOpt "loop" videoLoop     autoplay = boolOpt "autoplay" videoAutoplay -plottable :: CompoundValue -> Maybe [Value]-plottable (ValueTuple vs) = do+-- | A tuple of one-dimensional arrays of the same length, which is what the+-- plotting directives expect.+plottable :: Env -> I.Value -> LiterateM (Maybe [Value])+plottable env (IV.ValueRecord fs) = runMaybeT $ do+  vs <- hoistMaybe $ areTupleFields fs   (vs', ns') <- mapAndUnzipM inspect vs   guard $ length (nubOrd ns') == 1-  Just vs'+  pure vs'   where-    inspect (ValueAtom v)-      | [n] <- valueShape v = Just (v, n)-    inspect _ = Nothing-plottable _ = Nothing+    inspect v = do+      v' <- MaybeT $ dataValue env v+      case valueShape v' of+        [n] -> pure (v', n)+        _ -> hoistMaybe Nothing+plottable _ _ = pure Nothing +-- | As 'plottable', but for exactly two arrays, interpreted as x and y values.+plottable2d :: Env -> I.Value -> LiterateM (Maybe [Value])+plottable2d env v = do+  vs <- plottable env v+  pure $ case vs of+    Just [x, y] -> Just [x, y]+    _ -> Nothing++-- | The fields of a record, as expected by the plotting directives. Note that a+-- tuple is also a record, so this must be tried only after 'plottable'.+plottableFields ::+  (I.Value -> LiterateM (Maybe [Value])) ->+  I.Value ->+  LiterateM (Maybe [(T.Text, [Value])])+plottableFields f (IV.ValueRecord fs)+  | Nothing <- areTupleFields fs =+      runMaybeT $ mapM onField $ M.toList fs+  where+    onField (k, v) = (F.nameToText k,) <$> MaybeT (f v)+plottableFields _ _ = pure Nothing+ withGnuplotData ::   [(T.Text, T.Text)] ->   [(T.Text, [Value])] ->-  ([T.Text] -> [T.Text] -> ScriptM a) ->-  ScriptM a+  ([T.Text] -> [T.Text] -> LiterateM a) ->+  LiterateM a withGnuplotData sets [] cont = uncurry cont $ unzip $ reverse sets withGnuplotData sets ((f, vs) : xys) cont =   withTempFile $ \fname -> do     liftIO $ T.writeFile fname $ formatDataForGnuplot vs     withGnuplotData ((f, f <> "='" <> T.pack fname <> "'") : sets) xys cont -loadBMP :: FilePath -> ScriptM (Compound Value)-loadBMP bmpfile = do-  res <- liftIO $ BMP.readBMP bmpfile-  case res of-    Left err ->-      throwError $ "Failed to read BMP:\n" <> showText err-    Right bmp -> do-      let bmp_bs = BMP.unpackBMPToRGBA32 bmp-          (w, h) = BMP.bmpDimensions bmp-          shape = SVec.fromList [fromIntegral h, fromIntegral w]-          pix l =-            let (i, j) = l `divMod` w-                l' = (h - 1 - i) * w + j-                r = fromIntegral $ bmp_bs `BS.index` (l' * 4)-                g = fromIntegral $ bmp_bs `BS.index` (l' * 4 + 1)-                b = fromIntegral $ bmp_bs `BS.index` (l' * 4 + 2)-                a = fromIntegral $ bmp_bs `BS.index` (l' * 4 + 3)-             in (a `shiftL` 24) .|. (r `shiftL` 16) .|. (g `shiftL` 8) .|. b-      pure $ ValueAtom $ U32Value shape $ SVec.generate (w * h) pix--loadImage :: FilePath -> ScriptM (Compound Value)-loadImage imgfile =-  withTempDir $ \dir -> do-    let bmpfile = dir </> takeBaseName imgfile `replaceExtension` "bmp"-    void $ system "convert" [imgfile, "-type", "TrueColorAlpha", bmpfile] mempty-    loadBMP bmpfile--loadPCM :: Int -> FilePath -> ScriptM (Compound Value)-loadPCM num_channels pcmfile = do-  contents <- liftIO $ LBS.readFile pcmfile-  let v = SVec.byteStringToVector $ LBS.toStrict contents-      channel_length = SVec.length v `div` num_channels-      shape =-        SVec.fromList-          [ fromIntegral num_channels,-            fromIntegral channel_length-          ]-      -- ffmpeg outputs audio data in column-major format. `backPermuter` computes the-      -- tranposed indexes for a backpermutation.-      backPermuter i = (i `mod` channel_length) * num_channels + i `div` channel_length-      perm = SVec.generate (SVec.length v) backPermuter-  pure $ ValueAtom $ F64Value shape $ SVec.backpermute v perm--loadAudio :: FilePath -> ScriptM (Compound Value)-loadAudio audiofile = do-  s <- system "ffprobe" [audiofile, "-show_entries", "stream=channels", "-select_streams", "a", "-of", "compact=p=0:nk=1", "-v", "0"] mempty-  case T.decimal s of-    Right (num_channels, _) -> do-      withTempDir $ \dir -> do-        let pcmfile = dir </> takeBaseName audiofile `replaceExtension` "pcm"-        void $ system "ffmpeg" ["-i", audiofile, "-c:a", "pcm_f64le", "-map", "0", "-f", "data", pcmfile] mempty-        loadPCM num_channels pcmfile-    _ -> throwError "$loadImg failed to detect the number of channels in the audio input"--literateBuiltin :: EvalBuiltin ScriptM-literateBuiltin server "loadimg" vs-  | [v] <- vs = do-      v' <- getHaskellValue server v-      case v' of-        Just path -> do-          let path' = map (chr . fromIntegral) (path :: [Word8])-          valToExpValue <$> loadImage path'-        _ -> bad-  | otherwise = bad-  where-    bad =-      throwError $-        "$loadimg does not accept arguments of types: "-          <> T.intercalate ", " (map (prettyText . fmap scriptValueType) vs)-literateBuiltin server "loadaudio" vs-  | [v] <- vs = do-      v' <- getHaskellValue server v-      case v' of-        Just path -> do-          let path' = map (chr . fromIntegral) (path :: [Word8])-          valToExpValue <$> loadAudio path'-        _ -> bad-  | otherwise = bad-  where-    bad =-      throwError $-        "$loadaudio does not accept arguments of types: "-          <> T.intercalate ", " (map (prettyText . fmap scriptValueType) vs)-literateBuiltin server f vs =-  scriptBuiltin "." server f vs---- | Some of these only make sense for @futhark literate@, but enough--- are also sensible for @futhark script@ that we can share them. data Options = Options   { scriptBackend :: String,     scriptFuthark :: Maybe FilePath,@@ -678,12 +633,9 @@     scriptSkipCompilation :: Bool,     scriptOutput :: Maybe FilePath,     scriptVerbose :: Int,-    scriptStopOnError :: Bool,-    scriptBinary :: Bool,-    scriptExps :: [Either FilePath T.Text]+    scriptStopOnError :: Bool   } --- | The configuration before any user-provided options are processed. initialOptions :: Options initialOptions =   Options@@ -694,19 +646,144 @@       scriptSkipCompilation = False,       scriptOutput = Nothing,       scriptVerbose = 0,-      scriptStopOnError = False,-      scriptBinary = False,-      scriptExps = []+      scriptStopOnError = False     }  data Env = Env   { envImgDir :: FilePath,     envOpts :: Options,-    envServer :: ScriptServer,+    -- | Entry points are not interpreted, but run on this server.+    envServer :: FFI.Server,+    envSrc :: VNameSource,+    envTypeEnv :: T.Env,+    envCtx :: I.Ctx,     envHash :: T.Text   } -newFile :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> ScriptM ()) -> ScriptM FilePath+-- | Run an interpreter action. Traces are shown when verbose, external calls+-- are dispatched to the server, and breakpoints are ignored.+runInterpreter :: Env -> F I.ExtOp a -> LiterateM a+runInterpreter env =+  either (throwError . PP.docText . I.prettyInterpreterError) pure+    <=< runInterpreterWith report (Just (envServer env)) Nothing+  where+    report d =+      when (scriptVerbose (envOpts env) > 0) $+        liftIO $+          T.putStrLn $+            PP.docText d++-- | Type check and evaluate an expression, returning its type (which is useful+-- for error messages) and the value in full.+evalExp :: Env -> UncheckedExp -> LiterateM (F.StructType, I.Value)+evalExp env e = do+  fexp <- case T.checkExp [] (envSrc env) (envTypeEnv env) e of+    (_, Left terr) -> throwError $ PP.docText $ T.prettyTypeError terr+    (_, Right ([], fexp)) -> pure fexp+    (_, Right (_, fexp)) ->+      throwError $ "Ambiguous type of expression: " <> prettyText (typeOf fexp)+  (typeOf fexp,) <$> runInterpreter env (I.interpretExp (envCtx env) fexp)++-- | As 'evalExp', but also fetch any parts of the value that reside on+-- the server.+evalExpForced :: Env -> UncheckedExp -> LiterateM (F.StructType, I.Value)+evalExpForced env e = do+  (t, v) <- evalExp env e+  (t,) <$> force env v++-- | Fetch a value that resides on the server. Anything we do with a+-- value, except passing it back to the server, needs it in full.+force :: Env -> I.Value -> LiterateM I.Value+force env v = do+  v' <- liftIO $ forceValue (Just (envServer env)) v+  either (throwError . PP.docText . I.prettyInterpreterError) pure v'++-- | As 'evalExp', but convert the value to the flat representation expected by+-- the external programs we use. The description is used in the error message if+-- the value has no such representation.+evalExpToData :: Env -> T.Text -> UncheckedExp -> LiterateM Value+evalExpToData env what e = do+  (t, v) <- evalExp env e+  let nope = "Cannot " <> what <> " value of type " <> prettyText t+  maybe (throwError nope) pure =<< dataValue env v++-- | As 'dataValue', but for a value that is already present in full. Only+-- primitives and arrays of primitives have a flat representation, and not even+-- all of those: the element type of an empty array cannot be recovered from the+-- value alone.+localDataValue :: I.Value -> Maybe Value+localDataValue (IV.ValuePrim v) = primsToValue mempty [v]+localDataValue v@IV.ValueArray {} =+  primsToValue (SVec.fromList (map fromIntegral (dims (IV.valueShape v))))+    =<< prims v+  where+    prims (IV.ValueArray _ arr) = concat <$> mapM prims (A.elems arr)+    prims (IV.ValuePrim x) = Just [x]+    prims _ = Nothing+    dims (IV.ShapeDim n shape) = n : dims shape+    dims _ = []+localDataValue _ = Nothing++-- | Convert an interpreter value to the flat representation of the Futhark data+-- format, if it has one. A value that resides on the server is retrieved in its+-- entirety, which is far faster than forcing it, as that fetches an array one+-- element at a time.+dataValue :: Env -> I.Value -> LiterateM (Maybe Value)+dataValue env v@(IV.ValueLazyFFI _ vr []) = do+  r <- liftIO $ FFI.runServerM (envServer env) $ FFI.getData vr+  case r of+    Right (Just v') -> pure $ Just v'+    -- The value is opaque, or something went wrong; fall back to+    -- fetching it piecemeal, which may still work.+    _ -> dataValue env =<< force env v+dataValue env v@IV.ValueLazyFFI {} =+  -- A partially indexed array cannot be retrieved directly.+  dataValue env =<< force env v+dataValue _ v = pure $ localDataValue v++-- | The elements must all be of the same type, which is that of the+-- first one.+primsToValue :: SVec.Vector Int -> [F.PrimValue] -> Maybe Value+primsToValue shape vs =+  case vs of+    [] -> Nothing+    F.SignedValue (P.Int8Value _) : _ -> I8Value shape <$> vec asI8+    F.SignedValue (P.Int16Value _) : _ -> I16Value shape <$> vec asI16+    F.SignedValue (P.Int32Value _) : _ -> I32Value shape <$> vec asI32+    F.SignedValue (P.Int64Value _) : _ -> I64Value shape <$> vec asI64+    F.UnsignedValue (P.Int8Value _) : _ -> U8Value shape <$> vec (fmap fromIntegral . asI8)+    F.UnsignedValue (P.Int16Value _) : _ -> U16Value shape <$> vec (fmap fromIntegral . asI16)+    F.UnsignedValue (P.Int32Value _) : _ -> U32Value shape <$> vec (fmap fromIntegral . asI32)+    F.UnsignedValue (P.Int64Value _) : _ -> U64Value shape <$> vec (fmap fromIntegral . asI64)+    F.FloatValue (P.Float16Value _) : _ -> F16Value shape <$> vec asF16+    F.FloatValue (P.Float32Value _) : _ -> F32Value shape <$> vec asF32+    F.FloatValue (P.Float64Value _) : _ -> F64Value shape <$> vec asF64+    F.BoolValue _ : _ -> BoolValue shape <$> vec asBool+  where+    vec :: (SVec.Storable a) => (F.PrimValue -> Maybe a) -> Maybe (SVec.Vector a)+    vec f = SVec.fromList <$> mapM f vs+    asI8 (F.SignedValue (P.Int8Value x)) = Just x+    asI8 (F.UnsignedValue (P.Int8Value x)) = Just x+    asI8 _ = Nothing+    asI16 (F.SignedValue (P.Int16Value x)) = Just x+    asI16 (F.UnsignedValue (P.Int16Value x)) = Just x+    asI16 _ = Nothing+    asI32 (F.SignedValue (P.Int32Value x)) = Just x+    asI32 (F.UnsignedValue (P.Int32Value x)) = Just x+    asI32 _ = Nothing+    asI64 (F.SignedValue (P.Int64Value x)) = Just x+    asI64 (F.UnsignedValue (P.Int64Value x)) = Just x+    asI64 _ = Nothing+    asF16 (F.FloatValue (P.Float16Value x)) = Just x+    asF16 _ = Nothing+    asF32 (F.FloatValue (P.Float32Value x)) = Just x+    asF32 _ = Nothing+    asF64 (F.FloatValue (P.Float64Value x)) = Just x+    asF64 _ = Nothing+    asBool (F.BoolValue x) = Just x+    asBool _ = Nothing++newFile :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> LiterateM ()) -> LiterateM FilePath newFile env (fname_desired, template) m = do   let fname_base = fromMaybe (T.unpack (envHash env) <> "-" <> template) fname_desired       fname = envImgDir env </> fname_base@@ -723,11 +800,11 @@   modify $ \s -> s {stateFiles = S.insert fname $ stateFiles s}   pure fname -newFileContents :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> ScriptM ()) -> ScriptM T.Text+newFileContents :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> LiterateM ()) -> LiterateM T.Text newFileContents env f m =   liftIO . T.readFile =<< newFile env f m -processDirective :: Env -> Directive -> ScriptM T.Text+processDirective :: Env -> Directive -> LiterateM T.Text processDirective env (DirectiveBrief d) =   processDirective env d processDirective env (DirectiveCovert d) =@@ -735,51 +812,37 @@ processDirective env (DirectiveRes e) = do   result <-     newFileContents env (Nothing, "eval.txt") $ \resultf -> do-      v <- either nope pure =<< evalExpToGround literateBuiltin (envServer env) e-      liftIO $ T.writeFile resultf $ prettyText v+      v <- snd <$> evalExpForced env e+      liftIO $ T.writeFile resultf $ PP.docText $ I.prettyValue v   pure $ T.unlines ["```", result, "```"]-  where-    nope t =-      throwError $ "Cannot show value of type " <> prettyText t -- processDirective env (DirectiveImg e params) = do   fmap imgBlock . newFile env (imgFile params, "img.png") $ \pngfile -> do-    maybe_v <- evalExpToGround literateBuiltin (envServer env) e-    case maybe_v of-      Right (ValueAtom v)-        | Just bmp <- valueToBMP v -> do-            withTempDir $ \dir -> do-              let bmpfile = dir </> "img.bmp"-              liftIO $ LBS.writeFile bmpfile bmp-              void $ system "convert" [bmpfile, pngfile] mempty-      Right v ->-        nope $ fmap valueType v-      Left t ->-        nope t-  where-    nope t =-      throwError $-        "Cannot create image from value of type " <> prettyText t+    (t, v) <- evalExp env e+    bmp <- (valueToBMP =<<) <$> dataValue env v+    case bmp of+      Just bmp' ->+        withTempDir $ \dir -> do+          let bmpfile = dir </> "img.bmp"+          liftIO $ LBS.writeFile bmpfile bmp'+          void $ system "convert" [bmpfile, pngfile] mempty+      Nothing ->+        throwError $+          "Cannot create image from value of type " <> prettyText t -- processDirective env (DirectivePlot e size) = do   fmap imgBlock . newFile env (Nothing, "plot.png") $ \pngfile -> do-    maybe_v <- evalExpToGround literateBuiltin (envServer env) e-    case maybe_v of-      Right v-        | Just vs <- plottable2d v ->-            plotWith [(Nothing, vs)] pngfile-      Right (ValueRecord m)-        | Just m' <- traverse plottable2d m -> do-            plotWith (map (first Just) $ M.toList m') pngfile-      Right v ->-        throwError $ "Cannot plot value of type " <> prettyText (fmap valueType v)-      Left t ->-        throwError $ "Cannot plot opaque value of type " <> prettyText t+    (t, v) <- evalExp env e+    one <- plottable2d env v+    fields <- plottableFields (plottable2d env) v+    case (one, fields) of+      (Just vs, _) ->+        plotWith [(Nothing, vs)] pngfile+      (_, Just fs) ->+        plotWith (map (first Just) fs) pngfile+      _ ->+        throwError $ "Cannot plot value of type " <> prettyText t   where-    plottable2d v = do-      [x, y] <- plottable v-      Just [x, y]-     tag (Nothing, xys) j = ("data" <> showText (j :: Int), xys)     tag (Just f, xys) _ = (f, xys) @@ -807,15 +870,13 @@ -- processDirective env (DirectiveGnuplot e script) = do   fmap imgBlock . newFile env (Nothing, "plot.png") $ \pngfile -> do-    maybe_v <- evalExpToGround literateBuiltin (envServer env) e-    case maybe_v of-      Right (ValueRecord m)-        | Just m' <- traverse plottable m ->-            plotWith (M.toList m') pngfile-      Right v ->-        throwError $ "Cannot plot value of type " <> prettyText (fmap valueType v)-      Left t ->-        throwError $ "Cannot plot opaque value of type " <> prettyText t+    (t, v) <- evalExp env e+    fields <- plottableFields (plottable env) v+    case fields of+      Just fs ->+        plotWith fs pngfile+      Nothing ->+        throwError $ "Cannot plot value of type " <> prettyText t   where     plotWith xys pngfile = withGnuplotData [] xys $ \_ sets -> do       let script' =@@ -834,31 +895,25 @@    let file = (videoFile params, "video" <.> T.unpack format)   fmap (videoBlock params) . newFile env file $ \videofile -> do-    v <- evalExp literateBuiltin (envServer env) e+    (t, v) <- evalExp env e     let nope =           throwError $-            "Cannot produce video from value of type " <> prettyText (fmap scriptValueType v)+            "Cannot produce video from value of type " <> prettyText t     case v of-      ValueAtom SValue {} -> do-        ValueAtom arr <- getExpValue (envServer env) v-        case valueToBMPs arr of-          Nothing -> nope-          Just bmps ->+      IV.ValueRecord fs+        | Just [stepfun@IV.ValueFun {}, initial, num_frames] <- areTupleFields fs,+          IV.ValuePrim (F.SignedValue (P.Int64Value num_frames')) <- num_frames ->             withTempDir $ \dir -> do-              zipWithM_ (writeBMPFile dir) [0 ..] bmps+              renderFrames dir stepfun initial $ fromIntegral num_frames'               onWebM videofile =<< bmpsToVideo dir-      ValueTuple [stepfun, initial, num_frames]-        | ValueAtom (SFun stepfun' _ stepret closure) <- stepfun,-          Just [_, _] <- isScriptTuple (envServer env) stepret,-          ValueAtom (SValue "i64" _) <- num_frames -> do-            Just (ValueAtom num_frames') <--              mapM getValue <$> getExpValue (envServer env) num_frames+      _ -> do+        bmps <- (valueToBMPs =<<) <$> dataValue env v+        case bmps of+          Just bmps' ->             withTempDir $ \dir -> do-              let num_frames_int = fromIntegral (num_frames' :: Int64)-              renderFrames dir (stepfun', map ValueAtom closure) initial num_frames_int+              zipWithM_ (writeBMPFile dir) [0 ..] bmps'               onWebM videofile =<< bmpsToVideo dir-      _ ->-        nope+          Nothing -> nope   where     framerate = fromMaybe 30 $ videoFPS params     format = fromMaybe "webm" $ videoFormat params@@ -883,36 +938,26 @@       | otherwise =           (\_ _ -> pure (), pure ()) -    renderFrames dir (stepfun, closure) initial num_frames = do+    -- Only the image of each frame is fetched from the server; the+    -- state is passed straight back to the step function, so all the+    -- frames need not exist at once.+    renderFrames dir stepfun initial num_frames = do       foldM_ frame initial [0 .. num_frames - 1]       progressDone       where         frame old_state j = do           progressStep j num_frames-          v <--            evalExp literateBuiltin (envServer env)-              . Call (FuncFut stepfun)-              . map valueToExp-              $ closure ++ [old_state]-          freeValue (envServer env) old_state--          let nope =-                throwError $-                  "Cannot handle step function return type: "-                    <> prettyText (fmap scriptValueType v)--          arr <- project (envServer env) v "0"-          new_state <- project (envServer env) v "1"--          ValueAtom arr' <- getExpValue (envServer env) arr-          freeValue (envServer env) arr-          freeValue (envServer env) v--          case valueToBMP arr' of-            Nothing -> nope-            Just bmp -> do-              writeBMPFile dir j bmp-              pure new_state+          v <- runInterpreter env $ I.interpretApply (envCtx env) stepfun old_state+          case v of+            IV.ValueRecord fs+              | Just [arr, new_state] <- areTupleFields fs -> do+                  bmp <-+                    maybe badFrame pure . (valueToBMP =<<) =<< dataValue env arr+                  writeBMPFile dir j bmp+                  pure new_state+            _ -> badFrame+        badFrame =+          throwError "Cannot handle step function return value."      writeBMPFile dir j bmp =       liftIO $ LBS.writeFile (bmpfile dir j) bmp@@ -948,8 +993,8 @@   fmap imgBlock . newFile env (Nothing, "output." <> T.unpack output_format) $     \audiofile -> do       withTempDir $ \dir -> do-        maybe_v <- evalExpToGround literateBuiltin (envServer env) e-        maybe_raw_files <- toRawFiles dir maybe_v+        v <- evalExpToData env "create audio from" e+        maybe_raw_files <- toRawFiles dir v         case maybe_raw_files of           (input_format, raw_files) -> do             void $@@ -987,7 +1032,7 @@       let Just bytes = toBytes v       liftIO $ LBS.writeFile rawfile $ LBS.fromStrict bytes -    toRawFiles dir (Right (ValueAtom v))+    toRawFiles dir v       | length (valueShape v) == 1,         Just input_format <- toFfmpegFormat v = do           writeRaw dir "raw.pcm" v@@ -1003,7 +1048,7 @@               )               (valueElems v)               [0 :: Int ..]-    toRawFiles _ v = nope $ fmap (fmap valueType) v+    toRawFiles _ v = nope $ valueTypeText $ valueType v      toFfmpegFormat I8Value {} = Just "s8"     toFfmpegFormat U8Value {} = Just "u8"@@ -1027,7 +1072,7 @@      output_format = fromMaybe "wav" $ audioCodec params     sampling_frequency = fromMaybe 44100 $ audioSamplingFrequency params-    nope _ = throwError "Cannot create audio from value"+    nope t = throwError $ "Cannot create audio from value of type " <> t  -- Did this script block succeed or fail? data Failure = Failure | Success@@ -1050,7 +1095,7 @@         _ ->           "```\n" <> text <> "```\n"       env' = env {envHash = hashText (envHash env <> prettyText directive)}-  (r, files) <- runScriptM $ processDirective env' directive+  (r, files) <- runLiterateM $ processDirective env' directive   case r of     Left err -> failed prompt err files     Right t -> pure (Success, prompt <> "\n" <> t, files)@@ -1089,7 +1134,6 @@     (envImgDir env </> "CACHEDIR.TAG") `S.insert` mconcat files   pure (L.foldl' min Success failures, T.intercalate "\n" outputs) --- | Common command line options that transform 'Options'. scriptCommandLineOptions :: [FunOptDescr Options] scriptCommandLineOptions =   [ Option@@ -1107,7 +1151,7 @@           (\prog -> Right $ \config -> config {scriptFuthark = Just prog})           "PROGRAM"       )-      "The binary used for operations (defaults to same binary as 'futhark script').",+      "The binary used for operations (defaults to same binary as 'futhark literate').",     Option       "p"       ["pass-option"]@@ -1157,10 +1201,10 @@            "Stop and do not produce output file if any directive fails."        ] --- | Start up (and eventually shut down) a Futhark server--- corresponding to the provided program. If the program has a @.fut@--- extension, it will be compiled automatically.-prepareServer :: FilePath -> Options -> (ScriptServer -> IO a) -> IO a+-- Start up (and eventually shut down) a Futhark server corresponding+-- to the provided program. If the program has a @.fut@ extension, it+-- will be compiled automatically.+prepareServer :: FilePath -> Options -> (Server -> IO a) -> IO a prepareServer prog opts f = do   futhark <- maybe getExecutablePath pure $ scriptFuthark opts @@ -1197,7 +1241,7 @@                 else const . const $ pure ()           } -  withScriptServer cfg f+  withServer cfg f  -- | Run @futhark literate@. main :: String -> [String] -> IO ()@@ -1208,26 +1252,43 @@       let onError err = do             T.hPutStrLn stderr err             exitFailure+          onDocError err = do+            PP.hPutDocLn stderr err+            exitFailure       proghash <-         either onError pure <=< runExceptT $           system futhark ["hash", prog] mempty       script <- parseProgFile prog        orig_dir <- getCurrentDirectory-      let entryOpt v = "--entry-point=" ++ T.unpack v-          opts' =-            opts-              { scriptCompilerOptions =-                  map entryOpt (S.toList (varsInScripts script))-                    <> scriptCompilerOptions opts-              }-      prepareServer prog opts' $ \server -> do+      -- Every directive is interpreted, and may call any entry point of+      -- the program, so we cannot compile just a subset of them.+      prepareServer prog opts $ \server -> do+        -- The interpreter uses the server for entry point calls, and+        -- does not shut it down.+        ffi_server <- FFI.newServer server+        (_, imports, src) <-+          either (onDocError . prettyCompilerError) pure+            =<< runExceptT (readProgramFilesExceptKnown [] mempty [prog])+        let eval_cfg =+              evalConfig+                { evalPrintWarnings = False,+                  evalFile = Just prog,+                  evalBackend = Just $ scriptBackend opts+                }+        (_, tenv, ictx) <-+          either onDocError pure+            =<< initialiseInterpreter eval_cfg (Just prog) (Just ffi_server) imports+         let mdfile = fromMaybe (prog `replaceExtension` "md") $ scriptOutput opts             prog_dir = takeDirectory prog             imgdir = dropExtension (takeFileName mdfile) <> "-img"             env =               Env-                { envServer = server,+                { envServer = ffi_server,+                  envSrc = src,+                  envTypeEnv = tenv,+                  envCtx = ictx,                   envOpts = opts,                   envHash = proghash,                   envImgDir = imgdir
src/Futhark/CLI/Main.hs view
@@ -34,13 +34,14 @@ import Futhark.CLI.Query qualified as Query import Futhark.CLI.REPL qualified as REPL import Futhark.CLI.Run qualified as Run-import Futhark.CLI.Script qualified as Script import Futhark.CLI.Test qualified as Test import Futhark.CLI.WASM qualified as WASM import Futhark.Error import Futhark.Util (maxinum, showText) import Futhark.Util.Options-import GHC.IO.Encoding (setLocaleEncoding)+import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)+import GHC.IO.Encoding.Failure (CodingFailureMode (RoundtripFailure))+import GHC.IO.Encoding.UTF8 (mkUTF8) import GHC.IO.Exception (IOErrorType (..), IOException (..)) import System.Environment import System.Exit@@ -82,7 +83,6 @@       ("defs", (Defs.main, "Show location and name of all definitions.")),       ("query", (Query.main, "Query semantic information about program.")),       ("literate", (Literate.main, "Process a literate Futhark program.")),-      ("script", (Script.main, "Run FutharkScript expressions.")),       ("lsp", (LSP.main, "Run LSP server.")),       ("thanks", (Misc.mainThanks, "Express gratitude.")),       ("tokens", (Misc.mainTokens, "Print tokens from Futhark file.")),@@ -150,6 +150,10 @@   hSetEncoding stdout utf8   hSetEncoding stderr utf8   setLocaleEncoding utf8+  -- RoundtripFailure means file names that are not valid UTF-8 survive a+  -- decode/encode cycle unharmed.+  setFileSystemEncoding $ mkUTF8 RoundtripFailure+  setForeignEncoding $ mkUTF8 RoundtripFailure   args <- getArgs   prog <- getProgName   case args of
src/Futhark/CLI/Profile.hs view
@@ -3,16 +3,18 @@  import Control.Arrow ((&&&), (>>>)) import Control.Exception (catch)-import Control.Monad (forM_, (>=>))+import Control.Monad (forM_) import Control.Monad.Except (ExceptT, liftEither, runExcept, runExceptT) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (Except) import Data.Bifunctor (first, second) import Data.ByteString.Lazy.Char8 qualified as BS+import Data.Char (isAlphaNum, isAscii, ord) import Data.Foldable (toList) import Data.Function ((&)) import Data.List qualified as L import Data.Map qualified as M+import Data.Maybe (catMaybes, isJust) import Data.Monoid (Sum (..)) import Data.Sequence qualified as Seq import Data.Set qualified as S@@ -32,7 +34,7 @@   ) import Futhark.Profile.Details (CostCentreDetails (CostCentreDetails), CostCentreName (CostCentreName), CostCentres, SourceRangeDetails (SourceRangeDetails), SourceRanges, containingCostCentres) import Futhark.Profile.EventSummary qualified as ES-import Futhark.Profile.Html (generateCCOverviewHtml, generateHeatmapHtml, generateHtmlIndex, securedHashPath)+import Futhark.Profile.Html (generateCCOverviewHtml, generateHeatmapHtml, generateHtmlIndex, generateSourceIndex, securedHashPath) import Futhark.Profile.SourceRange (SourceRange) import Futhark.Profile.SourceRange qualified as SR import Futhark.Util (showText)@@ -53,6 +55,7 @@ import System.IO (hPutStrLn, stderr) import Text.Blaze.Html.Renderer.Text qualified as H import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A import Text.Printf (printf)  commonPrefix :: (Eq e) => [e] -> [e] -> [e]@@ -151,27 +154,36 @@     htmlDir :: FilePath   } -writeAnalysis :: TargetFiles -> ProfilingReport -> IO ()-writeAnalysis tf r = runExceptT >=> handleException $ do-  let evSummaryMap = ES.eventSummaries $ profilingEvents r+-- | Write text and HTML reports, even if source analysis is unavailable.+writeAnalysis :: TargetFiles -> Maybe T.Text -> Maybe ProfilingReport -> IO ()+writeAnalysis tf logText profilingReport = do+  createDirectoryIfMissing True $ htmlDir tf+  T.writeFile (htmlDir tf </> "style.css") cssFile -  -- heatmap html and cost centres-  writeHtml tf evSummaryMap+  let timelineText = timeline . profilingEvents <$> profilingReport+  sourceIndex <- case profilingReport of+    Nothing -> pure $ H.p "No profiling information recorded."+    Just r -> do+      let evSummaryMap = ES.eventSummaries $ profilingEvents r+      T.writeFile (summaryFile tf) $+        memoryReport (profilingMemory r)+          <> "\n\n"+          <> tabulateEvents evSummaryMap+      forM_ timelineText $ T.writeFile (timelineFile tf) -  -- profile.summary-  liftIO $-    T.writeFile (summaryFile tf) $-      memoryReport (profilingMemory r)-        <> "\n\n"-        <> tabulateEvents evSummaryMap+      sourceResult <- runExceptT $ writeHtml tf evSummaryMap+      case sourceResult of+        Left err -> do+          T.hPutStrLn stderr err+          pure $ do+            H.p "Source information unavailable."+            H.pre $ H.text err+        Right html -> pure html -  -- profile.timeline-  liftIO $-    T.writeFile (timelineFile tf) $-      timeline (profilingEvents r)-  where-    handleException :: Either T.Text () -> IO ()-    handleException = either (T.hPutStrLn stderr) pure+  let relHtmlDirPath = last $ splitPath $ htmlDir tf+  LT.writeFile (htmlIndexFile tf) $+    H.renderHtml $+      generateHtmlIndex relHtmlDirPath logText timelineText sourceIndex  toIOExcept :: Except T.Text a -> ExceptT T.Text IO a toIOExcept = liftEither . runExcept@@ -181,27 +193,14 @@   TargetFiles ->   -- | mapping keys are (name, provenance)   M.Map (T.Text, T.Text) ES.EvSummary ->-  ExceptT T.Text IO ()+  ExceptT T.Text IO H.Html writeHtml tf evSummaryMap = do   let htmlDirPath = htmlDir tf-  let htmlIndexPath = htmlIndexFile tf   (sourceRanges, costCentres) <- toIOExcept $ buildDetailStructures evSummaryMap   htmlFiles <- generateHtmlHeatmaps sourceRanges   let costCentreOverview = generateCCOverviewHtml costCentres    liftIO $ do-    -- create the bench.html/ directory-    createDirectoryIfMissing True htmlDirPath-    -- style is needed by both cc-overview and source ranges-    let cssPath = htmlDirPath </> "style.css"-    T.writeFile cssPath cssFile--    -- index file-    let relHtmlDirPath = last $ splitPath htmlDirPath-    LT.writeFile-      htmlIndexPath-      (H.renderHtml $ generateHtmlIndex relHtmlDirPath sourceRanges costCentres)-     -- cost centre file     LT.writeFile       (htmlDirPath </> "cost-centres.html")@@ -213,6 +212,9 @@             htmlDirPath </> makeRelative "/" (srcFilePath <> ".html")       writeLazyTextFile absPath (H.renderHtml html) +  let relHtmlDirPath = last $ splitPath htmlDirPath+  pure $ generateSourceIndex relHtmlDirPath sourceRanges+ writeLazyTextFile :: FilePath -> LT.Text -> IO () writeLazyTextFile filepath content = do   createDirectoryIfMissing True $ takeDirectory filepath@@ -402,18 +404,22 @@         TargetFiles           { summaryFile = top_dir </> "summary",             timelineFile = top_dir </> "timeline",-            htmlIndexFile = top_dir </> "index",+            htmlIndexFile = top_dir </> "index.html",             htmlDir = top_dir </> "html/"           }-  writeAnalysis tf r+  writeAnalysis tf Nothing $ Just r  analyseBenchResults :: FilePath -> [BenchResult] -> IO () analyseBenchResults json_path bench_results = do   top_dir <- prepareDir json_path   T.hPutStrLn stderr $ "Stripping '" <> T.pack prefix <> "' from program paths."-  mapM_ (onBenchResult top_dir) bench_results+  programs <- mapM (onBenchResult top_dir) bench_results+  writeNavigationIndex (top_dir </> "index.html") "Program Index" programs   where-    prefix = longestCommonPrefix $ map benchResultProg bench_results+    programPaths = map (takeWhile (/= ':') . benchResultProg) bench_results+    prefix = case S.toList $ S.fromList programPaths of+      [path] -> path+      paths -> takeDirectory $ longestCommonPrefix paths      -- Eliminate characters that are filesystem-meaningful.     escape '/' = '_'@@ -424,13 +430,26 @@      onBenchResult top_dir (BenchResult prog_path data_results) = do       let (prog_path', entry) = span (/= ':') prog_path-          prog_name = drop (length prefix) prog_path'-          prog_dir = top_dir </> dropExtension prog_name </> drop 1 entry+          prog_name = makeRelative prefix prog_path'+          relative_dir = dropExtension prog_name </> drop 1 entry+          -- Preserve the established <entry>/<dataset>-index.html layout for+          -- one source file. A file without an entry point still needs its+          -- own directory so it does not collide with the top-level index.+          prog_dir =+            top_dir+              </> if null relative_dir || relative_dir == "."+                then "program"+                else relative_dir       createDirectoryIfMissing True prog_dir-      mapM_ (onDataResult prog_dir (T.pack prog_name)) data_results+      datasets <-+        catMaybes <$> mapM (onDataResult prog_dir (T.pack prog_name)) data_results+      let index = prog_dir </> "index.html"+      writeNavigationIndex index (T.pack prog_path) datasets+      pure (T.pack prog_path, makeRelative top_dir index) -    onDataResult _ prog_name (DataResult name (Left _)) =+    onDataResult _ prog_name (DataResult name (Left _)) = do       problem prog_name name "execution failed"+      pure Nothing     onDataResult prog_dir prog_name (DataResult name (Right res)) = do       let name' = prog_dir </> T.unpack (T.map escape name)       case stdErr res of@@ -438,15 +457,39 @@         Just text -> T.writeFile (name' <.> ".log") text       case report res of         Nothing -> problem prog_name name "no profiling information"-        Just r ->-          let tf =-                TargetFiles-                  { summaryFile = name' <> ".summary",-                    timelineFile = name' <> ".timeline",-                    htmlIndexFile = name' <> "-index.html",-                    htmlDir = name' <> ".html/"-                  }-           in writeAnalysis tf r+        Just _ -> pure ()+      let tf =+            TargetFiles+              { summaryFile = name' <> ".summary",+                timelineFile = name' <> ".timeline",+                htmlIndexFile = name' <> "-index.html",+                htmlDir = name' <> ".html/"+              }+      if isJust (stdErr res) || isJust (report res)+        then do+          writeAnalysis tf (stdErr res) (report res)+          pure $ Just (name, makeRelative prog_dir $ htmlIndexFile tf)+        else pure Nothing++-- | Write an index of generated reports, with paths relative to the index.+writeNavigationIndex :: FilePath -> T.Text -> [(T.Text, FilePath)] -> IO ()+writeNavigationIndex path title links =+  writeLazyTextFile path $ H.renderHtml $ H.docTypeHtml $ do+    H.head $ do+      H.meta H.! A.charset "utf-8"+      H.title $ H.text title+      H.style $ H.text cssFile+    H.body $ do+      H.h2 $ H.text title+      H.ul $ forM_ links $ \(label, target) ->+        H.li $ H.a H.! A.href (H.toValue $ escapePath target) $ H.text label+  where+    -- Percent-encode UTF-8 bytes, retaining separators and URI-unreserved bytes.+    escapePath =+      concatMap escapeByte . BS.unpack . BS.fromStrict . T.encodeUtf8 . T.pack+    escapeByte c+      | isAscii c && (isAlphaNum c || c `elem` ['-', '.', '/', '_', '~']) = [c]+      | otherwise = printf "%%%02X" (ord c)  readFileSafely :: FilePath -> IO (Either String BS.ByteString) readFileSafely filepath =
src/Futhark/CLI/REPL.hs view
@@ -18,6 +18,15 @@ import Data.Text.IO qualified as T import Data.Version import Futhark.Compiler+import Futhark.Error (badOnLeft)+import Futhark.Eval+  ( EvalConfig (..),+    evalConfig,+    evalServerOptions,+    forceValue,+    initialiseInterpreter,+    runFFI,+  ) import Futhark.Format (parseFormatString) import Futhark.MonadFreshNames import Futhark.Util (fancyTerminal, showText)@@ -26,6 +35,7 @@ import Futhark.Version import Language.Futhark import Language.Futhark.Interpreter qualified as I+import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI import Language.Futhark.Parser import Language.Futhark.Semantic qualified as T import Language.Futhark.TypeChecker qualified as T@@ -48,10 +58,10 @@  -- | Run @futhark repl@. main :: String -> [String] -> IO ()-main = mainWithOptions () [] "options... [program.fut]" run+main = mainWithOptions evalConfig evalServerOptions "options... [program.fut]" run   where-    run [] _ = Just $ repl Nothing-    run [prog] _ = Just $ repl $ Just prog+    run [] cfg = Just $ repl cfg Nothing+    run [prog] cfg = Just $ repl cfg $ Just prog     run _ _ = Nothing  data StopReason = EOF | Stop | Exit | Load FilePath | Interrupt@@ -60,8 +70,8 @@ replSettings =   Haskeline.setComplete replComplete Haskeline.defaultSettings -repl :: Maybe FilePath -> IO ()-repl maybe_prog = do+repl :: EvalConfig -> Maybe FilePath -> IO ()+repl cfg maybe_prog = do   when fancyTerminal $ do     putDoc banner     putStrLn $ "Version " ++ showVersion version ++ "."@@ -86,20 +96,28 @@           Left (Load file) -> do             liftIO $ T.putStrLn $ "Loading " <> T.pack file             maybe_new_state <--              liftIO $ newFutharkiState (futharkiCount s) (futharkiProg s) $ Just file+              liftIO $ newFutharkiState cfg (futharkiCount s) (futharkiProg s) $ Just file             case maybe_new_state of-              Right new_state -> toploop new_state+              Right new_state -> do+                liftIO $ stopServer s+                toploop new_state               Left err -> do                 liftIO $ putDocLn err                 toploop s'           Right _ -> pure () -      finish _s = pure ()+      finish = liftIO . stopServer -  maybe_init_state <- liftIO $ newFutharkiState 0 noLoadedProg maybe_prog+      -- A server that has already crashed will complain when shut+      -- down, which is no reason to take the REPL with it.+      stopServer s = case futharkiServer s of+        Nothing -> pure ()+        Just server -> mapM_ T.putStrLn =<< FFI.stopServer server++  maybe_init_state <- liftIO $ newFutharkiState cfg 0 noLoadedProg maybe_prog   s <- case maybe_init_state of     Left prog_err -> do-      noprog_init_state <- liftIO $ newFutharkiState 0 noLoadedProg Nothing+      noprog_init_state <- liftIO $ newFutharkiState cfg 0 noLoadedProg Nothing       case noprog_init_state of         Left err ->           error $ "Failed to initialise interpreter state: " <> T.unpack (docText err)@@ -130,7 +148,9 @@     futharkiSkipBreaks :: [Loc],     futharkiBreakOnNaN :: Bool,     -- | The currently loaded file.-    futharkiLoaded :: Maybe FilePath+    futharkiLoaded :: Maybe FilePath,+    -- | Possibly a computation server.+    futharkiServer :: Maybe FFI.Server   }  extendEnvs :: LoadedProg -> (T.Env, I.Ctx) -> [ImportName] -> (T.Env, I.Ctx)@@ -141,26 +161,23 @@     t_imports = filter ((`elem` opens) . fst) $ lpImports prog     i_envs = map snd $ filter ((`elem` opens) . fst) $ M.toList $ I.ctxImports ictx -newFutharkiState :: Int -> LoadedProg -> Maybe FilePath -> IO (Either (Doc AnsiStyle) FutharkiState)-newFutharkiState count prev_prog maybe_file = runExceptT $ do+newFutharkiState ::+  EvalConfig ->+  Int ->+  LoadedProg ->+  Maybe FilePath ->+  IO (Either (Doc AnsiStyle) FutharkiState)+newFutharkiState cfg count prev_prog maybe_file = runExceptT $ do   let files = maybeToList maybe_file   -- Put code through the type checker.   prog <-     badOnLeft prettyProgErrors       =<< liftIO (reloadProg prev_prog files M.empty)   liftIO $ putDoc $ prettyWarnings $ lpWarnings prog-  -- Then into the interpreter.-  ictx <--    foldM-      (\ctx -> badOnLeft (pretty . show) <=< runInterpreterNoBreak . I.interpretImport ctx)-      I.initialCtx-      $ map (fmap fileProg) (lpImports prog) -  let (tenv, ienv) =-        let (iname, fm) = last $ lpImports prog-         in ( fileScope fm,-              ictx {I.ctxEnv = I.ctxImports ictx M.! iname}-            )+  -- Then into the interpreter.+  (server, tenv, ienv) <-+    ExceptT $ initialiseInterpreter cfg maybe_file Nothing $ lpImports prog    pure     FutharkiState@@ -170,12 +187,9 @@         futharkiBreaking = Nothing,         futharkiSkipBreaks = mempty,         futharkiBreakOnNaN = False,-        futharkiLoaded = maybe_file+        futharkiLoaded = maybe_file,+        futharkiServer = server       }-  where-    badOnLeft :: (err -> err') -> Either err a -> ExceptT err' IO a-    badOnLeft _ (Right x) = pure x-    badOnLeft p (Left err) = throwError $ p err  getPrompt :: FutharkiM String getPrompt = do@@ -282,7 +296,12 @@           r <- runInterpreter $ I.interpretExp ienv e'           case r of             Left err -> pure $ Left $ pretty $ showText err-            Right v -> pure $ Right v+            Right v -> do+              -- Whatever we do with the value next (printing it, most+              -- likely) requires having it in full.+              server <- gets futharkiServer+              either (Left . I.prettyInterpreterError) Right+                <$> liftIO (forceValue server v)       | otherwise ->           pure $             Left $@@ -362,20 +381,12 @@                 }        c--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 _ I.BreakNaN _ c) = c-    intOp (I.ExtOpBreak w _ _ c) = do-      liftIO $-        T.putStrLn $-          locText w <> ": " <> "ignoring breakpoint when computating constant."-      c+    intOp (I.ExtOpFFI sm c) = do+      server <- gets futharkiServer+      either (pure . Left) c =<< liftIO (runFFI server sm)+    intOp (I.ExtOpIO op c) = do+      server <- gets futharkiServer+      either (pure . Left . I.InterpreterError) c =<< liftIO (I.doIOOp server op)  replComplete :: Haskeline.CompletionFunc IO replComplete = loadComplete
src/Futhark/CLI/Run.hs view
@@ -3,7 +3,7 @@  import Control.Exception import Control.Monad-import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.Except (runExceptT) import Control.Monad.Free.Church import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString.Lazy qualified as BS@@ -12,6 +12,7 @@ import Data.Text.IO qualified as T import Futhark.Compiler import Futhark.Data.Reader (readValues)+import Futhark.Eval (interpretImports) import Futhark.Pipeline import Futhark.Util.Options import Futhark.Util.Pretty (AnsiStyle, Doc, align, hPutDoc, hPutDocLn, pretty, unAnnotate, (<+>))@@ -32,7 +33,7 @@  interpret :: InterpreterConfig -> FilePath -> IO () interpret config fp = do-  pr <- newFutharkiState config fp+  pr <- newInterpreterEnv config fp   (tenv, ienv) <- case pr of     Left err -> do       hPutDocLn stderr err@@ -74,7 +75,7 @@             (Just vs, Just ts) -> zipWithM_ putValue vs ts             _ -> putValue res ret -putValue :: I.Value -> TypeBase () () -> IO ()+putValue :: I.Value -> TypeBase () NoMode -> IO () putValue v t   | I.isEmptyArray v = T.putStrLn $ I.prettyEmptyArray t v   | otherwise = T.putStrLn $ I.valueText v@@ -106,11 +107,11 @@       "Do not print warnings."   ] -newFutharkiState ::+newInterpreterEnv ::   InterpreterConfig ->   FilePath ->   IO (Either (Doc AnsiStyle) (T.Env, I.Ctx))-newFutharkiState cfg file = runExceptT $ do+newInterpreterEnv cfg file = runExceptT $ do   (ws, imports, _src) <-     badOnLeft prettyCompilerError       =<< liftIO@@ -123,22 +124,7 @@       hPutDoc stderr $         prettyWarnings ws -  let loadImport ctx =-        badOnLeft I.prettyInterpreterError-          <=< runInterpreter' . I.interpretImport ctx--  ictx <- foldM loadImport 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 (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+  interpretImports runInterpreter' imports  runInterpreter' :: (MonadIO m) => F I.ExtOp a -> m (Either I.InterpreterError a) runInterpreter' m = runF m (pure . Right) intOp@@ -148,3 +134,6 @@       liftIO $ hPutDocLn stderr $ pretty w <> ":" <+> align (unAnnotate v)       c     intOp (I.ExtOpBreak _ _ _ c) = c+    intOp (I.ExtOpFFI {}) = error "External calls are not yet supported in Run."+    intOp (I.ExtOpIO op c) =+      either (pure . Left . I.InterpreterError) c =<< liftIO (I.doIOOp Nothing op)
− src/Futhark/CLI/Script.hs 
@@ -1,138 +0,0 @@--- | @futhark script@-module Futhark.CLI.Script (main) where--import Control.Monad.Except-import Control.Monad.IO.Class (MonadIO)-import Data.Binary qualified as Bin-import Data.ByteString.Lazy.Char8 qualified as BS-import Data.Char (chr)-import Data.Text qualified as T-import Data.Text.IO qualified as T-import Futhark.CLI.Literate-  ( Options (..),-    initialOptions,-    prepareServer,-    scriptCommandLineOptions,-  )-import Futhark.Script-import Futhark.Test.Values (Compound (..))-import Futhark.Util.Options-import Futhark.Util.Pretty (prettyText)-import System.Exit-import System.IO--commandLineOptions :: [FunOptDescr Options]-commandLineOptions =-  scriptCommandLineOptions-    ++ [ Option-           "D"-           ["debug"]-           ( NoArg $ Right $ \config ->-               config-                 { scriptExtraOptions = "-D" : scriptExtraOptions config,-                   scriptVerbose = scriptVerbose config + 1-                 }-           )-           "Enable debugging.",-         Option-           "L"-           ["log"]-           ( NoArg $ Right $ \config ->-               config-                 { scriptExtraOptions = "-L" : scriptExtraOptions config,-                   scriptVerbose = scriptVerbose config + 1-                 }-           )-           "Enable logging.",-         Option-           "b"-           ["binary"]-           (NoArg $ Right $ \config -> config {scriptBinary = True})-           "Produce binary output.",-         Option-           "f"-           ["file"]-           ( ReqArg-               (\f -> Right $ \config -> config {scriptExps = scriptExps config ++ [Left f]})-               "FILE"-           )-           "Run FutharkScript from this file.",-         Option-           "e"-           ["expression"]-           ( ReqArg-               (\s -> Right $ \config -> config {scriptExps = scriptExps config ++ [Right (T.pack s)]})-               "EXP"-           )-           "Run this expression."-       ]--parseScriptFile :: FilePath -> IO Exp-parseScriptFile f = do-  s <- T.readFile f-  case parseExpFromText f s of-    Left e -> do-      T.hPutStrLn stderr e-      exitFailure-    Right e -> pure e--getExp :: Either FilePath T.Text -> IO Exp-getExp (Left f) = parseScriptFile f-getExp (Right s) = case parseExpFromText "command line option" s of-  Left e -> do-    T.hPutStrLn stderr e-    exitFailure-  Right e -> pure e---- A few extra procedures that are not handled by scriptBuiltin.-extScriptBuiltin :: (MonadError T.Text m, MonadIO m) => EvalBuiltin m-extScriptBuiltin server "store" vs-  | [fv, v@(ValueAtom (SValue _ _))] <- vs = do-      fv' <- getHaskellValue server fv-      case fv' of-        Just path -> do-          let path' = map (chr . fromIntegral) (path :: [Bin.Word8])-          storeExpValue server path' v-          pure $ ValueTuple []-        _ -> bad-  | otherwise = bad-  where-    bad =-      throwError $-        "$store does not accept arguments of types: "-          <> T.intercalate ", " (map (prettyText . fmap scriptValueType) vs)-extScriptBuiltin server f vs =-  scriptBuiltin "." server f vs---- | Run @futhark script@.-main :: String -> [String] -> IO ()-main = mainWithOptions initialOptions commandLineOptions "PROGRAM [EXP]" $ \args opts ->-  case args of-    [prog, script] -> Just $ main' prog opts $ scriptExps opts ++ [Right $ T.pack script]-    [prog] -> Just $ main' prog opts $ scriptExps opts-    _ -> Nothing-  where-    main' prog opts scripts = do-      scripts' <- mapM getExp scripts-      prepareServer prog opts $ \s -> do-        r <--          runExceptT $ do-            vs <- mapM (evalExp extScriptBuiltin s) scripts'-            case reverse vs of-              [] -> pure Nothing-              v : _ -> Just <$> getExpValue s v <* freeValue s v-        case r of-          Left e -> do-            T.hPutStrLn stderr e-            exitFailure-          Right Nothing ->-            pure ()-          Right (Just v) ->-            if scriptBinary opts-              then case v of-                ValueAtom v' -> BS.putStr $ Bin.encode v'-                _ ->-                  T.hPutStrLn-                    stderr-                    "Result value cannot be represented in binary format."-              else T.putStrLn $ prettyText v
src/Futhark/CLI/Test.hs view
@@ -26,7 +26,7 @@ import Futhark.Analysis.Metrics.Type import Futhark.Server import Futhark.Test-import Futhark.Util (atMostChars, fancyTerminal, randomSeed, showText)+import Futhark.Util (atMostChars, fancyTerminal, nubOrd, randomSeed, showText) import Futhark.Util.Options import Futhark.Util.Pretty (annotate, bgColor, bold, hardline, pretty, putDoc, vsep) import Futhark.Util.Table@@ -399,8 +399,6 @@           onRes = either (Failure . pure) (const Success)       mapM (fmap onRes . runCompiledCase input_types' (out, out_t) ins) run_cases   where-    dir = takeDirectory program-     runCompiledCase input_types (out, out_t) ins run = runExceptT $ do       let TestRun _ input_spec _ index _ = run           case_ctx =@@ -412,10 +410,10 @@       context1 case_ctx $ do         expected <- getExpectedResult futhark program entry run -        valuesAsVars server (zip ins (map inputType input_types)) futhark dir input_spec+        ins' <- valuesAsVars server entry (zip ins (map inputType input_types)) futhark program input_spec -        call_r <- liftIO $ cmdCall server entry out ins-        liftCommand $ cmdFree server ins+        call_r <- liftIO $ cmdCall server entry out ins'+        liftCommand $ cmdFree server $ nubOrd ins'          let res = case call_r of               Left (CmdFailure _ err) ->
src/Futhark/CodeGen/Backends/CCUDA.hs view
@@ -49,11 +49,19 @@   GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_program(struct futhark_context_config *cfg, const char* s);|]   GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char* s);|]   GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_ptx_from(struct futhark_context_config *cfg, const char* s);|]+  GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_use_primary_context(struct futhark_context_config *cfg, int flag);|]  cliOptions :: [Option] cliOptions =   gpuOptions     ++ [ Option+           { optionLongName = "use-primary-context",+             optionShortName = Nothing,+             optionArgument = NoArgument,+             optionDescription = "Use the device's primary context instead of creating a new one (for sharing device pointers with other libraries such as XLA).",+             optionAction = [C.cstm|futhark_context_config_set_use_primary_context(cfg, 1);|]+           },+         Option            { optionLongName = "dump-cuda",              optionShortName = Nothing,              optionArgument = RequiredArgument "FILE",
src/Futhark/CodeGen/Backends/GPU.hs view
@@ -134,7 +134,7 @@         )     mkArgs i (MemKArg v) = do       let arg = "arg" <> show i-      v' <- GC.rawMem v+      v' <- GC.rawMem v (Space "device")       pure         ( [C.cparam|typename gpu_mem $id:arg|],           ([C.cexp|sizeof($id:arg)|], [C.cexp|&$id:arg|]),@@ -213,11 +213,13 @@       dststride_inits = [[C.cinit|$exp:e|] | Count e <- dststride]       srcstride_inits = [[C.cinit|$exp:e|] | Count e <- srcstride]       shape_inits = [[C.cinit|$exp:e|] | Count e <- shape]+  provenance <- GC.provenanceExp   GC.stm     [C.cstm|          if ((err =                 lmad_copy_gpu2host-                         (ctx, $int:(primByteSize t::Int), $exp:sync', $int:r,+                         (ctx, $exp:provenance,+                          $int:(primByteSize t::Int), $exp:sync', $int:r,                           $exp:dst, $exp:(unCount dstoffset),                           (typename int64_t[]){ $inits:dststride_inits },                           $exp:src, $exp:(unCount srcoffset),
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -300,8 +300,8 @@     cCLI :: T.Text,     cServer :: T.Text,     cLib :: T.Text,-    -- | The manifest, in JSON format.-    cJsonManifest :: T.Text+    -- | The manifest describing the C API.+    cManifest :: Manifest.Manifest   }  gnuSource :: T.Text@@ -347,7 +347,7 @@ asLibrary parts =   ( "#pragma once\n\n" <> cHeader parts,     gnuSource <> disableWarnings <> cHeader parts <> cUtils parts <> cLib parts,-    cJsonManifest parts+    Manifest.manifestToJSON $ cManifest parts   )  -- | As executable with command-line interface.@@ -493,7 +493,7 @@           cCLI = clidefs,           cServer = serverdefs,           cLib = libdefs,-          cJsonManifest = Manifest.manifestToJSON manifest+          cManifest = manifest         },       endstate     )@@ -702,6 +702,11 @@     getConst (ScalarParam name bt) = do       let ctp = primTypeToCType bt       pure [C.citem|$ty:ctp $id:name = ctx->constants->$id:name;|]+    -- A 'ScalarSpace' block is a C array, and C cannot assign those.  The+    -- array in the constants struct is the one we want to use anyway, so+    -- name it through a pointer.+    getConst (MemParam name (ScalarSpace _ pt)) =+      pure [C.citem|$ty:(primTypeToCType pt) *$id:name = ctx->constants->$id:name;|]     getConst (MemParam name space) = do       ty <- memToCType name space       pure [C.citem|$ty:ty $id:name = ctx->constants->$id:name;|]
src/Futhark/CodeGen/Backends/GenericC/Code.hs view
@@ -179,13 +179,13 @@  compileRead ::   VName ->-  Count u (TPrimExp t VName) ->+  Count m (TPrimExp t VName) ->   PrimType ->   Space ->   Volatility ->   CompilerM op s C.Exp compileRead src (Count iexp) restype space vol = do-  src' <- rawMem src+  src' <- rawMem src space   iexp' <- compileExp (untyped iexp)   generateRead src' iexp' restype space vol @@ -338,8 +338,8 @@   case cp of     Just cp' | t /= Unit -> do       shape' <- traverse (traverse (compileExp . untyped)) shape-      dst' <- rawMem dst-      src' <- rawMem src+      dst' <- rawMem dst dstspace+      src' <- rawMem src srcspace       dstoffset' <- traverse (compileExp . untyped) dstoffset       dststrides' <- traverse (traverse (compileExp . untyped)) dststrides       srcoffset' <- traverse (compileExp . untyped) srcoffset@@ -349,7 +349,7 @@       compileCopy t shape (dst, dstspace) (dstoffset, dststrides) (src, srcspace) (srcoffset, srcstrides) compileCode (Write _ _ Unit _ _ _) = pure () compileCode (Write dst (Count idx) elemtype space vol elemexp) = do-  dst' <- rawMem dst+  dst' <- rawMem dst space   idx' <- compileExp (untyped idx)   elemexp' <- compileExp elemexp   generateWrite dst' idx' elemtype space vol elemexp'@@ -469,8 +469,8 @@   ) ->   CompilerM op s () compileCopy t shape (dst, dstspace) dst_lmad (src, srcspace) src_lmad = do-  src' <- rawMem src-  dst' <- rawMem dst+  src' <- rawMem src srcspace+  dst' <- rawMem dst dstspace   let doWrite dst_i = generateWrite dst' dst_i t dstspace Nonvolatile       doRead src_i = generateRead src' src_i t srcspace Nonvolatile   compileCopyWith shape doWrite dst_lmad doRead src_lmad
src/Futhark/CodeGen/Backends/GenericC/EntryPoints.hs view
@@ -236,14 +236,14 @@     vdType (OpaqueValue name _) =       nameToText name -    outputManifest (u, vd) =+    outputManifest (o, vd) =       Manifest.Output         { Manifest.outputType = vdType vd,-          Manifest.outputUnique = u == Unique+          Manifest.outputFresh = o == Consume         }-    inputManifest ((v, u), vd) =+    inputManifest ((v, o), vd) =       Manifest.Input         { Manifest.inputName = nameToText v,           Manifest.inputType = vdType vd,-          Manifest.inputUnique = u == Unique+          Manifest.inputConsumed = o == Consume         }
src/Futhark/CodeGen/Backends/GenericC/Monad.hs view
@@ -515,10 +515,13 @@ fatMemUnRef (Space sid) = "memblock_unref_" ++ sid fatMemUnRef _ = "memblock_unref" -rawMem :: VName -> CompilerM op s C.Exp-rawMem v = rawMem' <$> fat <*> pure v+-- | The C expression for the raw pointer (or array) underlying a memory block.+rawMem :: VName -> Space -> CompilerM op s C.Exp+rawMem v space = rawMem' <$> fat <*> pure v   where-    fat = asks ((&&) . opsFatMemory . envOperations) <*> (isNothing <$> cacheMem v)+    fat = case space of+      ScalarSpace {} -> pure False+      _ -> asks ((&&) . opsFatMemory . envOperations) <*> (isNothing <$> cacheMem v)  rawMem' :: (C.ToExp a) => Bool -> a -> C.Exp rawMem' True e = [C.cexp|$exp:e.mem|]
src/Futhark/CodeGen/Backends/GenericC/Server.hs view
@@ -149,7 +149,7 @@       array_name = type_name <> "_array"       info_name = et <> "_info"       array_new_wrap = arrayNew ops <> "_wrap"-      array_set = arrayNew ops <> "_set"+      array_set_wrap = arraySet 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]]@@ -164,18 +164,11 @@                 *out = $id:(arrayNew ops)(ctx, p, $args:shape_args);                 return 0;               }-              int $id:array_set(struct futhark_context *ctx,-                                typename $id:c_type_name arr,-                                $ty:element_c_type *val,-                                const typename int64_t *is) {-                const typename int64_t *shape = $id:(arrayShape ops)(ctx, arr);-                typename uint64_t idx = is[0];-                for (int i = 1; i < $int:rank; ++i) {-                  idx *= shape[i-1];-                  idx += is[i];-                }-                (($ty:element_c_type*)$id:(arrayValuesRaw ops)(ctx, arr))[idx] = *val;-                return 0;+              int $id:array_set_wrap(struct futhark_context *ctx,+                                     typename $id:c_type_name arr,+                                     $ty:element_c_type *val,+                                     const typename int64_t *is) {+                return $id:(arraySet ops)(ctx, arr, *val, $args:is_args);               }               int $id:array_index_wrap(struct futhark_context *ctx,                                        void *dest,@@ -191,7 +184,7 @@                 .num_fields = 0,                 .fields = NULL,                 .new = (typename array_new_fn)$id:array_new_wrap,-                .set = (typename array_set_fn)$id:array_set,+                .set = (typename array_set_fn)$id:array_set_wrap,                 .shape = (typename array_shape_fn)$id:(arrayShape ops),                 .index = (typename array_index_fn)$id:array_index_wrap,                 .values = (typename array_values_fn)$id:(arrayValues ops),@@ -455,7 +448,7 @@       out_type = outputType output       in_types = map inputType inputs       in_types_name = nameFromText name <> "_in_types"-      in_unique_name = nameFromText name <> "_in_unique"+      in_consumed_name = nameFromText name <> "_in_consumed"       tuning_params_name = nameFromText name <> "_tuning_params"       attrs_name = nameFromText name <> "_attrs"       (in_items, in_args)@@ -466,7 +459,7 @@                   $inits:(map typeStructInit in_types),                   NULL                 };-                bool $id:in_unique_name[] = {+                bool $id:in_consumed_name[] = {                   $inits:(map inputUniqueInit inputs)                 };                 const char* $id:tuning_params_name[] = {@@ -488,15 +481,15 @@             .tuning_params = $id:tuning_params_name,             .in_types = $id:in_types_name,             .out_type = $init:(typeStructInit out_type),-            .in_unique = $id:in_unique_name,-            .out_unique = $init:(outputUniqueInit output),+            .in_consumed = $id:in_consumed_name,+            .out_fresh = $init:(outputUniqueInit output),             .attrs = $id:attrs_name             }|]       )   where     typeStructInit tname = [C.cinit|&$id:(typeStructName tname)|]-    inputUniqueInit = uniqueInit . inputUnique-    outputUniqueInit = uniqueInit . outputUnique+    inputUniqueInit = uniqueInit . inputConsumed+    outputUniqueInit = uniqueInit . outputFresh     uniqueInit True = [C.cinit|true|]     uniqueInit False = [C.cinit|false|]
src/Futhark/CodeGen/Backends/GenericC/Types.hs view
@@ -78,6 +78,7 @@   values_raw_array <- publicName $ "values_raw_" <> name   shape_array <- publicName $ "shape_" <> name   index_array <- publicName $ "index_" <> name+  set_array <- publicName $ "set_" <> name    let shape_names = ["dim" <> prettyText i | i <- [0 .. rank - 1]]       shape_params = [[C.cparam|typename int64_t $id:k|] | k <- shape_names]@@ -148,6 +149,19 @@         index_exp         space         [C.cexp|$int:(primByteSize pt::Int)|]+  -- The source is a function parameter, so the copy must be finished before+  -- we return.+  set_body <-+    collect $+      copy+        CopyBarrier+        [C.cexp|arr->mem.mem|]+        index_exp+        space+        [C.cexp|(unsigned char*)&v|]+        [C.cexp|0|]+        DefaultSpace+        [C.cexp|$int:(primByteSize pt::Int)|]    ctx_ty <- contextType   ops <- asks envOperations@@ -170,6 +184,9 @@     [C.cedecl|int $id:index_array($ty:ctx_ty *ctx, $ty:pt' *out, $ty:array_type *arr,                                   $params:index_params);|]   proto+    [C.cedecl|int $id:set_array($ty:ctx_ty *ctx, $ty:array_type *arr, $ty:pt' v,+                                $params:index_params);|]+  proto     [C.cedecl|$ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr);|]   proto     [C.cedecl|const typename int64_t* $id:shape_array($ty:ctx_ty *ctx, $ty:array_type *arr);|]@@ -227,6 +244,18 @@             return err;           } +          int $id:set_array($ty:ctx_ty *ctx, $ty:array_type *arr, $ty:pt' v,+                            $params:index_params) {+            int err = 0;+            if ($exp:in_bounds) {+              $items:(criticalSection ops set_body)+            } else {+              err = 1;+              set_error(ctx, strdup("Index out of bounds."));+            }+            return err;+          }+           $ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr) {             (void)ctx;             return arr->mem.mem;@@ -246,28 +275,10 @@         Manifest.arrayNew = new_array,         Manifest.arrayNewRaw = new_raw_array,         Manifest.arrayValuesRaw = values_raw_array,-        Manifest.arrayIndex = index_array+        Manifest.arrayIndex = index_array,+        Manifest.arraySet = set_array       } -lookupOpaqueType :: Name -> OpaqueTypes -> OpaqueType-lookupOpaqueType v (OpaqueTypes types) =-  case lookup v types of-    Just (t, _) -> t-    Nothing -> error $ "Unknown opaque type: " ++ show v--opaquePayload :: OpaqueTypes -> OpaqueType -> [ValueType]-opaquePayload _ (OpaqueSum ts _) = ts-opaquePayload _ (OpaqueArray _ _ ts) = ts-opaquePayload _ (OpaqueRecord []) = [ValueType Signed (Rank 0) Unit]-opaquePayload types (OpaqueRecord fs) = concatMap f fs-  where-    f (_, TypeOpaque s) = opaquePayload types $ lookupOpaqueType s types-    f (_, TypeTransparent v) = [v]-opaquePayload types (OpaqueRecordArray _ _ fs) = concatMap f fs-  where-    f (_, TypeOpaque s) = opaquePayload types $ lookupOpaqueType s types-    f (_, TypeTransparent v) = [v]- entryPointTypeToCType :: Publicness -> EntryPointType -> CompilerM op s C.Type entryPointTypeToCType _ (TypeOpaque desc) = opaqueToCType desc entryPointTypeToCType pub (TypeTransparent vt) = valueTypeToCType pub vt@@ -864,7 +875,8 @@     constructFunction ops ctx_ty opaque_ty i fname payload = do       (params, new_stms) <- unzip <$> zipWithM constructPayload [0 ..] payload -      let used = concatMap snd payload+      -- The first field holds the variant, unless there is only one.+      let used = [0 | not unary] ++ concatMap snd payload       set_unused_stms <-         mapM setUnused $ filter ((`notElem` used) . fst) (zip [0 ..] vds) @@ -891,12 +903,11 @@                     return FUTHARK_SUCCESS;                   }|] -    -- We must initialise some of the fields that are unused in this-    -- variant; specifically the ones corresponding to arrays. This-    -- has the unfortunate effect that all arrays in the nonused-    -- constructor are set to have size 0.-    setUnused (_, ValueType _ (Rank 0) _) =-      pure [C.citem|{}|]+    -- We must initialise the fields that are unused in this variant, as they+    -- are still freed and serialised. Arrays in the unused constructors are+    -- set to have size 0, and scalars to zero.+    setUnused (i, ValueType _ (Rank 0) _) =+      pure [C.citem|v->$id:(tupleField i) = 0;|]     setUnused (i, ValueType signed (Rank rank) pt) = do       new_array <- publicName $ "new_" <> arrayName pt signed rank       let dims = replicate rank [C.cexp|0|]
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -368,6 +368,41 @@     vd (Imp.ArrayValue _ _ pt s dims) =       mconcat (replicate (length dims) "[]") <> readTypeEnum pt s +-- | Describe the opaque types for the server, which implements the commands for+-- inspecting and constructing values based on this.+opaqueTypesDef :: Imp.OpaqueTypes -> PyStmt+opaqueTypesDef types@(Imp.OpaqueTypes ts) =+  Assign (Var "opaque_types") $ Dict $ map onType ts+  where+    onType (name, (t, _)) =+      ( String $ nameToText name,+        Dict $ (String "payload", List $ map (String . valueTypeName) $ Imp.opaquePayload types t) : info t+      )++    info (Imp.OpaqueRecord fs) =+      [kind "record", fields fs]+    info (Imp.OpaqueSum _ vs) =+      [kind "sum", (String "variants", List $ map variant vs)]+    info (Imp.OpaqueArray rank et _) =+      [kind "array", arrayRank rank, elemType et]+    info (Imp.OpaqueRecordArray rank et fs) =+      [kind "array", arrayRank rank, elemType et, fields fs]++    kind k = (String "kind", String k)+    arrayRank rank = (String "rank", Integer $ toInteger rank)+    elemType et = (String "elemtype", String $ nameToText et)+    fields fs = (String "fields", List [Tuple [String $ nameToText f, String $ entryTypeName t] | (f, t) <- fs])+    variant (v, payload) =+      Tuple+        [ String $ nameToText v,+          List [Tuple [String $ entryTypeName t, List $ map (Integer . toInteger) is] | (t, is) <- payload]+        ]++    entryTypeName (Imp.TypeOpaque t) = nameToText t+    entryTypeName (Imp.TypeTransparent vt) = valueTypeName vt++    valueTypeName (Imp.ValueType s (Imp.Rank r) pt) = T.replicate r "[]" <> readTypeEnum pt s+ -- | The class generated by the code generator must have a -- constructor, although it can be vacuous. data Constructor = Constructor [String] [PyStmt]@@ -466,6 +501,7 @@                              (Var "entry_points")                              (strDict entry_point_info),                            opaques_def,+                           opaqueTypesDef opaques,                            Assign                              (Var "sizes")                              (Dict $ map paramAssign $ M.toList params)@@ -964,11 +1000,11 @@ entryTypes (Imp.EntryPoint _ res args _doc) =   (map descArg args, desc res)   where-    descArg ((_, u), d) = desc (u, d)-    desc (u, Imp.OpaqueValue d _) = prettyText u <> nameToText d-    desc (u, Imp.TransparentValue (Imp.ScalarValue pt s _)) = prettyText u <> readTypeEnum pt s-    desc (u, Imp.TransparentValue (Imp.ArrayValue _ _ pt s dims)) =-      prettyText u <> mconcat (replicate (length dims) "[]") <> readTypeEnum pt s+    descArg ((_, o), d) = desc (o, d)+    desc (o, Imp.OpaqueValue d _) = prettyText o <> nameToText d+    desc (o, Imp.TransparentValue (Imp.ScalarValue pt s _)) = prettyText o <> readTypeEnum pt s+    desc (o, Imp.TransparentValue (Imp.ArrayValue _ _ pt s dims)) =+      prettyText o <> mconcat (replicate (length dims) "[]") <> readTypeEnum pt s  callEntryFun ::   [PyStmt] ->@@ -1220,14 +1256,12 @@   CompilerM op s PyExp generateRead _ _ Unit _ =   pure (compilePrimValue UnitValue)-generateRead _ _ _ ScalarSpace {} =-  error "GenericPython.generateRead: ScalarSpace"-generateRead src iexp pt DefaultSpace = do-  let pt' = compilePrimType pt-  pure $ fromStorage pt $ simpleCall "indexArray" [src, iexp, Var pt'] generateRead src iexp pt (Space space) = do   reader <- asks envReadScalar   reader src iexp pt space+generateRead src iexp pt _ = do+  let pt' = compilePrimType pt+  pure $ fromStorage pt $ simpleCall "indexArray" [src, iexp, Var pt']  generateWrite ::   PyExp ->@@ -1237,12 +1271,10 @@   PyExp ->   CompilerM op s () generateWrite _ _ Unit _ _ = pure ()-generateWrite _ _ _ ScalarSpace {} _ = do-  error "GenericPython.generateWrite: ScalarSpace" generateWrite dst iexp pt (Imp.Space space) elemexp = do   writer <- asks envWriteScalar   writer dst iexp pt space elemexp-generateWrite dst iexp _ DefaultSpace elemexp =+generateWrite dst iexp _ _ elemexp =   stm $ Exp $ simpleCall "writeScalarArray" [dst, iexp, elemexp]  -- | Compile an 'Copy' using sequential nested loops, but
src/Futhark/CodeGen/Backends/GenericWASM.hs view
@@ -19,11 +19,13 @@ where  import Data.List (intercalate)+import Data.Map qualified as M import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.SimpleRep (isValidCName, opaqueName) import Futhark.CodeGen.ImpCode.Sequential qualified as Imp import Futhark.CodeGen.RTS.JavaScript+import Futhark.Manifest import Futhark.Util (nubOrd, showText, zEncodeText) import Language.Futhark.Core (nameToText) import Language.Futhark.Primitive@@ -118,16 +120,12 @@     primToJSString _ Bool = "bool"     primToJSString _ Unit = error "entryTypeToJSString: Unit" -emccExportNames :: [JSEntryPoint] -> [(String, JSOpaqueType)] -> [String]-emccExportNames jses opaqueTypes =-  map (\jse -> "'_futhark_entry_" ++ T.unpack (GC.escapeName (T.pack (name jse))) ++ "'") jses-    ++ map (\arg -> "'" ++ gfn "new" arg ++ "'") arrays-    ++ map (\arg -> "'" ++ gfn "free" arg ++ "'") arrays-    ++ map (\arg -> "'" ++ gfn "shape" arg ++ "'") arrays-    ++ map (\arg -> "'" ++ gfn "values_raw" arg ++ "'") arrays-    ++ map (\arg -> "'" ++ gfn "values" arg ++ "'") arrays-    ++ map (\arg -> "'" ++ "_futhark_free_" ++ arg ++ "'") opaques-    ++ map (\rf -> "'_futhark_" ++ jsrfProjectFn rf ++ "'") allRecordFields+-- | The names of the C functions that must be exported from the WebAssembly+-- module. This is every function named in the manifest, as the server calls+-- these directly, as well as the context management functions.+emccExportNames :: Manifest -> [String]+emccExportNames manifest =+  map (\f -> "'_" ++ T.unpack f ++ "'") (nubOrd $ manifestFunctions manifest)     ++ [ "_futhark_context_config_new",          "_futhark_context_config_free",          "_futhark_context_new",@@ -139,16 +137,47 @@          "_futhark_context_pause_profiling",          "_futhark_context_unpause_profiling"        ]++manifestFunctions :: Manifest -> [CFuncName]+manifestFunctions manifest =+  map entryPointCFun (M.elems $ manifestEntryPoints manifest)+    ++ concatMap typeFunctions (M.elems $ manifestTypes manifest)   where-    -- Include array types from both entry points and record fields.-    arrays = nubOrd $ filter isArray (entryPointTypes ++ recordFieldTypes)-    -- Include opaque types from both entry points and record fields.-    opaques = nubOrd $ filter isOpaque (entryPointTypes ++ recordFieldTypes)-    entryPointTypes = concatMap (\jse -> parameters jse ++ [ret jse]) jses-    recordFieldTypes = [jsrfType rf | (_, JSOpaqueRecord fields) <- opaqueTypes, rf <- fields]-    gfn typ str = "_futhark_" ++ typ ++ "_" ++ baseType str ++ "_" ++ show (dim str) ++ "d"-    allRecordFields = [rf | (_, JSOpaqueRecord fields) <- opaqueTypes, rf <- fields]+    typeFunctions (TypeArray _ _ _ ops) =+      [ arrayFree ops,+        arrayShape ops,+        arrayValues ops,+        arrayNew ops,+        arrayNewRaw ops,+        arrayValuesRaw ops,+        arrayIndex ops,+        arraySet ops+      ]+    typeFunctions (TypeOpaque _ ops extra_ops _) =+      [opaqueFree ops, opaqueStore ops, opaqueRestore ops]+        ++ maybe [] extraFunctions extra_ops +    extraFunctions (OpaqueRecord ops) =+      recordNew ops : map recordFieldProject (recordFields ops)+    extraFunctions (OpaqueSum ops) =+      sumVariant ops : concatMap variantFunctions (sumVariants ops)+    extraFunctions (OpaqueArray ops) =+      [ opaqueArrayIndex ops,+        opaqueArrayShape ops,+        opaqueArrayNew ops,+        opaqueArraySet ops+      ]+    extraFunctions (OpaqueRecordArray ops) =+      [ recordArrayZip ops,+        recordArrayIndex ops,+        recordArrayShape ops,+        recordArrayNew ops,+        recordArraySet ops+      ]+        ++ map recordFieldProject (recordArrayFields ops)++    variantFunctions v = [sumVariantConstruct v, sumVariantDestruct v]+ javascriptWrapper :: [JSEntryPoint] -> [(String, JSOpaqueType)] -> T.Text javascriptWrapper entryPoints opaqueTypes =   T.unlines@@ -592,14 +621,16 @@  -- | Javascript code that can be appended to the generated module to -- run a Futhark server instance on startup.-runServer :: T.Text-runServer =+runServer :: Manifest -> T.Text+runServer manifest =   [text|    Module.onRuntimeInitialized = () => {      var context = new FutharkContext(Module);-     var server = new Server(context);+     var server = new Server(context, ${manifest_json});      server.run();    }|]+  where+    manifest_json = manifestToJSON manifest  -- | The names exported by the generated module. libraryExports :: T.Text
src/Futhark/CodeGen/Backends/MulticoreC.hs view
@@ -94,13 +94,16 @@ closureRetvalStructField v =   nameFromString "retval_" <> nameFromText (prettyText v) -data ValueType = Prim PrimType | MemBlock | RawMem+-- | How a value is passed to a worker through the closure struct.+data ValueType = Prim PrimType | MemBlock | RawMem | ScalarMem  compileFreeStructFields :: [VName] -> [(C.Type, C.Type, ValueType)] -> [C.FieldGroup] compileFreeStructFields = zipWith field   where     field name (_, storage_ty, Prim _) =       [C.csdecl|$ty:storage_ty $id:(closureFreeStructField name);|]+    field name (ty, _, ScalarMem) =+      [C.csdecl|$ty:ty $id:(closureFreeStructField name);|]     field name (_, _, _) =       [C.csdecl|$ty:defaultMemBlockType $id:(closureFreeStructField name);|] @@ -109,6 +112,8 @@   where     field name (ty, _, Prim _) =       [C.csdecl|$ty:ty *$id:(closureRetvalStructField name);|]+    field name (ty, _, ScalarMem) =+      [C.csdecl|$ty:ty $id:(closureRetvalStructField name);|]     field name (_, _, _) =       [C.csdecl|$ty:defaultMemBlockType $id:(closureRetvalStructField name);|] @@ -126,6 +131,8 @@       [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name.mem;|]     field name (_, _, RawMem) =       [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name;|]+    field name (_, _, ScalarMem) =+      [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name;|]  compileSetRetvalStructValues ::   (C.ToIdent a) =>@@ -144,6 +151,8 @@       [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name.mem;|]     field name (_, _, RawMem) =       [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name;|]+    field name (_, _, ScalarMem) =+      [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name;|]  compileGetRetvalStructVals :: (C.ToIdent a) => a -> [VName] -> [(C.Type, C.Type, ValueType)] -> [C.InitGroup] compileGetRetvalStructVals struct = zipWith field@@ -151,6 +160,8 @@     field name (ty, _storage_ty, Prim _) =       let inner = [C.cexp|*$id:struct->$id:(closureRetvalStructField name)|]        in [C.cdecl|$ty:ty $id:name = $exp:inner;|]+    field name (ty, _, ScalarMem) =+      [C.cdecl|$ty:ty $id:name = $id:struct->$id:(closureRetvalStructField name);|]     field name (ty, _, _) =       [C.cdecl|$ty:ty $id:name =                  {.desc = $string:(prettyString name),@@ -168,6 +179,8 @@     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, _, ScalarMem) =+      [C.cdecl|$ty:ty $id:name = $id:struct->$id:(closureFreeStructField name);|]     field name (ty, _, _) =       [C.cdecl|$ty:ty $id:name =                  {.desc = $string:(prettyString name),@@ -179,6 +192,8 @@   where     field name (_, _, Prim _) =       [C.cstm|*$id:struct->$id:(closureRetvalStructField name) = $exp:(C.toExp name noLoc);|]+    field name (_, _, ScalarMem) =+      [C.cstm|$id:struct->$id:(closureRetvalStructField name) = $id:name;|]     field name (_, _, _) =       [C.cstm|$id:struct->$id:(closureRetvalStructField name) = $id:name.mem;|] @@ -190,6 +205,8 @@   pure (ct, ct, vt)  mcMemToCType :: VName -> Space -> GC.CompilerM op s (C.Type, ValueType)+mcMemToCType _ (ScalarSpace _ pt) =+  pure ([C.cty|$ty:(GC.primTypeToCType pt)*|], ScalarMem) mcMemToCType v space = do   refcount <- GC.fatMemory space   cached <- isJust <$> GC.cacheMem v@@ -426,8 +443,8 @@                }|]    mapM_ GC.item code'-compileOp (Atomic aop) =-  atomicOps aop (\ty _ -> pure [C.cty|$ty:ty*|])+compileOp (Atomic space aop) =+  atomicOps space aop (\ty _ -> pure [C.cty|$ty:ty*|]) compileOp (ISPCKernel body _) =   scopedBlock body compileOp (ForEach i from bound body) = do@@ -456,27 +473,28 @@  doAtomic ::   (C.ToIdent a1) =>+  Space ->   a1 ->   VName ->-  Count u (TExp Int32) ->+  Count m (TExp Int32) ->   Exp ->   String ->   C.Type ->   (C.Type -> VName -> GC.CompilerM op s C.Type) ->   GC.CompilerM op s ()-doAtomic old arr ind val op ty castf = do+doAtomic space old arr ind val op ty castf = do   ind' <- GC.compileExp $ untyped $ unCount ind   val' <- GC.compileExp val   cast <- castf ty arr-  arr' <- GC.rawMem arr+  arr' <- GC.rawMem arr space   GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'], ($ty:ty) $exp:val', __ATOMIC_RELAXED);|] -atomicOps :: AtomicOp -> (C.Type -> VName -> GC.CompilerM op s C.Type) -> GC.CompilerM op s ()-atomicOps (AtomicCmpXchg t old arr ind res val) castf = do+atomicOps :: Space -> AtomicOp -> (C.Type -> VName -> GC.CompilerM op s C.Type) -> GC.CompilerM op s ()+atomicOps space (AtomicCmpXchg t old arr ind res val) castf = do   ind' <- GC.compileExp $ untyped $ unCount ind   new_val' <- GC.compileExp val   cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr-  arr' <- GC.rawMem arr+  arr' <- GC.rawMem arr space   GC.stm     [C.cstm|$id:res = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'],                  &$id:old,@@ -485,36 +503,39 @@   where     op :: String     op = "__atomic_compare_exchange_n"-atomicOps (AtomicXchg t old arr ind val) castf = do+atomicOps space (AtomicXchg t old arr ind val) castf = do   ind' <- GC.compileExp $ untyped $ unCount ind   val' <- GC.compileExp val   cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr-  GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast)$id:arr.mem)[$exp:ind'], $exp:val', __ATOMIC_SEQ_CST);|]+  arr' <- GC.rawMem arr space+  GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'], $exp:val', __ATOMIC_SEQ_CST);|]   where     op :: String     op = "__atomic_exchange_n"-atomicOps (AtomicLoad t ret arr ind) castf = do+atomicOps space (AtomicLoad t ret arr ind) castf = do   ind' <- GC.compileExp $ untyped $ unCount ind   cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr-  GC.stm [C.cstm|$id:ret = $id:op(&(($ty:cast)$id:arr.mem)[$exp:ind'], __ATOMIC_ACQUIRE);|]+  arr' <- GC.rawMem arr space+  GC.stm [C.cstm|$id:ret = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'], __ATOMIC_ACQUIRE);|]   where     op :: String     op = "__atomic_load_n"-atomicOps (AtomicStore t arr ind val) castf = do+atomicOps space (AtomicStore t arr ind val) castf = do   ind' <- GC.compileExp $ untyped $ unCount ind   val' <- GC.compileExp val   cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr-  GC.stm [C.cstm|$id:op(&(($ty:cast)$id:arr.mem)[$exp:ind'], $exp:val', __ATOMIC_RELEASE);|]+  arr' <- GC.rawMem arr space+  GC.stm [C.cstm|$id:op(&(($ty:cast)$exp:arr')[$exp:ind'], $exp:val', __ATOMIC_RELEASE);|]   where     op :: String     op = "__atomic_store_n"-atomicOps (AtomicAdd t old arr ind val) castf =-  doAtomic old arr ind val "__atomic_fetch_add" [C.cty|$ty:(GC.intTypeToCType t)|] castf-atomicOps (AtomicSub t old arr ind val) castf =-  doAtomic old arr ind val "__atomic_fetch_sub" [C.cty|$ty:(GC.intTypeToCType t)|] castf-atomicOps (AtomicAnd t old arr ind val) castf =-  doAtomic old arr ind val "__atomic_fetch_and" [C.cty|$ty:(GC.intTypeToCType t)|] castf-atomicOps (AtomicOr t old arr ind val) castf =-  doAtomic old arr ind val "__atomic_fetch_or" [C.cty|$ty:(GC.intTypeToCType t)|] castf-atomicOps (AtomicXor t old arr ind val) castf =-  doAtomic old arr ind val "__atomic_fetch_xor" [C.cty|$ty:(GC.intTypeToCType t)|] castf+atomicOps space (AtomicAdd t old arr ind val) castf =+  doAtomic space old arr ind val "__atomic_fetch_add" [C.cty|$ty:(GC.intTypeToCType t)|] castf+atomicOps space (AtomicSub t old arr ind val) castf =+  doAtomic space old arr ind val "__atomic_fetch_sub" [C.cty|$ty:(GC.intTypeToCType t)|] castf+atomicOps space (AtomicAnd t old arr ind val) castf =+  doAtomic space old arr ind val "__atomic_fetch_and" [C.cty|$ty:(GC.intTypeToCType t)|] castf+atomicOps space (AtomicOr t old arr ind val) castf =+  doAtomic space old arr ind val "__atomic_fetch_or" [C.cty|$ty:(GC.intTypeToCType t)|] castf+atomicOps space (AtomicXor t old arr ind val) castf =+  doAtomic space old arr ind val "__atomic_fetch_xor" [C.cty|$ty:(GC.intTypeToCType t)|] castf
src/Futhark/CodeGen/Backends/MulticoreISPC.hs view
@@ -58,6 +58,14 @@ varying :: C.TypeQual varying = C.EscTypeQual "varying" noLoc +-- | Qualify a pointer type so that the pointer itself is uniform, not just+-- what it points at: @uniform T *@ is a varying pointer in ISPC, @uniform T *+-- uniform@ is not.+uniformly :: C.Type -> C.Type+uniformly (C.Type ds (C.Ptr quals d dl) l) =+  C.Type ds (C.Ptr (uniform : quals) d dl) l+uniformly t = t+ -- | Compile the program to C and ISPC code using multicore operations. compileProg ::   (MonadFreshNames m) => T.Text -> Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text))@@ -160,6 +168,15 @@  -- | Set memory in ISPC setMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> ISPCCompilerM ()+-- A 'ScalarSpace' block is an array, not a reference-counted pointer, so+-- assigning one to another is an element-wise copy.+setMem dest src (ScalarSpace ds _) = do+  i <- C.toIdent <$> newVName "i"+  let bound = cproduct $ map (`C.toExp` noLoc) ds+  GC.stm+    [C.cstm|for ($tyqual:uniform typename int32_t $id:i = 0; $id:i < $exp:bound; $id:i++) {+              $exp:dest[$id:i] = $exp:src[$id:i];+            }|] setMem dest src space = do   let src_s = T.unpack $ expText $ C.toExp src noLoc   strlit <- makeStringLiteral src_s@@ -171,6 +188,8 @@  -- | Unref memory in ISPC unRefMem :: (C.ToExp a) => a -> Space -> ISPCCompilerM ()+-- A 'ScalarSpace' block is not reference counted; there is nothing to free.+unRefMem _ ScalarSpace {} = pure () unRefMem mem space = do   cached <- isJust <$> GC.cacheMem mem   let mem_s = T.unpack $ expText $ C.toExp mem noLoc@@ -298,8 +317,8 @@     compileOutputsUniform (MemParam name space) = do       ty <- GC.memToCType name space       p_name <- newVName $ baseName name <> "_p"-      let params = [C.cparam|$tyqual:uniform $ty:ty $id:p_name|]-          args = [C.cexp|&$id:p_name|]+      let params = [C.cparam|$tyqual:uniform $ty:ty *$tyqual:uniform $id:p_name|]+          args = [C.cexp|$id:p_name|]       pure (params, args)      compileInputsVarying (ScalarParam name bt) = do@@ -333,13 +352,15 @@       pure (params, args, pre_body, post_body)     compileOutputsVarying (MemParam name space) = do       typ <- GC.memToCType name space+      p_name <- newVName $ baseName name <> "_p"       newvn <- newVName $ "aos_" <> baseName name-      let params = [C.cparam|$ty:typ $id:name|]+      let params = [C.cparam|$tyqual:varying $ty:typ * $tyqual:uniform $id:p_name|]           args = [C.cexp|&$id:(newvn)[i]|]           pre_body =             [C.citems|$tyqual:uniform $ty:typ $id:(newvn)[programCount];-                       $id:(newvn)[programIndex] = $id:name;|]-      pure (params, args, pre_body, [])+                       $id:(newvn)[programIndex] = *$id:p_name;|]+          post_body = [C.citems|*$id:p_name = $id:(newvn)[programIndex];|]+      pure (params, args, pre_body, post_body)  -- | Handle logging an error message in ISPC. handleError :: ErrorMsg Exp -> String -> ISPCCompilerM ()@@ -387,6 +408,39 @@      mapArgNames (ErrorMsg parts) = mapArgNames' parts +-- | Is this a space whose memory blocks we can address directly from ISPC+-- code, and for which 'readHostMem'/'writeHostMem' know the layout?+isHostSpace :: Space -> Bool+isHostSpace DefaultSpace = True+isHostSpace ScalarSpace {} = True+isHostSpace Space {} = False++-- | Read an element of a memory block. A 'ScalarSpace' block is an array of+-- the element type, while a 'DefaultSpace' block is a byte pointer whose+-- variability depends on whether the block is lexical; see 'getMemType'.+readHostMem :: PrimType -> VName -> Space -> C.Exp -> ISPCCompilerM C.Exp+readHostMem t mem space i = do+  mem' <- GC.rawMem mem space+  case space of+    ScalarSpace {} -> pure [C.cexp|$exp:mem'[$exp:i]|]+    _ -> fromStorage t . GC.derefPointer mem' i <$> getMemType mem t++-- | Write an element of a memory block; the counterpart of 'readHostMem'. The+-- index is forced to be varying, as ISPC will otherwise complain about writing+-- a varying value through a uniform index.+writeHostMem :: PrimType -> VName -> Space -> C.Exp -> C.Exp -> ISPCCompilerM ()+writeHostMem t mem space i v = do+  mem' <- GC.rawMem mem space+  case space of+    ScalarSpace {} -> GC.stm [C.cstm|$exp:mem'[$exp:i] = $exp:v;|]+    _ -> do+      deref <-+        GC.derefPointer+          mem'+          [C.cexp|($tyquals:([varying]) typename int64_t)$exp:i|]+          <$> getMemType mem t+      GC.stm [C.cstm|$exp:deref = $exp:(toStorage t v);|]+ -- | Given the name and type of a parameter, return the C type used to -- represent it. We use uniform pointers to varying values for lexical -- memory blocks, as this generally results in less gathers/scatters.@@ -510,6 +564,21 @@           go code     go (x : xs) = compileCode x >> go xs     go [] = pure ()+compileCode (DeclareMem name (ScalarSpace ds t)) = do+  -- A 'ScalarSpace' block is an array, and an ISPC varying array has no+  -- address, so it cannot not be passed to a task. Give each program instance a+  -- row of an array-of-structs and name that row with a varying pointer, which+  -- is addressable and which every other use of the block can treat exactly+  -- like the array it replaces.+  storage <- newVName "scalar_storage"+  let ct = GC.primTypeToCType t+      n = cproduct $ map (`C.toExp` noLoc) ds+  GC.decl [C.cdecl|$tyqual:uniform $ty:ct $id:storage[programCount][$exp:n];|]+  GC.decl [C.cdecl|$tyqual:uniform $ty:ct * $tyqual:varying $id:name = &$id:storage[programIndex][0];|]+compileCode (Allocate _ _ ScalarSpace {}) =+  -- Handled by the declaration of the memory block, which is translated to+  -- an actual array.+  pure () compileCode (Allocate name (Count (TPrimExp e)) space) = do   size <- compileExp e   cached <- GC.cacheMem name@@ -528,7 +597,7 @@   setMem dest src space compileCode (Write dest (Count idx) elemtype DefaultSpace _ elemexp)   | isConstExp (untyped idx) = do-      dest' <- GC.rawMem dest+      dest' <- GC.rawMem dest DefaultSpace       idxexp <- compileExp $ constFoldPrimExp $ untyped idx       deref <-         GC.derefPointer@@ -538,7 +607,7 @@       elemexp' <- toStorage elemtype <$> compileExp elemexp       GC.stm [C.cstm|$exp:deref = $exp:elemexp';|]   | otherwise = do-      dest' <- GC.rawMem dest+      dest' <- GC.rawMem dest DefaultSpace       idxexp <- compileExp $ untyped idx       deref <-         GC.derefPointer@@ -552,26 +621,23 @@     isSimple (ValueExp _) = True     isSimple _ = False compileCode (Read x src (Count iexp) restype DefaultSpace _) = do-  src' <- GC.rawMem src+  src' <- GC.rawMem src DefaultSpace   e <-     fmap (fromStorage restype) $       GC.derefPointer src'         <$> compileExp (untyped iexp)         <*> getMemType src restype   GC.stm [C.cstm|$id:x = $exp:e;|]-compileCode (Copy t shape (dst, DefaultSpace) dst_lmad (src, DefaultSpace) src_lmad) = do-  dst' <- GC.rawMem dst-  src' <- GC.rawMem src-  let doWrite dst_i ve = do-        deref <--          GC.derefPointer-            dst'-            [C.cexp|($tyquals:([varying]) typename int64_t)$exp:dst_i|]-            <$> getMemType dst t-        GC.stm [C.cstm|$exp:deref = $exp:(toStorage t ve);|]-      doRead src_i =-        fromStorage t . GC.derefPointer src' src_i <$> getMemType src t-  GC.compileCopyWith shape doWrite dst_lmad doRead src_lmad+compileCode (Copy t shape (dst, dstspace) dst_lmad (src, srcspace) src_lmad)+  | t /= Unit,+    isHostSpace dstspace,+    isHostSpace srcspace =+      GC.compileCopyWith+        shape+        (writeHostMem t dst dstspace)+        dst_lmad+        (readHostMem t src srcspace)+        src_lmad compileCode (Free name space) = do   cached <- isJust <$> GC.cacheMem name   unless cached $ unRefMem name space@@ -707,6 +773,12 @@     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 (ty, _, MC.ScalarMem) =+      -- The block belongs to this task alone, so the pointer is uniform.+      -- Note the second 'uniform': without it the pointer itself is varying.+      pure+        [C.citems|$ty:(uniformly ty) $id:name =+                    $id:struct'->$id:(MC.closureFreeStructField name);|]     field name (_, _, _) = do       strlit <- makeStringLiteral $ prettyString name       pure@@ -933,8 +1005,8 @@   tar' <- compileExp tar   lane' <- compileExp lane   GC.stm [C.cstm|$id:dest = extract($exp:tar', $exp:lane');|]-compileOp (Atomic aop) =-  MC.atomicOps aop $ \ty arr -> do+compileOp (Atomic space aop) =+  MC.atomicOps space aop $ \ty arr -> do     cached <- isJust <$> GC.cacheMem arr     if cached       then pure [C.cty|$tyqual:varying $ty:ty* $tyqual:uniform|]@@ -1031,7 +1103,7 @@   addDeps name $ freeIn e findDeps (Call tars _ args) =   mapM_ (\x -> addDeps x $ freeIn args) tars-findDeps (Read x arr (Count iexp) _ DefaultSpace _) = do+findDeps (Read x arr (Count iexp) _ _ _) = do   addDeps x $ freeIn (untyped iexp)   addDeps x $ oneName arr findDeps (Op (GetLoopBounds x y)) = do@@ -1039,7 +1111,7 @@   addDeps y mempty findDeps (Op (ExtractLane x _ _)) = do   addDeps x mempty-findDeps (Op (Atomic (AtomicCmpXchg _ old arr ind res val))) = do+findDeps (Op (Atomic _ (AtomicCmpXchg _ old arr ind res val))) = do   addDeps res $ freeIn arr <> freeIn ind <> freeIn val   addDeps old $ freeIn arr <> freeIn ind <> freeIn val findDeps _ = pure ()
src/Futhark/CodeGen/Backends/MulticoreWASM.hs view
@@ -59,7 +59,7 @@     ( ws,       ( prog'',         javascriptWrapper (fRepMyRep prog') (opaqueToJS (Imp.defTypes prog')),-        "_futhark_context_config_set_num_threads" : emccExportNames (fRepMyRep prog') (opaqueToJS (Imp.defTypes prog'))+        "_futhark_context_config_set_num_threads" : emccExportNames (GC.cManifest prog'')       )     )
src/Futhark/CodeGen/Backends/SequentialWASM.hs view
@@ -49,7 +49,7 @@       (DefaultSpace, [DefaultSpace])       []       prog'-  pure (ws, (prog'', javascriptWrapper (fRepMyRep prog') (opaqueToJS (Imp.defTypes prog')), emccExportNames (fRepMyRep prog') (opaqueToJS (Imp.defTypes prog'))))+  pure (ws, (prog'', javascriptWrapper (fRepMyRep prog') (opaqueToJS (Imp.defTypes prog')), emccExportNames (GC.cManifest prog'')))   where     operations :: GC.Operations Imp.Sequential ()     operations =
src/Futhark/CodeGen/ImpCode.hs view
@@ -114,6 +114,7 @@ import Futhark.IR.Prop.Names import Futhark.IR.Syntax.Core   ( Attrs (..),+    Diet (..),     EntryPointType (..),     ErrorMsg (..),     ErrorMsgPart (..),@@ -127,6 +128,8 @@     SubExp (..),     ValueType (..),     errorMsgArgTypes,+    lookupOpaqueType,+    opaquePayload,   ) import Futhark.Util (nubByOrd) import Futhark.Util.Pretty hiding (space)@@ -202,10 +205,9 @@     ScalarValue PrimType Signedness VName   deriving (Eq, Show) --- | ^ An externally visible value.  This can be an opaque value+-- | An externally visible value.  This can be an opaque value -- (covering several physical internal values), or a single value that--- can be used externally.  We record the uniqueness because it is--- important to the external interface as well.+-- can be used externally. data ExternalValue   = -- | The string is a human-readable description with no other     -- semantics.@@ -214,10 +216,12 @@   deriving (Show)  -- | Information about how this function can be called from the outside world.+-- We record the consumption/freshness because it is important to the external+-- interface as well. data EntryPoint = EntryPoint   { entryPointName :: Name,-    entryPointResults :: (Uniqueness, ExternalValue),-    entryPointArgs :: [((Name, Uniqueness), ExternalValue)],+    entryPointResults :: (Diet, ExternalValue),+    entryPointArgs :: [((Name, Diet), ExternalValue)],     entryPointDocs :: Maybe T.Text   }   deriving (Show)@@ -523,8 +527,8 @@         "results" <+> nestedBlock (ppRes result)       ]     where-      ppArg ((p, u), t) = pretty p <+> ":" <+> ppRes (u, t)-      ppRes (u, t) = pretty u <> pretty t+      ppArg ((p, o), t) = pretty p <+> ":" <+> ppRes (o, t)+      ppRes (o, t) = pretty o <> pretty t  instance (Pretty op) => Pretty (FunctionT op) where   pretty (Function entry outs ins attrs body) =
src/Futhark/CodeGen/ImpCode/Multicore.hs view
@@ -46,7 +46,8 @@   | -- | If the context is currently in an error state (e.g. because some other     -- task has died), put @True@ in the given variable, otherwise @False@.     GetError VName-  | Atomic AtomicOp+  | -- | An atomic operation on a memory block in the given space.+    Atomic Space AtomicOp  -- | Multicore code. type MCCode = Code Multicore@@ -135,7 +136,7 @@           [ "params" <+> nestedBlock (pretty params),             "body" <+> nestedBlock (pretty body)           ]-  pretty (Atomic _) =+  pretty (Atomic _ _) =     "AtomicOp"   pretty (ISPCKernel body _) =     "ispc" <+> nestedBlock (pretty body)@@ -173,7 +174,7 @@     freeIn' par_code <> freeIn' seq_code <> freeIn' info   freeIn' (ParLoop _ body _) =     freeIn' body-  freeIn' (Atomic aop) =+  freeIn' (Atomic _ aop) =     freeIn' aop   freeIn' (ISPCKernel body _) =     freeIn' body@@ -225,7 +226,9 @@     declared x = go declared x      set (SetMem x y _) = namesFromList [x, y]-    set (Call _ _ args) = foldMap onArg args+    set (Call dests _ args) =+      -- Some of the dests might not be memory, but it does not matter.+      namesFromList dests <> foldMap onArg args       where         onArg ExpArg {} = mempty         onArg (MemArg x) = oneName x
src/Futhark/CodeGen/ImpGen.hs view
@@ -333,11 +333,11 @@         Array           (entryArrayElemType arrayEntry)           (Shape $ entryArrayShape arrayEntry)-          NoUniqueness+          NoMode       entryType (ScalarVar _ scalarEntry) =         Prim $ entryScalarType scalarEntry       entryType (AccVar _ (acc, ispace, ts)) =-        Acc acc ispace ts NoUniqueness+        Acc acc ispace ts  runImpM ::   ImpM rep r op a ->@@ -498,12 +498,6 @@   compileStms used_consts stms $ pure ()   pure (used_consts, ()) -lookupOpaqueType :: Name -> OpaqueTypes -> OpaqueType-lookupOpaqueType v (OpaqueTypes types) =-  case lookup v types of-    Just (t, _) -> t-    Nothing -> error $ "Unknown opaque type: " ++ show v- valueTypeSign :: ValueType -> Signedness valueTypeSign (ValueType sign _ _) = sign @@ -554,7 +548,7 @@   OpaqueTypes ->   [FParam rep] ->   Maybe [EntryParam] ->-  ImpM rep r op ([Imp.Param], [ArrayDecl], Maybe [((Name, Uniqueness), Imp.ExternalValue)])+  ImpM rep r op ([Imp.Param], [ArrayDecl], Maybe [((Name, Diet), Imp.ExternalValue)]) compileInParams types params eparams = do   (inparams, arrayds) <- partitionEithers <$> mapM compileInParam params   let findArray x = find (isArrayDecl x) arrayds@@ -580,18 +574,18 @@           _ ->             Nothing -      mkExts (EntryParam v u et@(TypeOpaque desc) : epts) fparams =+      mkExts (EntryParam v o et@(TypeOpaque desc) : epts) fparams =         let signs = entryPointSignedness types et             n = entryPointSize types et             (fparams', rest) = splitAt n fparams-         in ( (v, u),+         in ( (v, o),               Imp.OpaqueValue                 desc                 (catMaybes $ zipWith mkValueDesc fparams' signs)             )               : mkExts epts rest-      mkExts (EntryParam v u (TypeTransparent (ValueType s _ _)) : epts) (fparam : fparams) =-        maybeToList (((v, u),) . Imp.TransparentValue <$> mkValueDesc fparam s)+      mkExts (EntryParam v o (TypeTransparent (ValueType s _ _)) : epts) (fparam : fparams) =+        maybeToList (((v, o),) . Imp.TransparentValue <$> mkValueDesc fparam s)           ++ mkExts epts fparams       mkExts _ _ = [] @@ -627,7 +621,7 @@   [RetType rep] ->   EntryResult ->   [Maybe Imp.Param] ->-  ImpM rep r op (Uniqueness, Imp.ExternalValue)+  ImpM rep r op (Diet, Imp.ExternalValue) compileExternalValues types orig_rts orig_epts maybe_params = do   let (ctx_rts, val_rts) =         splitAt@@ -661,13 +655,13 @@       num_ctx = length ctx_rts    case (orig_epts, val_rts) of-    (EntryResult u et@(TypeOpaque desc), rets) -> do+    (EntryResult o et@(TypeOpaque desc), rets) -> do       let signs = entryPointSignedness types et       vds <- forM (zip3 [num_ctx ..] signs rets) $ \(j, s, r) -> mkValueDesc j s r-      pure (u, Imp.OpaqueValue desc vds)-    (EntryResult u (TypeTransparent (ValueType s _ _)), [ret]) -> do+      pure (o, Imp.OpaqueValue desc vds)+    (EntryResult o (TypeTransparent (ValueType s _ _)), [ret]) -> do       vd <- mkValueDesc num_ctx s ret-      pure (u, Imp.TransparentValue vd)+      pure (o, Imp.TransparentValue vd)     _ -> error "compileExternalValues: invalid inputs."  compileOutParams ::@@ -675,7 +669,7 @@   OpaqueTypes ->   [RetType rep] ->   Maybe EntryResult ->-  ImpM rep r op (Maybe (Uniqueness, Imp.ExternalValue), [Imp.Param], [ValueDestination])+  ImpM rep r op (Maybe (Diet, Imp.ExternalValue), [Imp.Param], [ValueDestination]) compileOutParams types orig_rts maybe_orig_epts = do   (maybe_params, dests) <- mapAndUnzipM compileOutParam orig_rts   evs <- case maybe_orig_epts of@@ -1076,7 +1070,7 @@     addFParam fparam =       addVar (paramName fparam) $         memBoundToVarEntry Nothing $-          noUniquenessReturns $+          noModeReturns $             paramDec fparam  -- | Another hack.@@ -1160,13 +1154,13 @@  memBoundToVarEntry ::   Maybe (Exp rep) ->-  MemBound NoUniqueness ->+  MemBound NoMode ->   VarEntry rep memBoundToVarEntry e (MemPrim bt) =   ScalarVar e ScalarEntry {entryScalarType = bt} memBoundToVarEntry e (MemMem space) =   MemVar e $ MemEntry space-memBoundToVarEntry e (MemAcc acc ispace ts _) =+memBoundToVarEntry e (MemAcc acc ispace ts) =   AccVar e (acc, ispace, ts) memBoundToVarEntry e (MemArray bt shape _ (ArrayIn mem lmad)) =   let location = MemLoc mem (shapeDims shape) lmad@@ -1180,9 +1174,9 @@ infoDec ::   (Mem rep inner) =>   NameInfo rep ->-  MemInfo SubExp NoUniqueness MemBind+  MemInfo SubExp NoMode MemBind infoDec (LetName dec) = letDecMem dec-infoDec (FParamName dec) = noUniquenessReturns dec+infoDec (FParamName dec) = noModeReturns dec infoDec (LParamName dec) = dec infoDec (IndexName it) = MemPrim $ IntType it @@ -1890,7 +1884,7 @@ sAllocArrayPerm :: Name -> PrimType -> ShapeBase SubExp -> Space -> [Int] -> ImpM rep r op VName sAllocArrayPerm name pt shape space perm = do   let permuted_dims = rearrangeShape perm $ shapeDims shape-  mem <- sAlloc (name <> "_mem") (typeSize (Array pt shape NoUniqueness)) space+  mem <- sAlloc (name <> "_mem") (typeSize (Array pt shape NoMode)) space   let iota_lmad = LMAD.iota 0 $ map (isInt64 . primExpFromSubExp int64) permuted_dims   sArray name pt shape mem $     LMAD.permute iota_lmad $
src/Futhark/CodeGen/ImpGen/GPU.hs view
@@ -27,7 +27,7 @@ import Futhark.Error import Futhark.IR.GPUMem import Futhark.MonadFreshNames-import Futhark.Util.IntegralExp (divUp, nextMul)+import Futhark.Util.IntegralExp (ceilDiv, nextMul) import Prelude hiding (quot, rem)  callKernelOperations :: Operations GPUMem HostEnv Imp.HostOp@@ -144,7 +144,7 @@   -- The calculations are done with 64-bit integers to avoid overflow   -- issues.   let num_tblocks_maybe_zero =-        sMin64 (pe64 w64 `divUp` pe64 tblock_size) $+        sMin64 (pe64 w64 `ceilDiv` pe64 tblock_size) $           sExt64 (tvExp max_num_tblocks)   -- We also don't want zero blocks.   let num_tblocks = sMax64 1 num_tblocks_maybe_zero@@ -249,16 +249,25 @@  expCompiler :: ExpCompiler GPUMem HostEnv Imp.HostOp -- We generate a simple kernel for iota and replicate.-expCompiler (Pat [pe]) (BasicOp (Iota n x s et)) = do-  x' <- toExp x-  s' <- toExp s-  sIota (patElemName pe) (pe64 n) x' s' et-expCompiler (Pat [pe]) (BasicOp (Replicate shape se))+expCompiler dest@(Pat [pe]) e@(BasicOp (Iota n x s et)) = do+  space <- lookupArraySpace $ patElemName pe+  -- Might still have non-GPU iotas.+  if space == Space "device"+    then do+      x' <- toExp x+      s' <- toExp s+      sIota (patElemName pe) (pe64 n) x' s' et+    else defCompileExp dest e+expCompiler dest@(Pat [pe]) e@(BasicOp (Replicate shape se))   | Acc {} <- patElemType pe = pure ()-  | otherwise =-      if shapeRank shape == 0-        then copyDWIM (patElemName pe) [] se []-        else sReplicate (patElemName pe) se+  | shapeRank shape == 0 =+      copyDWIM (patElemName pe) [] se []+  | otherwise = do+      space <- lookupArraySpace $ patElemName pe+      -- Might still have non-GPU replicates.+      if space == Space "device"+        then sReplicate (patElemName pe) se+        else defCompileExp dest e -- Allocation in the "shared" space is just a placeholder. expCompiler _ (Op (Alloc _ (Space "shared"))) =   pure ()
src/Futhark/CodeGen/ImpGen/GPU/Base.hs view
@@ -61,7 +61,7 @@ import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.Transform.Rename import Futhark.Util (dropLast, nubOrd, splitFromEnd)-import Futhark.Util.IntegralExp (divUp, quot, rem)+import Futhark.Util.IntegralExp (ceilDiv, quot, rem) import Prelude hiding (quot, rem)  -- | Which target are we ultimately generating code for?  While most@@ -219,7 +219,7 @@     if n == num_threads       then f tid       else do-        num_chunks <- dPrimVE "num_chunks" $ n `divUp` num_threads+        num_chunks <- dPrimVE "num_chunks" $ n `ceilDiv` num_threads         sFor "chunk_i" num_chunks $ \chunk_i -> do           i <- dPrimVE "i" $ chunk_i * num_threads + tid           sWhen (i .<. n) $ f i@@ -828,10 +828,24 @@             zipWithM_ (writeArray bucket) arrs $               map (Var . paramName) acc_params +  -- Entering and leaving the critical section is done with an atomic+  -- compare-and-exchange, but that orders only the lock word itself.+  -- The writes are ordered by the fence that 'writeAtomic' emits, but+  -- the reads need one here: without it the memory model permits them+  -- to be served from a stale cache, so the value we combine with is+  -- the one from before the previous lock holder ran, and that+  -- holder's update is lost.+  let acquire_fence =+        sOp . Imp.MemFence $+          case space of+            Space "shared" -> Imp.FenceLocal+            _ -> Imp.FenceGlobal+   -- While-loop: Try to insert your value   sWhile (tvExp continue) $ do     try_acquire_lock     sWhen lock_acquired $ do+      acquire_fence       dLParams acc_params       bind_acc_params       op_body@@ -1026,7 +1040,7 @@   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+  virt_num_tblocks <- dPrimVE "virt_num_tblocks" $ kernel_size `ceilDiv` tvExp tblock_size   num_tblocks <- dPrimV "num_tblocks" $ virt_num_tblocks `sMin64` max_num_tblocks   pure (sExt32 virt_num_tblocks, Count $ tvSize num_tblocks, Count $ tvSize tblock_size) @@ -1103,7 +1117,7 @@   sOp $ Imp.GetBlockId (tvVar phys_tblock_id) 0   iterations <-     dPrimVE "iterations" $-      (required_blocks - tvExp phys_tblock_id) `divUp` sExt32 (kernelNumBlocks constants)+      (required_blocks - tvExp phys_tblock_id) `ceilDiv` sExt32 (kernelNumBlocks constants)    sFor "i" iterations $ \i -> do     m . tvExp
src/Futhark/CodeGen/ImpGen/GPU/Block.hs view
@@ -29,7 +29,7 @@ import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.Transform.Rename import Futhark.Util (chunks, mapAccumLM, takeLast)-import Futhark.Util.IntegralExp (divUp, rem)+import Futhark.Util.IntegralExp (ceilDiv, rem) import Prelude hiding (quot, rem)  -- | @flattenArray k flat arr@ flattens the outer @k@ dimensions of@@ -105,7 +105,7 @@ blockChunkLoop w m = do   constants <- kernelConstants <$> askEnv   let max_chunk_size = sExt32 $ kernelBlockSize constants-  num_chunks <- dPrimVE "num_chunks" $ w `divUp` max_chunk_size+  num_chunks <- dPrimVE "num_chunks" $ w `ceilDiv` max_chunk_size   sFor "chunk_i" num_chunks $ \chunk_i -> do     chunk_start <-       dPrimVE "chunk_start" $ chunk_i * max_chunk_size@@ -223,7 +223,7 @@           let num_locks = pe64 $ unCount tblock_size               dims = map pe64 $ shapeDims (segments <> histOpShape op <> histShape op)               l' = Locking locks 0 1 0 (pure . (`rem` num_locks) . flattenIndex dims)-              locks_t = Array int32 (Shape [unCount tblock_size]) NoUniqueness+              locks_t = Array int32 (Shape [unCount tblock_size]) NoMode            locks_mem <- sAlloc "locks_mem" (typeSize locks_t) $ Space "shared"           dArray locks int32 (arrayShape locks_t) locks_mem $@@ -668,7 +668,7 @@       then         sWhen (ltid + offset .<. pe64 w) $           copyDWIMFix (patElemName pe) [ltid + offset] (Var what) [ltid]-      else sFor "i" (n `divUp` kernelBlockSize constants) $ \i -> do+      else sFor "i" (n `ceilDiv` kernelBlockSize constants) $ \i -> do         j <- dPrimVE "j" $ kernelBlockSize constants * i + ltid         sWhen (j + offset .<. pe64 w) $           copyDWIMFix (patElemName pe) [j + offset] (Var what) [j]@@ -776,7 +776,7 @@   where     mkMap dims = do       let n = product $ map Imp.pe64 dims-      num_chunks <- dPrimVE "num_chunks" $ sExt32 $ n `divUp` unCount tblock_size+      num_chunks <- dPrimVE "num_chunks" $ sExt32 $ n `ceilDiv` unCount tblock_size       pure (dims, num_chunks)  -- | Make use of various precomputed constants.
src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs view
@@ -21,17 +21,25 @@ -- -- LMAX: maximum amount of shared memory per threadblock (hard limit). --+-- SMAX: most passes we are willing to make over the input (depends on+-- how expensive the atomic update is, e.g. 3, and is 1 if the kernel+-- body cannot safely be executed more than once).+-- -- We wish to compute: -- -- COOP: cooperation level (number of threads per subhistogram) -- -- LH: number of shared memory subhistograms --+-- S: number of chunks the buckets are split into, as LH subhistograms+-- of the entire histogram will usually not fit in LMAX.+-- -- We do this as: -- -- COOP = ceil(H / T) -- LH = ceil((G*T)/H)--- if COOP <= G && H <= LMAX then+-- S = ceil(H / (buckets that fit in LMAX))+-- if COOP <= G && S <= SMAX then --   use shared memory -- else --   use global memory@@ -53,7 +61,7 @@ import Futhark.Pass.ExplicitAllocations () import Futhark.Transform.Substitute import Futhark.Util (chunks, mapAccumLM, maxinum, splitFromEnd, takeLast)-import Futhark.Util.IntegralExp (divUp, quot, rem)+import Futhark.Util.IntegralExp (ceilDiv, quot, rem) import Prelude hiding (quot, rem)  data SubhistosInfo = SubhistosInfo@@ -82,6 +90,27 @@ histRank :: HistOp GPUMem -> Int histRank = shapeRank . histShape +-- | The element types of the shared memory arrays that make up a+-- single subhistogram for this operation: one per component of the+-- operator, plus a lock array if the operator needs locking.+slugSharedArrays :: SegHistSlug -> [Type]+slugSharedArrays (SegHistSlug op _ _ do_op) =+  case do_op of+    AtomicLocking {} -> Prim int32 : lambdaReturnType (histOp op)+    _ -> lambdaReturnType (histOp op)++-- | The size of the largest of these histograms.+maxHistSize :: [SegHistSlug] -> Imp.TExp Int64+maxHistSize = L.foldl' sMax64 0 . map (histSize . slugOp)++-- | Bytes of shared memory occupied by a single bucket of a single+-- subhistogram for this operation, not counting the padding of the+-- individual component arrays.+slugSharedBytesPerBucket :: SegHistSlug -> Imp.TExp Int64+slugSharedBytesPerBucket slug =+  unCount . sum . map (typeSize . (`arrayOfShape` histOpShape (slugOp slug))) $+    slugSharedArrays slug+ -- | Figure out how much memory is needed per histogram, both -- segmented and unsegmented, and compute some other auxiliary -- information.@@ -265,7 +294,7 @@         MayBeMultiPass ->           sExt32 $             (sExt64 hist_M_min * hist_H * sExt64 hist_el_size)-              `divUp` t64 (hist_F_L2 * r64 (tvExp hist_L2) * hist_RACE_exp)+              `ceilDiv` t64 (hist_F_L2 * r64 (tvExp hist_L2) * hist_RACE_exp)         MustBeSinglePass ->           1 @@ -287,32 +316,19 @@     r64 = isF64 . ConvOpExp (SIToFP Int32 Float64) . untyped     t64 = isInt64 . ConvOpExp (FPToSI Float64 Int64) . untyped -    -- "Average element size" as computed by a formula that also takes-    -- locking into account.-    slugElAvgSize slug@(SegHistSlug op _ _ do_op) =-      case do_op of-        AtomicLocking {} ->-          slugElSize slug `quot` (1 + L.genericLength (lambdaReturnType (histOp op)))-        _ ->-          slugElSize slug `quot` L.genericLength (lambdaReturnType (histOp op))+    slugElSize :: SegHistSlug -> Imp.TExp Int32+    slugElSize = sExt32 . slugSharedBytesPerBucket      -- "Average element size" as computed by a formula that also takes     -- locking into account.-    slugElSize (SegHistSlug op _ _ do_op) =-      sExt32 . unCount . sum $-        case do_op of-          AtomicLocking {} ->-            map (typeSize . (`arrayOfShape` histOpShape op)) $-              Prim int32 : lambdaReturnType (histOp op)-          _ ->-            map (typeSize . (`arrayOfShape` histOpShape op)) $-              lambdaReturnType (histOp op)+    slugElAvgSize slug =+      slugElSize slug `quot` L.genericLength (slugSharedArrays slug)      onOp hist_L2 hist_M_min hist_S hist_RACE_exp l slug = do       let SegHistSlug op num_subhistos subhisto_info do_op = slug           hist_H = histSize op -      hist_H_chk <- dPrimVE "hist_H_chk" $ hist_H `divUp` sExt64 hist_S+      hist_H_chk <- dPrimVE "hist_H_chk" $ hist_H `ceilDiv` sExt64 hist_S        emit $ Imp.DebugPrint "Chunk size (H_chk)" $ Just $ untyped hist_H_chk @@ -391,7 +407,7 @@       total_w_64 = product space_sizes_64    hist_H_chks <- forM (map (histSize . slugOp) slugs) $ \w ->-    dPrimVE "hist_H_chk" $ w `divUp` sExt64 hist_S+    dPrimVE "hist_H_chk" $ w `ceilDiv` sExt64 hist_S    sKernelThread "seghist_global" (segFlat space) (defKernelAttrs num_tblocks tblock_size) $ do     constants <- kernelConstants <$> askEnv@@ -401,7 +417,7 @@       dPrimVE "subhisto_ind" $         sExt32 (kernelGlobalThreadId constants)           `quot` ( kernelNumThreads constants-                     `divUp` sExt32 (tvExp (slugNumSubhistos slug))+                     `ceilDiv` sExt32 (tvExp (slugNumSubhistos slug))                  )      -- Loop over flat offsets into the input and output.  The@@ -608,7 +624,7 @@     num_segments <- dPrimVE "num_segments" $ product $ map pe64 segment_dims      hist_H_chks <- forM (map slugOp slugs) $ \op ->-      dPrimV "hist_H_chk" $ histSize op `divUp` sExt64 hist_S+      dPrimV "hist_H_chk" $ histSize op `ceilDiv` sExt64 hist_S      histo_sizes <- forM (zip slugs hist_H_chks) $ \(slug, hist_H_chk) -> do       let histo_dims =@@ -617,7 +633,7 @@         dPrimVE "histo_size" $ product histo_dims       let block_hists_size = sExt64 num_subhistos_per_block * histo_size       init_per_thread <--        dPrimVE "init_per_thread" $ sExt32 $ block_hists_size `divUp` pe64 (unCount tblock_size)+        dPrimVE "init_per_thread" $ sExt32 $ block_hists_size `ceilDiv` pe64 (unCount tblock_size)       pure (histo_dims, histo_size, init_per_thread)      let attrs = (defKernelAttrs num_tblocks tblock_size) {kAttrCheckSharedMemory = False}@@ -909,7 +925,7 @@   num_tblocks <-     fmap (Imp.Count . tvSize) $       dPrimV "num_tblocks" $-        sExt64 hist_T `divUp` pe64 (unCount tblock_size)+        sExt64 hist_T `ceilDiv` pe64 (unCount tblock_size)   let num_tblocks' = pe64 <$> num_tblocks       tblock_size' = pe64 <$> tblock_size @@ -922,7 +938,7 @@       r64         ( sMin64             (sExt64 (tvExp hist_L `quot` hist_el_size))-            (hist_N `divUp` sExt64 (unCount num_tblocks'))+            (hist_N `ceilDiv` sExt64 (unCount num_tblocks'))         )         / r64 hist_H @@ -950,10 +966,10 @@           dPrimVE "hist_T_hist_min" $             sExt32 $               sMin64 (sExt64 hist_Nin * sExt64 hist_Nout) (sExt64 hist_T)-                `divUp` sExt64 hist_Nout+                `ceilDiv` sExt64 hist_Nout          -- Number of blocks, rounded up.-        let r = hist_T_hist_min `divUp` sExt32 hist_B+        let r = hist_T_hist_min `ceilDiv` sExt32 hist_B          dPrimVE "work_asymp_M_max" $ hist_Nin `quot` (sExt64 r * hist_H)       else@@ -974,7 +990,7 @@   -- working on the same (sub)histogram.   hist_C <-     dPrimVE "hist_C" $-      hist_B `divUp` sExt64 hist_M_nonzero+      hist_B `ceilDiv` sExt64 hist_M_nonzero    emit $ Imp.DebugPrint "local hist_M0" $ Just $ untyped hist_M0   emit $ Imp.DebugPrint "local work asymp M max" $ Just $ untyped work_asymp_M_max@@ -987,20 +1003,29 @@         untyped $           hist_H * hist_el_size * sExt64 (tvExp hist_M) -  -- local_mem_needed is what we need to keep a single bucket in local-  -- memory - this is an absolute minimum.  We can fit anything else-  -- by doing multiple passes, although more than a few is-  -- (heuristically) not efficient.+  -- local_mem_needed is what we need to keep a single bucket of every+  -- histogram in shared memory - this is an absolute minimum.  We can+  -- fit anything else by doing multiple passes, although more than a+  -- few is (heuristically) not efficient.   local_mem_needed <-     dPrimVE "local_mem_needed" $-      hist_el_size * sExt64 (tvExp hist_M)-  -- We add one to the memory requirement because if the chunk-  -- otherwise *exactly* fits, it might actually *not* fit in the case-  -- of a multi-value operator, as we individually round up the sizes-  -- of the component arrays. (Very rare edge case.)+      sum (map slugSharedBytesPerBucket slugs) * sExt64 hist_M_nonzero++  -- Each component array is separately padded to a multiple of eight+  -- bytes.+  let padding_needed = 8 * L.genericLength (concatMap slugSharedArrays slugs)++  -- We must bound the chunk directly, as dividing the total bucket+  -- space by hist_L bounds only the average chunk, and the chunk we+  -- actually use, ceil(hist_H/hist_S), can then still overrun.+  hist_H_chk_max <-+    dPrimVE "hist_H_chk_max" . sMax64 1 $+      (tvExp hist_L - padding_needed) `quot` local_mem_needed++  -- Fused histograms share a hist_S, so we chunk by the largest.   hist_S <--    dPrimVE "hist_S" . sExt32 $-      (hist_H * local_mem_needed + 1) `divUp` tvExp hist_L+    dPrimVE "hist_S" . sExt32 . sMax64 1 $+      maxHistSize slugs `ceilDiv` hist_H_chk_max   let max_S = case bodyPassage kbody of         MustBeSinglePass -> 1         MayBeMultiPass -> fromIntegral $ maxinum $ map slugMaxLocalMemPasses slugs@@ -1010,7 +1035,7 @@       then         fmap Count $           dPrimVE "blocks_per_segment" $-            unCount num_tblocks' `divUp` hist_Nout+            unCount num_tblocks' `ceilDiv` hist_Nout       else pure num_tblocks'    -- We only use shared memory if the number of updates per histogram@@ -1020,7 +1045,7 @@   let pick_local =         hist_Nin           .>=. hist_H-          .&&. (local_mem_needed .<=. tvExp hist_L)+          .&&. ((local_mem_needed + padding_needed) .<=. tvExp hist_L)           .&&. (hist_S .<=. max_S)           .&&. hist_C           .<=. hist_B@@ -1096,7 +1121,7 @@           _ -> Nothing     hist_el_size <-       dPrimVE "hist_el_size" $-        L.foldl' (+) (h `divUp` hist_H) $+        L.foldl' (+) (h `ceilDiv` hist_H) $           mapMaybe lockSize slugs      -- Input elements contributing to each histogram.
src/Futhark/CodeGen/ImpGen/GPU/SegMap.hs view
@@ -12,7 +12,7 @@ import Futhark.CodeGen.ImpGen.GPU.Base import Futhark.CodeGen.ImpGen.GPU.Block import Futhark.IR.GPUMem-import Futhark.Util.IntegralExp (divUp)+import Futhark.Util.IntegralExp (ceilDiv) import Prelude hiding (quot, rem)  -- | Compile 'SegMap' instance code.@@ -32,7 +32,7 @@   emit $ Imp.DebugPrint "\n# SegMap" Nothing   case lvl of     SegThread {} -> do-      virt_num_tblocks <- dPrimVE "virt_num_tblocks" $ sExt32 $ product dims' `divUp` unCount tblock_size'+      virt_num_tblocks <- dPrimVE "virt_num_tblocks" $ sExt32 $ product dims' `ceilDiv` unCount tblock_size'       sKernelThread "segmap" (segFlat space) attrs $         virtualiseBlocks (segVirt lvl) virt_num_tblocks $ \tblock_id -> do           local_tid <- kernelLocalThreadId . kernelConstants <$> askEnv
src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs view
@@ -56,18 +56,17 @@ where  import Control.Monad-import Data.List (genericLength, zip4)+import Data.List (zip4) import Data.Map qualified as M import Data.Maybe import Futhark.CodeGen.ImpCode.GPU qualified as Imp import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.GPU.Base-import Futhark.Error import Futhark.IR.GPUMem import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.Transform.Rename import Futhark.Util (chunks, mapAccumLM)-import Futhark.Util.IntegralExp (divUp, nextMul, quot, rem)+import Futhark.Util.IntegralExp (ceilDiv, nextMul, quot, rem) import Prelude hiding (quot, rem)  forM2_ :: (Monad m) => [a] -> [b] -> (a -> b -> m c) -> m ()@@ -94,11 +93,6 @@       reg_constraint = (k_reg - 1 - sum_sizes') `quot` (2 * sum_sizes')   untyped $ sMax64 1 $ sMin64 mem_constraint reg_constraint --- | The maximum number of operators we support in a single SegRed.--- This limit arises out of the static allocation of counters.-maxNumOps :: Int-maxNumOps = 25- -- | Code generation for the body of the SegRed, taking a continuation -- for saving the results of the body.  The results should be -- represented as a pairing of a t'SubExp' along with a list of@@ -161,28 +155,18 @@   [SegBinOp GPUMem] ->   DoSegBody ->   CallKernelGen ()-compileSegRed' pat grid space segbinops map_body_cont-  | genericLength segbinops > maxNumOps =-      compilerLimitationS $-        ( "compileSegRed': at most "-            <> show maxNumOps-            <> " reduction operators are supported,\nbut found kernel with "-            <> show (length segbinops)-            <> ".\n"-        )-          <> ("Pattern: " <> prettyString pat)-  | otherwise = do-      chunk_v <- dPrimV "chunk_size" . isInt64 =<< kernelConstToExp chunk_const-      case unSegSpace space of-        [(_, Constant (IntValue (Int64Value 1))), _] ->-          compileReduction (chunk_v, chunk_const) nonsegmentedReduction-        _ -> do-          let segment_size = pe64 $ last $ segSpaceDims space-              use_small_segments = segment_size * 2 .<. pe64 (unCount tblock_size)-          sIf-            use_small_segments-            (compileReduction (chunk_v, chunk_const) smallSegmentsReduction)-            (compileReduction (chunk_v, chunk_const) largeSegmentsReduction)+compileSegRed' pat grid space segbinops map_body_cont = do+  chunk_v <- dPrimV "chunk_size" . isInt64 =<< kernelConstToExp chunk_const+  case unSegSpace space of+    [(_, Constant (IntValue (Int64Value 1))), _] ->+      compileReduction (chunk_v, chunk_const) nonsegmentedReduction+    _ -> do+      let segment_size = pe64 $ last $ segSpaceDims space+          use_small_segments = segment_size * 2 .<. pe64 (unCount tblock_size)+      sIf+        use_small_segments+        (compileReduction (chunk_v, chunk_const) smallSegmentsReduction)+        (compileReduction (chunk_v, chunk_const) largeSegmentsReduction)   where     compileReduction chunk f =       f pat num_tblocks tblock_size chunk space segbinops map_body_cont@@ -358,7 +342,7 @@     -- necessarily be 0.     forM_ gtids $ \v -> dPrimV_ v (0 :: Imp.TExp Int64) -    q <- dPrimVE "q" $ n `divUp` (sExt64 (kernelNumThreads constants) * chunk)+    q <- dPrimVE "q" $ n `ceilDiv` (sExt64 (kernelNumThreads constants) * chunk)      slugs <-       mapM (segBinOpSlug ltid tblock_id) $@@ -410,7 +394,7 @@   num_threads <- fmap tvSize $ dPrimV "num_threads" $ num_tblocks' * tblock_size'   let num_segments = product $ init dims'       segments_per_block = tblock_size' `quot` segment_size_nonzero-      required_blocks = sExt32 $ num_segments `divUp` segments_per_block+      required_blocks = sExt32 $ num_segments `ceilDiv` segments_per_block    emit $ Imp.DebugPrint "# SegRed-small" Nothing   emit $ Imp.DebugPrint "num_segments" $ Just $ untyped num_segments@@ -517,11 +501,11 @@    blocks_per_segment <-     dPrimVE "blocks_per_segment" $-      num_tblocks' `divUp` sMax64 1 num_segments+      num_tblocks' `ceilDiv` sMax64 1 num_segments    q <-     dPrimVE "q" $-      segment_size `divUp` (tblock_size' * blocks_per_segment * chunk)+      segment_size `ceilDiv` (tblock_size' * blocks_per_segment * chunk)    num_virtblocks <-     dPrimV "num_virtblocks" $@@ -1002,7 +986,7 @@       sComment "read in the per-block-results" $ do         read_per_thread <-           dPrimVE "read_per_thread" $-            blocks_per_segment `divUp` sExt64 tblock_size+            blocks_per_segment `ceilDiv` sExt64 tblock_size          forM2_ acc_params nes $ \p ne ->           copyDWIM (paramName p) [] ne []
src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs view
@@ -16,7 +16,7 @@ import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.Transform.Rename import Futhark.Util (mapAccumLM)-import Futhark.Util.IntegralExp (IntegralExp (mod, rem), divUp, nextMul, quot)+import Futhark.Util.IntegralExp (IntegralExp (mod, rem), ceilDiv, nextMul, quot) import Prelude hiding (mod, quot, rem)  xParams, yParams :: SegBinOp GPUMem -> [LParam GPUMem]@@ -235,7 +235,7 @@  -- | Calculate the number of u64 words needed to store n bits bitArrayWords :: Imp.KernelConstExp -> Imp.KernelConstExp-bitArrayWords n = untyped $ isInt64 n `divUp` 64+bitArrayWords n = untyped $ isInt64 n `ceilDiv` 64  -- | Set a bit in a bit array stored as u64 words setBitInBitArray :: Imp.TExp Int64 -> VName -> Imp.TExp Int64 -> Imp.TExp Bool -> InKernelGen ()@@ -362,7 +362,7 @@     dPrimV "num_bit_words" . isInt64 =<< kernelConstToExp num_words_const    num_virt_blocks <--    tvSize <$> dPrimV "num_virt_blocks" (n `divUp` (tblock_size_e * chunk))+    tvSize <$> dPrimV "num_virt_blocks" (n `ceilDiv` (tblock_size_e * chunk))   let num_virt_blocks_e = pe64 num_virt_blocks    num_virt_threads <-@@ -438,7 +438,7 @@     sOp $ Imp.GetBlockId (tvVar phys_block_id) 0     iters <-       dPrimVE "virtloop_bound" $-        (num_virt_blocks_e - tvExp phys_block_id) `divUp` num_phys_blocks_e+        (num_virt_blocks_e - tvExp phys_block_id) `ceilDiv` num_phys_blocks_e      sFor "virtloop_i" iters $ const $ do       dyn_id <- dPrim "dynamic_id"
src/Futhark/CodeGen/ImpGen/GPU/SegScan/TwoPass.hs view
@@ -14,7 +14,7 @@ import Futhark.IR.GPUMem import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.Transform.Rename-import Futhark.Util.IntegralExp (divUp, quot, rem)+import Futhark.Util.IntegralExp (ceilDiv, quot, rem) import Prelude hiding (quot, rem)  -- Aggressively try to reuse memory for different SegBinOps, because@@ -53,7 +53,7 @@       pure arrs      getMem pt shape = do-      let size = typeSize $ Array pt shape NoUniqueness+      let size = typeSize $ Array pt shape NoMode       mems <- get       case (L.find ((size `elem`) . fst) mems, mems) of         (Just mem, _) -> do@@ -160,7 +160,7 @@   let (gtids, dims) = unzip $ unSegSpace space       dims' = map pe64 dims   let num_elements = product dims'-      elems_per_thread = num_elements `divUp` sExt64 (tvExp num_threads)+      elems_per_thread = num_elements `ceilDiv` sExt64 (tvExp num_threads)       elems_per_group = unCount tblock_size' * elems_per_thread    let crossesSegment =@@ -334,7 +334,7 @@   -- Number of chunks needed to cover all stage-1 blocks.   num_chunks <-     dPrimVE "stage2_num_chunks" $-      stage1_num_tblocks_e `divUp` stage2_tblock_size_e+      stage1_num_tblocks_e `ceilDiv` stage2_tblock_size_e    sKernelThread "scan_stage2" (segFlat space) (defKernelAttrs (Count (intConst Int64 1)) stage2_tblock_size) $ do     constants <- kernelConstants <$> askEnv@@ -506,7 +506,7 @@   required_groups <-     dPrimVE "required_groups" $       sExt32 $-        product dims' `divUp` sExt64 (unCount tblock_size')+        product dims' `ceilDiv` sExt64 (unCount tblock_size')    sKernelThread "scan_stage3" (segFlat space) (defKernelAttrs num_tblocks tblock_size) $     virtualiseBlocks SegVirt required_groups $ \virt_tblock_id -> do
src/Futhark/CodeGen/ImpGen/Multicore/Base.hs view
@@ -69,10 +69,10 @@   name_entry <- lookupVar arr   case name_entry of     ArrayVar _ (ArrayEntry (MemLoc mem _ _) _) ->-      pure $ Imp.MemParam mem DefaultSpace+      Imp.MemParam mem . entryMemSpace <$> lookupMemory mem     _ -> error $ "arrParam: could not handle array " ++ show arr -toParam :: VName -> TypeBase shape u -> MulticoreGen [Imp.Param]+toParam :: VName -> TypeBase shape o -> MulticoreGen [Imp.Param] toParam name (Prim pt) = pure [Imp.ScalarParam name pt] toParam name (Mem space) = pure [Imp.MemParam name space] toParam name Array {} = pure <$> arrParam name@@ -379,16 +379,16 @@           -- Common variables.           old <- dPrimS "old" t -          (arr', _a_space, bucket_offset) <- fullyIndexArray a bucket+          (arr', a_space, bucket_offset) <- fullyIndexArray a bucket -          case opHasAtomicSupport old arr' (sExt32 <$> bucket_offset) op of+          case opHasAtomicSupport a_space old arr' (sExt32 <$> bucket_offset) op of             Just f -> sOp $ f $ Imp.var y t             Nothing ->               atomicUpdateCAS t a old bucket x $                 x <~~ Imp.BinOpExp op (Imp.var x t) (Imp.var y t)   where-    opHasAtomicSupport old arr' bucket' bop = do-      let atomic f = Imp.Atomic . f old arr' bucket'+    opHasAtomicSupport space old arr' bucket' bop = do+      let atomic f = Imp.Atomic space . f old arr' bucket'       atomic <$> atomicBinOp bop      primOrCas ops@@ -409,13 +409,13 @@   continue <- dPrimVol "continue" int32 (0 :: Imp.TExp Int32)    -- Correctly index into locks.-  (locks', _locks_space, locks_offset) <-+  (locks', locks_space, locks_offset) <-     fullyIndexArray (lockingArray locking) $ lockingMapping locking bucket    -- Critical section   let try_acquire_lock = do         old <-- (0 :: Imp.TExp Int32)-        sOp . Imp.Atomic $+        sOp . Imp.Atomic locks_space $           Imp.AtomicCmpXchg             int32             (tvVar old)@@ -428,7 +428,7 @@       -- simple write, for memory coherency reasons.       release_lock = do         old <-- lockingToLock locking-        sOp . Imp.Atomic $+        sOp . Imp.Atomic locks_space $           Imp.AtomicCmpXchg             int32             (tvVar old)@@ -480,7 +480,7 @@   MulticoreGen () atomicUpdateCAS t arr old bucket x do_op = do   run_loop <- dPrimV "run_loop" (0 :: Imp.TExp Int32)-  (arr', _a_space, bucket_offset) <- fullyIndexArray arr bucket+  (arr', a_space, bucket_offset) <- fullyIndexArray arr bucket    bytes <- toIntegral $ primBitSize t   let (toBits, fromBits) =@@ -507,7 +507,7 @@   sWhile (tvExp run_loop .==. 0) $ do     x <~~ Imp.var old t     do_op -- Writes result into x-    sOp . Imp.Atomic $+    sOp . Imp.Atomic a_space $       Imp.AtomicCmpXchg         bytes         old_bits_v
src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs view
@@ -15,7 +15,7 @@ import Futhark.CodeGen.ImpGen.Multicore.Base import Futhark.IR.MCMem import Futhark.Transform.Rename (renameBody)-import Futhark.Util.IntegralExp (divUp)+import Futhark.Util.IntegralExp (ceilDiv) import Prelude hiding (quot, rem)  -- This does not correspond with the actual cache size, but the actual cache@@ -344,14 +344,18 @@   VName ->   Imp.Count Imp.Elements (Imp.TExp Int32) ->   MulticoreGen ()-load64 v arr i = sOp $ Imp.Atomic $ Imp.AtomicLoad (IntType Int64) v arr i+load64 v arr i = do+  space <- entryMemSpace <$> lookupMemory arr+  sOp $ Imp.Atomic space $ Imp.AtomicLoad (IntType Int64) v arr i  store64 ::   VName ->   Imp.Count Imp.Elements (Imp.TExp Int32) ->   Imp.TExp Int64 ->   MulticoreGen ()-store64 arr i x = sOp $ Imp.Atomic $ Imp.AtomicStore (IntType Int64) arr i (untyped x)+store64 arr i x = do+  space <- entryMemSpace <$> lookupMemory arr+  sOp $ Imp.Atomic space $ Imp.AtomicStore (IntType Int64) arr i (untyped x)  add64 ::   TV Int64 ->@@ -359,7 +363,9 @@   Imp.Count Imp.Elements (Imp.TExp Int32) ->   Imp.TExp Int64 ->   MulticoreGen ()-add64 v arr i x = sOp $ Imp.Atomic $ Imp.AtomicAdd Int64 (tvVar v) arr i (untyped x)+add64 v arr i x = do+  space <- entryMemSpace <$> lookupMemory arr+  sOp $ Imp.Atomic space $ Imp.AtomicAdd Int64 (tvVar v) arr i (untyped x)  applyPostOp ::   Pat LetDecMem ->@@ -422,9 +428,9 @@   post_op   nsubtasks = do     let multiplier = 1 -- For playing with.-        blockSize = cacheSize `divUp` (totalBytes scan_ops * multiplier)+        blockSize = cacheSize `ceilDiv` (totalBytes scan_ops * multiplier) -    block_no <- dPrimV "nblocks" (pe64 n `divUp` blockSize)+    block_no <- dPrimV "nblocks" (pe64 n `ceilDiv` blockSize)      -- allocate flags/aggr/prefix arrays of length nblocks     flagsArr <- sAllocArray "scan_flags" int64 (Shape [Var (tvVar block_no)]) DefaultSpace
src/Futhark/Construct.hs view
@@ -663,8 +663,8 @@ instantiateShapes ::   (Monad m) =>   (Int -> m SubExp) ->-  [TypeBase ExtShape u] ->-  m [TypeBase Shape u]+  [TypeBase ExtShape o] ->+  m [TypeBase Shape o] instantiateShapes f ts = evalStateT (mapM instantiate ts) M.empty   where     instantiate t = do@@ -683,7 +683,7 @@ -- | Like 'instantiateShapes', but obtains names from the provided -- list.  If an 'Ext' is out of bounds of this list, the function -- fails with 'error'.-instantiateShapes' :: [VName] -> [TypeBase ExtShape u] -> [TypeBase Shape u]+instantiateShapes' :: [VName] -> [TypeBase ExtShape o] -> [TypeBase Shape o] instantiateShapes' names ts =   -- Carefully ensure that the order of idents we produce corresponds   -- to their existential index.
src/Futhark/Doc/Generator.hs view
@@ -33,8 +33,8 @@ primTypeHtml :: PrimType -> Html primTypeHtml = docToHtml . pretty -prettyU :: Uniqueness -> Html-prettyU = docToHtml . pretty+prettyMode :: Freshness -> Html+prettyMode = docToHtml . pretty  renderName :: Name -> Html renderName name = docToHtml (pretty name)@@ -442,7 +442,7 @@  renderTypeBind :: (VName, TypeBinding) -> DocM Html renderTypeBind (name, TypeAbbr l tps tp) = do-  tp' <- retTypeHtml $ toResRet Nonunique tp+  tp' <- retTypeHtml $ toResRet Nonfresh tp   name' <- vnameHtml name   abbrev <- typeAbbrevHtml l name' tps   pure $ H.div $ abbrev <> " = " <> tp'@@ -450,7 +450,7 @@ synopsisValBindBind :: (VName, BoundV) -> DocM Html synopsisValBindBind (name, BoundV tps t) = do   tps' <- mapM typeParamHtml tps-  t' <- typeHtml $ second (const Nonunique) t+  t' <- typeHtml $ second (const Nonfresh) t   name' <- vnameHtml name   pure $ keyword "val " <> name' <> mconcat (map (" " <>) tps') <> ": " <> t' @@ -458,12 +458,12 @@ dietHtml Consume = "*" dietHtml Observe = "" -typeHtml :: TypeBase Size Uniqueness -> DocM Html+typeHtml :: TypeBase Size Freshness -> DocM Html typeHtml t = case t of-  Array u shape et -> do+  Array o shape et -> do     shape' <- prettyShape shape-    et' <- typeHtml $ Scalar $ second (const Nonunique) et-    pure $ prettyU u <> shape' <> et'+    et' <- typeHtml $ Scalar $ second (const Nonfresh) et+    pure $ prettyMode o <> shape' <> et'   Scalar (Prim et) -> pure $ primTypeHtml et   Scalar (Record fs)     | Just ts <- areTupleFields fs ->@@ -474,12 +474,12 @@       ppField (name, tp) = do         tp' <- typeHtml tp         pure $ toHtml (nameToString name) <> ": " <> tp'-  Scalar (TypeVar u et targs) -> do+  Scalar (TypeVar o et targs) -> do     targs' <- mapM typeArgHtml targs     et' <- qualNameHtml et-    pure $ prettyU u <> et' <> mconcat (map (" " <>) targs')+    pure $ prettyMode o <> et' <> mconcat (map (" " <>) targs')   Scalar (Arrow _ pname d t1 t2) -> do-    t1' <- typeHtml $ second (const Nonunique) t1+    t1' <- typeHtml $ second (const Nonfresh) t1     t2' <- retTypeHtml t2     case pname of       Named v -> do@@ -505,7 +505,7 @@  typeArgHtml :: TypeArg Size -> DocM Html typeArgHtml (TypeArgDim d) = dimDeclHtml d-typeArgHtml (TypeArgType t) = typeHtml $ second (const Nonunique) t+typeArgHtml (TypeArgType t) = typeHtml $ second (const Nonfresh) t  modParamHtml :: [ModParamBase Info VName] -> DocM Html modParamHtml [] = pure mempty@@ -597,7 +597,7 @@  typeExpHtml :: TypeExp Exp VName -> DocM Html typeExpHtml e = case e of-  TEUnique t _ -> ("*" <>) <$> typeExpHtml t+  TEStar t _ -> ("*" <>) <$> typeExpHtml t   TEArray d at _ -> do     at' <- typeExpHtml at     d' <- dimExpHtml d@@ -666,7 +666,7 @@ paramHtml :: Pat ParamType -> DocM Html paramHtml pat = do   let (pat_param, d, t) = patternParam pat-  t' <- typeHtml $ second (const Nonunique) t+  t' <- typeHtml $ second (const Nonfresh) t   case pat_param of     Named v -> do       v' <- vnameHtml v
src/Futhark/Error.hs view
@@ -11,6 +11,7 @@     compilerLimitation,     compilerLimitationS,     internalErrorS,+    badOnLeft,   ) where @@ -36,6 +37,11 @@   | -- | An internal compiler error.  The second pretty is extra data     -- for debugging, which can be written to a file.     InternalError T.Text T.Text ErrorClass++-- | Turn a failure into an error in the current monad, mapping the+-- failure with the given function.+badOnLeft :: (MonadError err' m) => (err -> err') -> Either err a -> m a+badOnLeft f = either (throwError . f) pure  -- | Print an error intended for human consumption. prettyCompilerError :: CompilerError -> Doc AnsiStyle
src/Futhark/Eval.hs view
@@ -1,42 +1,66 @@+-- | Facilities for evaluating Futhark code.+--+-- This most directly provides the building blocks for @futhark eval@, but this+-- module also contains server interaction machinery used by @futhark repl@ and+-- other commands that make use of the Futhark interpreter. module Futhark.Eval-  ( InterpreterConfig (..),+  ( EvalConfig (..),+    InterpreterState,     runExpr,-    interpreterConfig,-    newFutharkiState,+    evalConfig,+    evalServerOptions,+    runFFI,+    forceValue,+    externaliseLast,+    runInterpreterWith,+    interpretImports,+    initialiseInterpreter,+    newInterpreterState,     Evaluation (..),-    EvalRecordRef (),+    EvalRecordRef,     runEvalRecordRef,   ) where  import Control.Exception (IOException, catch)-import Control.Monad (foldM, when, (<=<))-import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad (foldM, unless, void, 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.Bifunctor (first)+import Data.Either (isLeft) import Data.IORef (IORef, modifyIORef') import Data.Map qualified as M-import Data.Maybe (maybeToList)+import Data.Maybe (isJust, 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.Compiler.Program (FileModule (..), Imports, VFS, fileScope)+import Futhark.Error (badOnLeft, externalErrorS, prettyCompilerError) import Futhark.FreshNames (VNameSource)+import Futhark.Server qualified as S+import Futhark.Test.Compile (FutharkExe (..), compileProgram, futharkServerCfg)+import Futhark.Util (showText)+import Futhark.Util.Options (ArgDescr (..), FunOptDescr, OptDescr (..)) import Futhark.Util.Pretty (commasep, hPutDoc, hPutDocLn, hardline, putDocLn)+import Language.Futhark.Core (locText) import Language.Futhark.Interpreter qualified as I+import Language.Futhark.Interpreter.FFI.Push qualified as FFI+import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI 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.Prop (UncheckedExp, typeOf) import Language.Futhark.Semantic qualified as T-import Language.Futhark.Syntax (nameToText, typeParamName)+import Language.Futhark.Syntax (DecBase (LocalDec, ValDec), ProgBase (progDecs), ValBindBase (..), nameToText, typeParamName) import Language.Futhark.TypeChecker qualified as T import Prettyprinter (Doc, align, pretty, unAnnotate, vcat, (<+>)) import Prettyprinter.Render.Terminal (AnsiStyle)+import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitFailure), exitWith)+import System.FilePath (dropExtension, (</>)) import System.IO (stderr)  -- | The class of monads that can perform expression evaluation.@@ -78,20 +102,29 @@ runEvalRecordRef msgRef (EvalRecordRef action) =   flip runReaderT msgRef $ runExceptT action -newtype InterpreterState = InterpreterState (VNameSource, T.Env, I.Ctx)+newtype InterpreterState = InterpreterState (VNameSource, T.Env, I.Ctx, Maybe FFI.Server)  -- | 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) =>+  (Evaluation m, MonadIO m) =>   InterpreterState ->   T.Text ->   m (Doc AnsiStyle)-runExpr (InterpreterState (src, env, ctx)) str = do-  uexp <- case parseExp "" str of+runExpr state str =+  case parseExp "" str of     Left (SyntaxError _ serr) -> abort $ pretty serr-    Right e -> pure e+    Right uexp -> runParsedExpr state uexp++-- | As 'runExpr', but for an expression that has already been parsed -+-- perhaps from somewhere other than a Futhark file.+runParsedExpr ::+  (Evaluation m, MonadIO m) =>+  InterpreterState ->+  UncheckedExp ->+  m (Doc AnsiStyle)+runParsedExpr (InterpreterState (src, env, ctx, s)) uexp = do   fexp <- case T.checkExp [] src env uexp of     (_, Left terr) -> do       abort $ T.prettyTypeError terr@@ -103,27 +136,140 @@             "The following types are ambiguous: "               <> commasep (map (pretty . nameToText . toName . typeParamName) tparams)           ]-  pval <- runInterpreterNoBreak $ I.interpretExp ctx fexp+  pval <- runInterpreterWith trace s Nothing $ I.interpretExp ctx fexp   case pval of-    Left err -> do-      abort $ I.prettyInterpreterError err-    Right val -> pure $ I.prettyValue val <> hardline+    Left err -> abort $ I.prettyInterpreterError err+    Right val -> do+      forced <- liftIO $ forceValue s val+      case forced of+        Left err -> abort $ I.prettyInterpreterError err+        Right val' -> pure $ I.prettyValue val' <> hardline -data InterpreterConfig = InterpreterConfig-  { interpreterPrintWarnings :: Bool,-    interpreterFile :: Maybe String+data EvalConfig = EvalConfig+  { evalPrintWarnings :: Bool,+    evalFile :: Maybe String,+    -- | If @Just@, compile the file using this backend.+    evalBackend :: Maybe String,+    evalSkipCompilation :: Bool,+    evalExtraOptions :: [String],+    evalCompilerOptions :: [String],+    evalFuthark :: Maybe FilePath   } -interpreterConfig :: InterpreterConfig-interpreterConfig = InterpreterConfig True Nothing+evalConfig :: EvalConfig+evalConfig =+  EvalConfig+    { evalPrintWarnings = True,+      evalFile = Nothing,+      evalBackend = Nothing,+      evalSkipCompilation = False,+      evalExtraOptions = [],+      evalCompilerOptions = [],+      evalFuthark = Nothing+    } -newFutharkiState ::+-- | Command line options for configuring the use of an external server.+evalServerOptions :: [FunOptDescr EvalConfig]+evalServerOptions =+  [ Option+      "p"+      ["pass-option"]+      ( ReqArg+          ( \opt ->+              Right $ \config ->+                config {evalExtraOptions = opt : evalExtraOptions config}+          )+          "OPT"+      )+      "Pass this option to programs being run.",+    Option+      []+      ["pass-compiler-option"]+      ( ReqArg+          ( \opt ->+              Right $ \config ->+                config {evalCompilerOptions = opt : evalCompilerOptions config}+          )+          "OPT"+      )+      "Pass this option to the compiler.",+    Option+      []+      ["skip-compilation"]+      (NoArg $ Right $ \config -> config {evalSkipCompilation = True})+      "Use already compiled server-mode program.",+    Option+      []+      ["backend"]+      ( ReqArg+          (\backend -> Right $ \config -> config {evalBackend = Just backend})+          "BACKEND"+      )+      "The compiler backend used (defaults to interpreted)."+  ]++-- | Compile the given file and start a server for it. Returns 'Left' on error.+prepareServer :: EvalConfig -> FilePath -> String -> IO (Either T.Text FFI.Server)+prepareServer cfg file backend = runExceptT $ do+  futhark <- liftIO $ maybe getExecutablePath pure $ evalFuthark cfg++  unless (evalSkipCompilation cfg) $+    void $+      compileProgram ("--server" : evalCompilerOptions cfg) (FutharkExe futhark) backend file++  let server_cfg = futharkServerCfg ("." </> dropExtension file) $ evalExtraOptions cfg+  started <-+    liftIO $+      (Right <$> FFI.startServer server_cfg)+        `catch` (\(S.ServerException err) -> pure $ Left err)+        `catch` (\(err :: IOException) -> pure $ Left $ showText err)+  either throwError pure started++-- | Perform an action on the server. A failure is reported as a 'Left'. Calls+-- 'error' if no server is provided.+runFFI ::+  Maybe FFI.Server ->+  FFI.ServerM I.Value ->+  IO (Either I.InterpreterError I.Value)+runFFI Nothing _ = error "External call, but no server."+runFFI (Just server) m =+  first (I.InterpreterError . T.pack) <$> FFI.runServerM server m++-- | Fetch in full a value that may reside on a server, so that it can+-- be printed or otherwise inspected.+forceValue ::+  Maybe FFI.Server ->+  I.Value ->+  IO (Either I.InterpreterError I.Value)+forceValue Nothing v = pure $ Right v+forceValue server v = runFFI server $ FFI.getLazy v++externalise :: FileModule -> FileModule+externalise fm = fm {fileProg = (fileProg fm) {progDecs = map onDec $ progDecs $ fileProg fm}}+  where+    onDec (ValDec vb)+      | isJust $ valBindEntryPoint vb =+          ValDec $ vb {valBindAttrs = "$external" : valBindAttrs vb}+    onDec (LocalDec dec loc) = LocalDec (onDec dec) loc+    onDec dec = dec++-- | Mark the entry points of the last import - which is the file the+-- user actually asked us to load - as external, meaning that calls to+-- them are dispatched to a server instead of being interpreted.+externaliseLast :: Imports -> Imports+externaliseLast [] = []+externaliseLast [(k, fm)] = [(k, externalise fm)]+externaliseLast (x : xs) = x : externaliseLast xs++-- | Type check and interpret the given program (if any), producing a state+-- in which expressions can be evaluated with 'runExpr'.+newInterpreterState ::   (MonadIO m, Evaluation m) =>-  InterpreterConfig ->-  Maybe FilePath ->+  EvalConfig ->   VFS ->   m (Either (Doc AnsiStyle) InterpreterState)-newFutharkiState cfg maybe_file vfs = runExceptT $ do+newInterpreterState cfg vfs = runExceptT $ do+  let maybe_file = evalFile cfg   (ws, imports, src) <-     badOnLeft prettyCompilerError       =<< liftIO@@ -131,39 +277,87 @@             `catch` \(err :: IOException) ->               pure (externalErrorS (show err))         )-  when (interpreterPrintWarnings cfg) $-    liftIO $-      hPutDoc stderr $-        prettyWarnings ws+  when (evalPrintWarnings 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+  (s, tenv, ienv) <- ExceptT $ initialiseInterpreter cfg maybe_file Nothing 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, s) -  pure $ InterpreterState (src, tenv, ienv)+-- | Interpret the given imports in order with the provided interpreter runner,+-- and produce the type and interpreter environment of the last one.+interpretImports ::+  (Monad m) =>+  (F I.ExtOp I.Ctx -> m (Either I.InterpreterError I.Ctx)) ->+  Imports ->+  ExceptT (Doc AnsiStyle) m (T.Env, I.Ctx)+interpretImports runner imports = do+  let foldFile ctx =+        badOnLeft I.prettyInterpreterError+          <=< lift . runner . I.interpretImport ctx+  ictx <- foldM foldFile I.initialCtx $ map (fmap fileProg) imports+  let (iname, fm) = last imports+  pure (fileScope fm, ictx {I.ctxEnv = I.ctxImports ictx M.! iname})++-- | Set up an interpreter context for the given program. If a server is+-- provided, or a backend has been requested (in which case a server is+-- started), then the entry points of the loaded file are marked external, such+-- that calls to them are dispatched to the server instead of being interpreted.+-- On failure, a server started here is shut down again, so a returned server is+-- always one that the caller now owns (and must eventually stop). A server+-- passed in by the caller is never shut down here.+initialiseInterpreter ::+  (Evaluation m, MonadIO m) =>+  EvalConfig ->+  Maybe FilePath ->+  Maybe FFI.Server ->+  Imports ->+  m (Either (Doc AnsiStyle) (Maybe FFI.Server, T.Env, I.Ctx))+initialiseInterpreter cfg maybe_file server imports =+  case (server, maybe_file, evalBackend cfg) of+    (Just s, _, _) ->+      evalWith (Just s) $ externaliseLast imports+    (Nothing, Just file, Just backend) -> do+      started <- liftIO $ prepareServer cfg file backend+      case started of+        Left err -> pure $ Left $ pretty err+        Right s -> do+          r <- evalWith (Just s) $ externaliseLast imports+          -- Do not leave a server running if we never got off the ground.+          when (isLeft r) $ void $ liftIO $ FFI.stopServer s+          pure r+    _ -> evalWith Nothing imports   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+    evalWith s =+      runExceptT+        . fmap (\(tenv, ienv) -> (s, tenv, ienv))+        . interpretImports (runInterpreterWith trace s Nothing) -runInterpreterNoBreak ::-  (Evaluation m) =>+-- | Run an interpreter action non-interactively. Breakpoints are ignored, as+-- there is no way to enter a debugging prompt. Traces, and the breakpoints+-- that are ignored, are reported with the given function. External calls are+-- dispatched to the given server (if any). Relative paths in IO operations are+-- resolved relative to the given directory, if any, and otherwise relative to+-- the working directory.+runInterpreterWith ::+  (MonadIO m) =>+  (Doc AnsiStyle -> m ()) ->+  Maybe FFI.Server ->+  Maybe FilePath ->   F I.ExtOp a ->   m (Either I.InterpreterError a)-runInterpreterNoBreak m = runF m (pure . Right) intOp+runInterpreterWith report s dir 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)+      report $ pretty w <> ":" <+> align (unAnnotate v)       c-    intOp (I.ExtOpBreak _ _ _ c) = c+    intOp (I.ExtOpBreak _ I.BreakNaN _ c) = c+    intOp (I.ExtOpBreak w _ _ c) = do+      report $ pretty (locText w) <> ": ignoring breakpoint."+      c+    intOp (I.ExtOpFFI sm c) = either (pure . Left) c =<< liftIO (runFFI s sm)+    intOp (I.ExtOpIO op c) =+      either (pure . Left . I.InterpreterError) c+        =<< liftIO (I.doIOOp s (maybe id I.ioRelativeTo dir op))
src/Futhark/Fmt/Printer.hs view
@@ -98,7 +98,7 @@     where       fmtFieldType (L _ name', t) = fmtName mempty name' <> ":" <+> align (fmt t)   fmt (TEArray se te loc) = addComments loc $ fmt se <> fmt te-  fmt (TEUnique te loc) = addComments loc $ "*" <> fmt te+  fmt (TEStar te loc) = addComments loc $ "*" <> fmt te   fmt (TEApply te tArgE loc) = addComments loc $ fmt te <+> fmt tArgE   fmt (TEArrow name te0 te1 loc) =     addComments loc $@@ -135,11 +135,12 @@           <+> "="           </> stdIndent (fmt e) -instance Format (AttrAtom a) where+instance Format (AttrAtom Name) where   fmt (AtomName name) = fmt name+  fmt (AtomVar name) = "$" <> fmt name   fmt (AtomInt int) = text constantStyle $ prettyText int -instance Format (AttrInfo a) where+instance Format (AttrInfo Name) where   fmt attr = "#" <> brackets (fmtAttrInfo attr)     where       fmtAttrInfo (AttrAtom attr' loc) = addComments loc $ fmt attr'
src/Futhark/IR/GPU/Op.hs view
@@ -8,6 +8,7 @@     -- * Host operations     HostOp (..),     traverseHostOpStms,+    simplifyKernelOp,     typeCheckHostOp,      -- * SegOp refinements@@ -409,3 +410,45 @@     [ "Expected type: " <> prettyTuple ts,       "Got body type: " <> prettyTuple body_ts     ]++-- | Simplify a 'HostOp', using the provided function for 'OtherOp'.+simplifyKernelOp ::+  ( Engine.SimplifiableRep rep,+    BodyDec rep ~ ()+  ) =>+  Engine.SimplifyOp rep (op (Wise rep)) ->+  HostOp op (Wise rep) ->+  Engine.SimpleM rep (HostOp op (Wise rep), Stms (Wise rep))+simplifyKernelOp f (OtherOp op) = do+  (op', stms) <- f op+  pure (OtherOp op', stms)+simplifyKernelOp _ (SegOp op) = do+  (op', hoisted) <- simplifySegOp op+  pure (SegOp op', hoisted)+simplifyKernelOp _ (SizeOp (GetSize key size_class)) =+  pure (SizeOp $ GetSize key size_class, mempty)+simplifyKernelOp _ (SizeOp (GetSizeMax size_class)) =+  pure (SizeOp $ GetSizeMax size_class, mempty)+simplifyKernelOp _ (SizeOp (CmpSizeLe key size_class x)) = do+  x' <- Engine.simplify x+  pure (SizeOp $ CmpSizeLe key size_class x', mempty)+simplifyKernelOp _ (SizeOp (CalcNumBlocks w max_num_tblocks tblock_size)) = do+  w' <- Engine.simplify w+  pure (SizeOp $ CalcNumBlocks w' max_num_tblocks tblock_size, mempty)+simplifyKernelOp _ (GPUBody ts body) = do+  ts' <- Engine.simplify ts+  (hoisted, body') <-+    -- A GPUBody is a single-threaded kernel that cannot perform+    -- allocations.  By pretending we are simplifying memory (as we do+    -- inside SegOps) we allow allocations to be hoisted out of+    -- branches within the body, and ultimately out of the GPUBody+    -- itself.+    Engine.localVtable (\vtable -> vtable {ST.simplifyMemory = True}) $+      Engine.simplifyBody keepOnGPU mempty (map (const mempty) ts) body+  pure (GPUBody ts' body', hoisted)+  where+    keepOnGPU _ _ = keepExpOnGPU . stmExp+    keepExpOnGPU (BasicOp Index {}) = True+    keepExpOnGPU (BasicOp (ArrayLit _ t)) | primType t = True+    keepExpOnGPU Loop {} = True+    keepExpOnGPU _ = False
src/Futhark/IR/GPU/Simplify.hs view
@@ -39,47 +39,6 @@ simplifyLambda =   Simplify.simplifyLambda simpleGPU kernelRules Engine.noExtraHoistBlockers -simplifyKernelOp ::-  ( Engine.SimplifiableRep rep,-    BodyDec rep ~ ()-  ) =>-  Simplify.SimplifyOp rep (op (Wise rep)) ->-  HostOp op (Wise rep) ->-  Engine.SimpleM rep (HostOp op (Wise rep), Stms (Wise rep))-simplifyKernelOp f (OtherOp op) = do-  (op', stms) <- f op-  pure (OtherOp op', stms)-simplifyKernelOp _ (SegOp op) = do-  (op', hoisted) <- simplifySegOp op-  pure (SegOp op', hoisted)-simplifyKernelOp _ (SizeOp (GetSize key size_class)) =-  pure (SizeOp $ GetSize key size_class, mempty)-simplifyKernelOp _ (SizeOp (GetSizeMax size_class)) =-  pure (SizeOp $ GetSizeMax size_class, mempty)-simplifyKernelOp _ (SizeOp (CmpSizeLe key size_class x)) = do-  x' <- Engine.simplify x-  pure (SizeOp $ CmpSizeLe key size_class x', mempty)-simplifyKernelOp _ (SizeOp (CalcNumBlocks w max_num_tblocks tblock_size)) = do-  w' <- Engine.simplify w-  pure (SizeOp $ CalcNumBlocks w' max_num_tblocks tblock_size, mempty)-simplifyKernelOp _ (GPUBody ts body) = do-  ts' <- Engine.simplify ts-  (hoisted, body') <--    -- A GPUBody is a single-threaded kernel that cannot perform-    -- allocations.  By pretending we are simplifying memory (as we do-    -- inside SegOps) we allow allocations to be hoisted out of-    -- branches within the body, and ultimately out of the GPUBody-    -- itself.-    Engine.localVtable (\vtable -> vtable {ST.simplifyMemory = True}) $-      Engine.simplifyBody keepOnGPU mempty (map (const mempty) ts) body-  pure (GPUBody ts' body', hoisted)-  where-    keepOnGPU _ _ = keepExpOnGPU . stmExp-    keepExpOnGPU (BasicOp Index {}) = True-    keepExpOnGPU (BasicOp (ArrayLit _ t)) | primType t = True-    keepExpOnGPU Loop {} = True-    keepExpOnGPU _ = False- instance TraverseOpStms (Wise GPU) where   traverseOpStms = traverseHostOpStms traverseSOACStms
src/Futhark/IR/GPUMem.hs view
@@ -18,7 +18,6 @@ import Futhark.Analysis.UsageTable qualified as UT import Futhark.IR.Aliases (Aliases) import Futhark.IR.GPU.Op-import Futhark.IR.GPU.Simplify (simplifyKernelOp) import Futhark.IR.Mem import Futhark.IR.Mem.Simplify import Futhark.IR.TypeCheck qualified as TC@@ -58,7 +57,7 @@   checkFParamDec = checkMemInfo   checkLParamDec = checkMemInfo   checkLetBoundDec = checkMemInfo-  checkRetType = mapM_ $ TC.checkExtType . declExtTypeOf+  checkRetType = mapM_ $ TC.checkExtType . extTypeOf   primFParam name t = pure $ Param mempty name (MemPrim t)   matchPat = matchPatToExp   matchReturnType = matchFunctionReturnType
src/Futhark/IR/MCMem.hs view
@@ -49,7 +49,7 @@   checkFParamDec = checkMemInfo   checkLParamDec = checkMemInfo   checkLetBoundDec = checkMemInfo-  checkRetType = mapM_ (TC.checkExtType . declExtTypeOf)+  checkRetType = mapM_ (TC.checkExtType . extTypeOf)   primFParam name t = pure $ Param mempty name (MemPrim t)   matchPat = matchPatToExp   matchReturnType = matchFunctionReturnType
src/Futhark/IR/Mem.hs view
@@ -68,7 +68,7 @@     ExpReturns,     BodyReturns,     FunReturns,-    noUniquenessReturns,+    noModeReturns,     bodyReturnsToExpReturns,     Mem,     HasLetDecMem (..),@@ -139,11 +139,11 @@ import Futhark.Util.Pretty qualified as PP import Prelude hiding (id, (.)) -type LetDecMem = MemInfo SubExp NoUniqueness MemBind+type LetDecMem = MemInfo SubExp NoMode MemBind -type FParamMem = MemInfo SubExp Uniqueness MemBind+type FParamMem = MemInfo SubExp Diet MemBind -type LParamMem = MemInfo SubExp NoUniqueness MemBind+type LParamMem = MemInfo SubExp NoMode MemBind  type RetTypeMem = FunReturns @@ -217,7 +217,7 @@   opType (EnsureDirect v) = f <$> lookupType v     where       f (Array pt shape _) =-        [Mem DefaultSpace, Array pt (fmap Free shape) NoUniqueness]+        [Mem DefaultSpace, Array pt (fmap Free shape) NoMode]       f _ = error $ "EnsureDirect applied to non-array: " ++ show v   opType (Inner k) = opType k @@ -284,10 +284,10 @@ -- | An index function that may contain existential variables. type ExtLMAD = LMAD.LMAD (TPrimExp Int64 (Ext VName)) --- | A summary of the memory information for every let-bound--- identifier, function parameter, and return value.  Parameterisered--- over uniqueness, dimension, and auxiliary array information.-data MemInfo d u ret+-- | A summary of the memory information for every let-bound identifier,+-- function parameter, and return value. Parameterisered over mode, dimension,+-- and auxiliary array information.+data MemInfo d o ret   = -- | A primitive value.     MemPrim PrimType   | -- | A memory block.@@ -297,81 +297,71 @@     -- array to /element/ offset, /not/ byte offsets!  To translate to     -- byte offsets, multiply the offset with the size of the array     -- element type.-    MemArray PrimType (ShapeBase d) u ret+    MemArray PrimType (ShapeBase d) o ret   | -- | An accumulator, which is not stored anywhere.-    MemAcc VName Shape [Type] u+    MemAcc VName Shape [Type]   deriving (Eq, Show, Ord) --- XXX Ord? -type MemBound u = MemInfo SubExp u MemBind--instance (FixExt ret) => DeclExtTyped (MemInfo ExtSize Uniqueness ret) where-  declExtTypeOf (MemPrim pt) = Prim pt-  declExtTypeOf (MemMem space) = Mem space-  declExtTypeOf (MemArray pt shape u _) = Array pt shape u-  declExtTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u--instance (FixExt ret) => ExtTyped (MemInfo ExtSize Uniqueness ret) where-  extTypeOf = fromDecl . declExtTypeOf+type MemBound o = MemInfo SubExp o MemBind -instance (FixExt ret) => ExtTyped (MemInfo ExtSize NoUniqueness ret) where+instance (FixExt ret) => ExtTyped (MemInfo ExtSize NoMode ret) where   extTypeOf (MemPrim pt) = Prim pt   extTypeOf (MemMem space) = Mem space-  extTypeOf (MemArray pt shape u _) = Array pt shape u-  extTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u+  extTypeOf (MemArray pt shape o _) = Array pt shape o+  extTypeOf (MemAcc acc ispace ts) = Acc acc ispace ts -instance (FixExt ret) => FixExt (MemInfo ExtSize u ret) where+instance (FixExt ret) => FixExt (MemInfo ExtSize o ret) where   fixExt _ _ (MemPrim pt) = MemPrim pt   fixExt _ _ (MemMem space) = MemMem space-  fixExt _ _ (MemAcc acc ispace ts u) = MemAcc acc ispace ts u-  fixExt i se (MemArray pt shape u ret) =-    MemArray pt (fixExt i se shape) u (fixExt i se ret)+  fixExt _ _ (MemAcc acc ispace ts) = MemAcc acc ispace ts+  fixExt i se (MemArray pt shape o ret) =+    MemArray pt (fixExt i se shape) o (fixExt i se ret)    mapExt _ (MemPrim pt) = MemPrim pt   mapExt _ (MemMem space) = MemMem space-  mapExt _ (MemAcc acc ispace ts u) = MemAcc acc ispace ts u-  mapExt f (MemArray pt shape u ret) =-    MemArray pt (mapExt f shape) u (mapExt f ret)+  mapExt _ (MemAcc acc ispace ts) = MemAcc acc ispace ts+  mapExt f (MemArray pt shape o ret) =+    MemArray pt (mapExt f shape) o (mapExt f ret) -instance Typed (MemInfo SubExp Uniqueness ret) where+instance Typed (MemInfo SubExp Diet ret) where   typeOf = fromDecl . declTypeOf -instance Typed (MemInfo SubExp NoUniqueness ret) where+instance Typed (MemInfo SubExp NoMode ret) where   typeOf (MemPrim pt) = Prim pt   typeOf (MemMem space) = Mem space-  typeOf (MemArray bt shape u _) = Array bt shape u-  typeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u+  typeOf (MemArray bt shape o _) = Array bt shape o+  typeOf (MemAcc acc ispace ts) = Acc acc ispace ts -instance DeclTyped (MemInfo SubExp Uniqueness ret) where+instance DeclTyped (MemInfo SubExp Diet ret) where   declTypeOf (MemPrim bt) = Prim bt   declTypeOf (MemMem space) = Mem space-  declTypeOf (MemArray bt shape u _) = Array bt shape u-  declTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u+  declTypeOf (MemArray bt shape o _) = Array bt shape o+  declTypeOf (MemAcc acc ispace ts) = Acc acc ispace ts -instance (FreeIn d, FreeIn ret) => FreeIn (MemInfo d u ret) where+instance (FreeIn d, FreeIn ret) => FreeIn (MemInfo d o ret) where   freeIn' (MemArray _ shape _ ret) = freeIn' shape <> freeIn' ret   freeIn' (MemMem s) = freeIn' s   freeIn' MemPrim {} = mempty-  freeIn' (MemAcc acc ispace ts _) = freeIn' (acc, ispace, ts)+  freeIn' (MemAcc acc ispace ts) = freeIn' (acc, ispace, ts) -instance (Substitute d, Substitute ret) => Substitute (MemInfo d u ret) where-  substituteNames subst (MemArray bt shape u ret) =+instance (Substitute d, Substitute ret) => Substitute (MemInfo d o ret) where+  substituteNames subst (MemArray bt shape o ret) =     MemArray       bt       (substituteNames subst shape)-      u+      o       (substituteNames subst ret)-  substituteNames substs (MemAcc acc ispace ts u) =+  substituteNames substs (MemAcc acc ispace ts) =     MemAcc       (substituteNames substs acc)       (substituteNames substs ispace)       (substituteNames substs ts)-      u   substituteNames _ (MemMem space) =     MemMem space   substituteNames _ (MemPrim bt) =     MemPrim bt -instance (Substitute d, Substitute ret) => Rename (MemInfo d u ret) where+instance (Substitute d, Substitute ret) => Rename (MemInfo d o ret) where   rename = substituteRename  simplifyLMAD ::@@ -394,33 +384,33 @@  instance   (Engine.Simplifiable d, Engine.Simplifiable ret) =>-  Engine.Simplifiable (MemInfo d u ret)+  Engine.Simplifiable (MemInfo d o ret)   where   simplify (MemPrim bt) =     pure $ MemPrim bt   simplify (MemMem space) =     pure $ MemMem space-  simplify (MemArray bt shape u ret) =-    MemArray bt <$> Engine.simplify shape <*> pure u <*> Engine.simplify ret-  simplify (MemAcc acc ispace ts u) =-    MemAcc <$> Engine.simplify acc <*> Engine.simplify ispace <*> Engine.simplify ts <*> pure u+  simplify (MemArray bt shape o ret) =+    MemArray bt <$> Engine.simplify shape <*> pure o <*> Engine.simplify ret+  simplify (MemAcc acc ispace ts) =+    MemAcc <$> Engine.simplify acc <*> Engine.simplify ispace <*> Engine.simplify ts  instance   ( PP.Pretty (ShapeBase d),-    PP.Pretty (TypeBase (ShapeBase d) u),+    PP.Pretty (TypeBase (ShapeBase d) o),     PP.Pretty d,-    PP.Pretty u,+    PP.Pretty o,     PP.Pretty ret   ) =>-  PP.Pretty (MemInfo d u ret)+  PP.Pretty (MemInfo d o ret)   where   pretty (MemPrim bt) = PP.pretty bt   pretty (MemMem DefaultSpace) = "mem"   pretty (MemMem s) = "mem" <> PP.pretty s-  pretty (MemArray bt shape u ret) =-    PP.pretty (Array bt shape u) <+> "@" <+> PP.pretty ret-  pretty (MemAcc acc ispace ts u) =-    PP.pretty u <> PP.pretty (Acc acc ispace ts NoUniqueness :: Type)+  pretty (MemArray bt shape o ret) =+    PP.pretty (Array bt shape o) <+> "@" <+> PP.pretty ret+  pretty (MemAcc acc ispace ts) =+    PP.pretty (Acc acc ispace ts :: Type)  -- | Memory information for an array bound somewhere in the program. data MemBind@@ -555,50 +545,50 @@ -- whose entire purpose is to store an existing array in some -- arbitrary location.  This is a consequence of the design decision -- never to have implicit memory copies.-type ExpReturns = MemInfo ExtSize NoUniqueness (Maybe MemReturn)+type ExpReturns = MemInfo ExtSize NoMode (Maybe MemReturn)  -- | The return of a body, which must always indicate where -- returned arrays are located.-type BodyReturns = MemInfo ExtSize NoUniqueness MemReturn+type BodyReturns = MemInfo ExtSize NoMode MemReturn  -- | The memory return of a function, which must always indicate where -- returned arrays are located.-type FunReturns = MemInfo ExtSize Uniqueness MemReturn+type FunReturns = MemInfo ExtSize NoMode MemReturn -maybeReturns :: MemInfo d u r -> MemInfo d u (Maybe r)-maybeReturns (MemArray bt shape u ret) =-  MemArray bt shape u $ Just ret+maybeReturns :: MemInfo d o r -> MemInfo d o (Maybe r)+maybeReturns (MemArray bt shape o ret) =+  MemArray bt shape o $ Just ret maybeReturns (MemPrim bt) =   MemPrim bt maybeReturns (MemMem space) =   MemMem space-maybeReturns (MemAcc acc ispace ts u) =-  MemAcc acc ispace ts u+maybeReturns (MemAcc acc ispace ts) =+  MemAcc acc ispace ts -noUniquenessReturns :: MemInfo d u r -> MemInfo d NoUniqueness r-noUniquenessReturns (MemArray bt shape _ r) =-  MemArray bt shape NoUniqueness r-noUniquenessReturns (MemPrim bt) =+noModeReturns :: MemInfo d o r -> MemInfo d NoMode r+noModeReturns (MemArray bt shape _ r) =+  MemArray bt shape NoMode r+noModeReturns (MemPrim bt) =   MemPrim bt-noUniquenessReturns (MemMem space) =+noModeReturns (MemMem space) =   MemMem space-noUniquenessReturns (MemAcc acc ispace ts _) =-  MemAcc acc ispace ts NoUniqueness+noModeReturns (MemAcc acc ispace ts) =+  MemAcc acc ispace ts  funReturnsToExpReturns :: FunReturns -> ExpReturns-funReturnsToExpReturns = noUniquenessReturns . maybeReturns+funReturnsToExpReturns = noModeReturns . maybeReturns  bodyReturnsToExpReturns :: BodyReturns -> ExpReturns-bodyReturnsToExpReturns = noUniquenessReturns . maybeReturns+bodyReturnsToExpReturns = noModeReturns . maybeReturns -varInfoToExpReturns :: MemInfo SubExp NoUniqueness MemBind -> ExpReturns-varInfoToExpReturns (MemArray et shape u (ArrayIn mem lmad)) =-  MemArray et (fmap Free shape) u $+varInfoToExpReturns :: MemInfo SubExp NoMode MemBind -> ExpReturns+varInfoToExpReturns (MemArray et shape o (ArrayIn mem lmad)) =+  MemArray et (fmap Free shape) o $     Just $       ReturnsInBlock mem $         existentialiseLMAD [] lmad varInfoToExpReturns (MemPrim pt) = MemPrim pt-varInfoToExpReturns (MemAcc acc ispace ts u) = MemAcc acc ispace ts u+varInfoToExpReturns (MemAcc acc ispace ts) = MemAcc acc ispace ts varInfoToExpReturns (MemMem space) = MemMem space  matchRetTypeToResult ::@@ -662,14 +652,14 @@       MemPrim t     toRet (MemMem space) =       MemMem space-    toRet (MemAcc acc ispace ts u) =-      MemAcc acc ispace ts u-    toRet (MemArray pt shape u (ArrayIn mem lmad))+    toRet (MemAcc acc ispace ts) =+      MemAcc acc ispace ts+    toRet (MemArray pt shape _ (ArrayIn mem lmad))       | Just i <- mem `elemIndex` param_names,         Param _ _ (MemMem space) : _ <- drop i params =-          MemArray pt shape' u $ ReturnsNewBlock space i lmad'+          MemArray pt shape' NoMode $ ReturnsNewBlock space i lmad'       | otherwise =-          MemArray pt shape' u $ ReturnsInBlock mem lmad'+          MemArray pt shape' NoMode $ ReturnsInBlock mem lmad'       where         shape' = fmap toExtSE shape         lmad' = existentialiseLMAD param_names lmad@@ -713,10 +703,10 @@   )  matchReturnType ::-  (PP.Pretty u) =>-  [MemInfo ExtSize u MemReturn] ->+  (PP.Pretty o) =>+  [MemInfo ExtSize o MemReturn] ->   [SubExp] ->-  [MemInfo SubExp NoUniqueness MemBind] ->+  [MemInfo SubExp NoMode MemBind] ->   TC.TypeM rep () matchReturnType rettype res ts = do   let existentialiseLMAD0 :: LMAD -> ExtLMAD@@ -731,7 +721,7 @@         | x == y = pure ()       checkReturn (MemMem x) (MemMem y)         | x == y = pure ()-      checkReturn (MemAcc xacc xispace xts _) (MemAcc yacc yispace yts _)+      checkReturn (MemAcc xacc xispace xts) (MemAcc yacc yispace yts)         | (xacc, xispace, xts) == (yacc, yispace, yts) =             pure ()       checkReturn@@ -842,7 +832,7 @@     matches _ _ (MemPrim x) (MemPrim y) = x == y     matches _ _ (MemMem x_space) (MemMem y_space) =       x_space == y_space-    matches _ _ (MemAcc x_accs x_ispace x_ts _) (MemAcc y_accs y_ispace y_ts _) =+    matches _ _ (MemAcc x_accs x_ispace x_ts) (MemAcc y_accs y_ispace y_ts) =       (x_accs, x_ispace, x_ts) == (y_accs, y_ispace, y_ts)     matches ctxids ctxexts (MemArray x_pt x_shape _ x_ret) (MemArray y_pt y_shape _ y_ret) =       x_pt == y_pt@@ -871,21 +861,21 @@ varMemInfo ::   (Mem rep inner) =>   VName ->-  TC.TypeM rep (MemInfo SubExp NoUniqueness MemBind)+  TC.TypeM rep (MemInfo SubExp NoMode MemBind) varMemInfo name = do   dec <- TC.lookupVar name    case dec of     LetName (_, summary) -> pure $ letDecMem summary-    FParamName summary -> pure $ noUniquenessReturns summary+    FParamName summary -> pure $ noModeReturns summary     LParamName summary -> pure summary     IndexName it -> pure $ MemPrim $ IntType it  -- | Turn info into memory information.-nameInfoToMemInfo :: (Mem rep inner) => NameInfo rep -> MemBound NoUniqueness+nameInfoToMemInfo :: (Mem rep inner) => NameInfo rep -> MemBound NoMode nameInfoToMemInfo info =   case info of-    FParamName summary -> noUniquenessReturns summary+    FParamName summary -> noModeReturns summary     LParamName summary -> summary     LetName summary -> letDecMem summary     IndexName it -> MemPrim $ IntType it@@ -894,13 +884,13 @@ lookupMemInfo ::   (HasScope rep m, Mem rep inner) =>   VName ->-  m (MemInfo SubExp NoUniqueness MemBind)+  m (MemInfo SubExp NoMode MemBind) lookupMemInfo = fmap nameInfoToMemInfo . lookupInfo  subExpMemInfo ::   (HasScope rep m, Mem rep inner) =>   SubExp ->-  m (MemInfo SubExp NoUniqueness MemBind)+  m (MemInfo SubExp NoMode MemBind) subExpMemInfo (Var v) = lookupMemInfo v subExpMemInfo (Constant v) = pure $ MemPrim $ primValueType v @@ -939,13 +929,13 @@ checkMemInfo ::   (TC.Checkable rep) =>   VName ->-  MemInfo SubExp u MemBind ->+  MemInfo SubExp o MemBind ->   TC.TypeM rep () checkMemInfo _ (MemPrim _) = pure () checkMemInfo _ (MemMem (ScalarSpace d _)) = mapM_ (TC.require (Prim int64)) d checkMemInfo _ (MemMem _) = pure ()-checkMemInfo _ (MemAcc acc ispace ts u) =-  TC.checkType $ Acc acc ispace ts u+checkMemInfo _ (MemAcc acc ispace ts) =+  TC.checkType $ Acc acc ispace ts checkMemInfo name (MemArray _ shape _ (ArrayIn v lmad)) = do   t <- lookupType v   case t of@@ -974,7 +964,7 @@             <> ")"  bodyReturnsFromPat ::-  Pat (MemBound NoUniqueness) -> [(VName, BodyReturns)]+  Pat (MemBound NoMode) -> [(VName, BodyReturns)] bodyReturnsFromPat pat =   map asReturns $ patElems pat   where@@ -990,14 +980,14 @@         case patElemDec pe of           MemPrim pt -> MemPrim pt           MemMem space -> MemMem space-          MemArray pt shape u (ArrayIn mem lmad) ->-            MemArray pt (Shape $ map ext $ shapeDims shape) u $+          MemArray pt shape o (ArrayIn mem lmad) ->+            MemArray pt (Shape $ map ext $ shapeDims shape) o $               case find ((== mem) . patElemName . snd) $ zip [0 ..] ctx of                 Just (i, PatElem _ (MemMem space)) ->                   ReturnsNewBlock space i $                     existentialiseLMAD (map patElemName ctx) lmad                 _ -> ReturnsInBlock mem $ existentialiseLMAD [] lmad-          MemAcc acc ispace ts u -> MemAcc acc ispace ts u+          MemAcc acc ispace ts -> MemAcc acc ispace ts       )  extReturns :: [ExtType] -> [ExpReturns]@@ -1008,16 +998,16 @@       pure $ MemPrim bt     addDec (Mem space) =       pure $ MemMem space-    addDec t@(Array bt shape u)+    addDec t@(Array bt shape o)       | existential t = do           i <- get <* modify (+ 1)-          pure . MemArray bt shape u . Just $+          pure . MemArray bt shape o . Just $             ReturnsNewBlock DefaultSpace i $               LMAD.iota 0 (map convert $ shapeDims shape)       | otherwise =-          pure $ MemArray bt shape u Nothing-    addDec (Acc acc ispace ts u) =-      pure $ MemAcc acc ispace ts u+          pure $ MemArray bt shape o Nothing+    addDec (Acc acc ispace ts) =+      pure $ MemAcc acc ispace ts     convert (Ext i) = le64 (Ext i)     convert (Free v) = Free <$> pe64 v @@ -1044,14 +1034,14 @@       pure $ MemPrim bt     MemArray et shape _ (ArrayIn mem lmad) ->       pure $-        MemArray et (fmap Free shape) NoUniqueness $+        MemArray et (fmap Free shape) NoMode $           Just $             ReturnsInBlock mem $               existentialiseLMAD [] lmad     MemMem space ->       pure $ MemMem space-    MemAcc acc ispace ts u ->-      pure $ MemAcc acc ispace ts u+    MemAcc acc ispace ts ->+      pure $ MemAcc acc ispace ts  subExpReturns :: (HasScope rep m, Monad m, Mem rep inner) => SubExp -> m ExpReturns subExpReturns (Var v) =@@ -1077,7 +1067,7 @@   case reshaper (reshapeKind newshape) lmad $ map pe64 $ shapeDims $ newShape newshape of     Just lmad' ->       pure . Just $-        [ MemArray et (Free <$> newShape newshape) NoUniqueness . Just $+        [ MemArray et (Free <$> newShape newshape) NoMode . Just $             ReturnsInBlock mem (existentialiseLMAD [] lmad')         ]     Nothing -> pure Nothing@@ -1092,7 +1082,7 @@       dims' = rearrangeShape perm dims   pure $     Just-      [ MemArray et (Shape $ map Free dims') NoUniqueness $+      [ MemArray et (Shape $ map Free dims') NoMode $           Just $             ReturnsInBlock mem $               existentialiseLMAD [] lmad'@@ -1113,20 +1103,20 @@   where     typeWithDec t p =       case (t, paramDec p) of-        ( Array pt shape u,+        ( Array pt shape o,           MemArray _ _ _ (ArrayIn mem lmad)           )             | Just (i, mem_p) <- isLoopVar mem,               Mem space <- paramType mem_p ->-                pure $ MemArray pt shape u $ Just $ ReturnsNewBlock space i lmad'+                pure $ MemArray pt shape o $ Just $ ReturnsNewBlock space i lmad'             | otherwise ->-                pure $ MemArray pt shape u $ Just $ ReturnsInBlock mem lmad'+                pure $ MemArray pt shape o $ Just $ ReturnsInBlock mem lmad'             where               lmad' = existentialiseLMAD (map paramName mergevars) lmad         (Array {}, _) ->           error "expReturns: Array return type but not array merge variable."-        (Acc acc ispace ts u, _) ->-          pure $ MemAcc acc ispace ts u+        (Acc acc ispace ts, _) ->+          pure $ MemAcc acc ispace ts         (Prim pt, _) ->           pure $ MemPrim pt         (Mem space, _) ->@@ -1156,27 +1146,27 @@   (Monad m, HasScope rep m, Mem rep inner) =>   VName ->   Slice SubExp ->-  m (MemInfo SubExp NoUniqueness MemBind)+  m (MemInfo SubExp NoMode MemBind) sliceInfo v slice = do   (et, _, mem, lmad) <- arrayVarReturns v   case sliceDims slice of     [] -> pure $ MemPrim et     dims ->       pure $-        MemArray et (Shape dims) NoUniqueness . ArrayIn mem $+        MemArray et (Shape dims) NoMode . ArrayIn mem $           LMAD.slice lmad (fmap pe64 slice)  flatSliceInfo ::   (Monad m, HasScope rep m, Mem rep inner) =>   VName ->   FlatSlice SubExp ->-  m (MemInfo SubExp NoUniqueness MemBind)+  m (MemInfo SubExp NoMode MemBind) flatSliceInfo v slice@(FlatSlice offset idxs) = do   (et, _, mem, lmad) <- arrayVarReturns v   map (fmap pe64) idxs     & FlatSlice (pe64 offset)     & LMAD.flatSlice lmad-    & MemArray et (Shape (flatSliceDims slice)) NoUniqueness . ArrayIn mem+    & MemArray et (Shape (flatSliceDims slice)) NoMode . ArrayIn mem     & pure  class (IsOp op) => OpReturns op where@@ -1192,7 +1182,7 @@       MemArray et shape _ _ ->         pure           [ MemMem space,-            MemArray et (fmap Free shape) NoUniqueness . Just $+            MemArray et (fmap Free shape) NoMode . Just $               ReturnsNewBlock space 0 . LMAD.iota 0 $                 fmap (fmap Free . pe64) (shapeDims shape)           ]@@ -1214,7 +1204,7 @@   | otherwise =       Nothing   where-    rettype = map declExtTypeOf rets+    rettype = map extTypeOf rets     parammap :: M.Map VName (SubExp, Type)     parammap =       M.fromList $@@ -1228,11 +1218,11 @@       MemPrim t     correctDims (MemMem space) =       MemMem space-    correctDims (MemArray et shape u memsummary) =-      MemArray et (correctShape shape) u $+    correctDims (MemArray et shape o memsummary) =+      MemArray et (correctShape shape) o $         correctSummary memsummary-    correctDims (MemAcc acc ispace ts u) =-      MemAcc acc ispace ts u+    correctDims (MemAcc acc ispace ts) =+      MemAcc acc ispace ts      correctShape = Shape . map correctDim . shapeDims     correctDim (Ext i) = Ext i
src/Futhark/IR/Mem/Simplify.hs view
@@ -138,10 +138,10 @@     Just (Manifest v0 perm, v1_cs) <- ST.lookupBasicOp v1 vtable,     Pat [PatElem _ (_, MemArray _ _ _ (ArrayIn mem _))] <- pat =       Simplify $ do-        ~(MemArray pt shape u (ArrayIn _ v1_lmad)) <- lookupMemInfo v1+        ~(MemArray pt shape o (ArrayIn _ v1_lmad)) <- lookupMemInfo v1         v0' <- newVName (baseName v1 <> "_manifest")         let manifest_pat =-              Pat [PatElem v0' $ MemArray pt shape u $ ArrayIn mem v1_lmad]+              Pat [PatElem v0' $ MemArray pt shape o $ ArrayIn mem v1_lmad]             stm = mkWiseStm manifest_pat mempty $ BasicOp $ Manifest v0 perm         certifying (v1_cs <> v2_cs) $ addStm stm         auxing aux $ letBind pat $ BasicOp $ Reshape v0' s
src/Futhark/IR/Parse.hs view
@@ -11,8 +11,9 @@      -- * Representation-agnostic fragments     parseType,-    parseDeclExtType,     parseDeclType,+    parseDeclExtType,+    parseExtType,     parseVName,     parseSubExp,     parseSubExpRes,@@ -103,7 +104,7 @@ pAsterisk = void $ lexeme "*" pArrow = void $ lexeme "->" -pNonArray :: Parser (TypeBase shape NoUniqueness)+pNonArray :: Parser (TypeBase shape NoMode) pNonArray =   choice     [ Prim <$> pPrimType,@@ -115,19 +116,18 @@               <*> pShape               <* pComma               <*> pTypes-              <*> pure NoUniqueness           )     ]  pTypeBase ::   (ArrayShape shape) =>   Parser shape ->-  Parser u ->-  Parser (TypeBase shape u)-pTypeBase ps pu = do-  u <- pu+  Parser o ->+  Parser (TypeBase shape o)+pTypeBase ps po = do+  o <- po   shape <- ps-  arrayOf <$> pNonArray <*> pure shape <*> pure u+  arrayOf <$> pNonArray <*> pure shape <*> pure o  pShape :: Parser Shape pShape = Shape <$> many (brackets pSubExp)@@ -146,13 +146,13 @@ pExtShape = Shape <$> many (brackets pExtSize)  pType :: Parser Type-pType = pTypeBase pShape (pure NoUniqueness)+pType = pTypeBase pShape (pure NoMode)  pTypes :: Parser [Type] pTypes = braces $ pType `sepBy` pComma  pExtType :: Parser ExtType-pExtType = pTypeBase pExtShape (pure NoUniqueness)+pExtType = pTypeBase pExtShape (pure NoMode)  pExtTypes :: Parser [ExtType] pExtTypes = braces $ pExtType `sepBy` pComma@@ -160,20 +160,20 @@ pRank :: Parser Rank pRank = Rank . length <$> many (lexeme "[" *> lexeme "]") -pUniqueness :: Parser Uniqueness-pUniqueness = choice [pAsterisk $> Unique, pure Nonunique]+pDiet :: Parser Diet+pDiet = choice [pAsterisk $> Consume, pure Observe]  pDeclBase ::-  Parser (TypeBase shape NoUniqueness) ->-  Parser (TypeBase shape Uniqueness)-pDeclBase p = flip toDecl <$> pUniqueness <*> p--pDeclType :: Parser DeclType-pDeclType = pDeclBase pType+  Parser (TypeBase shape NoMode) ->+  Parser (TypeBase shape Diet)+pDeclBase p = flip toDecl <$> pDiet <*> p  pDeclExtType :: Parser DeclExtType pDeclExtType = pDeclBase pExtType +pDeclType :: Parser DeclType+pDeclType = pDeclBase pType+ pSubExp :: Parser SubExp pSubExp = Var <$> pVName <|> Constant <$> pPrimValue @@ -688,9 +688,9 @@   where     pEntryPointInputs = braces (pEntryPointInput `sepBy` pComma)     pEntryPointInput =-      EntryParam <$> pName <* pColon <*> pUniqueness <*> pEntryPointType+      EntryParam <$> pName <* pColon <*> pDiet <*> pEntryPointType     pEntryPointResult =-      EntryResult <$> pUniqueness <*> pEntryPointType+      EntryResult <$> pDiet <*> pEntryPointType  pFunDef :: PR rep -> Parser (FunDef rep) pFunDef pr = do@@ -1094,8 +1094,8 @@ pExtLMAD :: Parser ExtLMAD pExtLMAD = pLMADBase $ isInt64 <$> pPrimExp int64 pExtPrimExpLeaf -pMemInfo :: Parser d -> Parser u -> Parser ret -> Parser (MemInfo d u ret)-pMemInfo pd pu pret =+pMemInfo :: Parser d -> Parser o -> Parser ret -> Parser (MemInfo d o ret)+pMemInfo pd po pret =   choice     [ MemPrim <$> pPrimType,       keyword "mem" $> MemMem <*> choice [pSpace, pure DefaultSpace],@@ -1103,13 +1103,13 @@     ]   where     pArrayOrAcc = do-      u <- pu+      o <- po       shape <- Shape <$> many (brackets pd)-      choice [pArray u shape, pAcc u]-    pArray u shape = do+      choice [pArray o shape, pAcc]+    pArray o shape = do       pt <- pPrimType-      MemArray pt shape u <$> (lexeme "@" *> pret)-    pAcc u =+      MemArray pt shape o <$> (lexeme "@" *> pret)+    pAcc =       keyword "acc"         *> parens           ( MemAcc@@ -1118,7 +1118,6 @@               <*> pShape               <* pComma               <*> pTypes-              <*> pure u           )  pSpace :: Parser Space@@ -1143,19 +1142,19 @@     ]  pRetTypeMem :: Parser RetTypeMem-pRetTypeMem = pMemInfo pExtSize pUniqueness pMemReturn+pRetTypeMem = pMemInfo pExtSize (pure NoMode) pMemReturn  pBranchTypeMem :: Parser BranchTypeMem-pBranchTypeMem = pMemInfo pExtSize (pure NoUniqueness) pMemReturn+pBranchTypeMem = pMemInfo pExtSize (pure NoMode) pMemReturn  pFParamMem :: Parser FParamMem-pFParamMem = pMemInfo pSubExp pUniqueness pMemBind+pFParamMem = pMemInfo pSubExp pDiet pMemBind  pLParamMem :: Parser LParamMem-pLParamMem = pMemInfo pSubExp (pure NoUniqueness) pMemBind+pLParamMem = pMemInfo pSubExp (pure NoMode) pMemBind  pLetDecMem :: Parser LetDecMem-pLetDecMem = pMemInfo pSubExp (pure NoUniqueness) pMemBind+pLetDecMem = pMemInfo pSubExp (pure NoMode) pMemBind  pMemOp :: Parser (inner rep) -> Parser (MemOp inner rep) pMemOp pInner =@@ -1170,11 +1169,11 @@  prSOACS :: PR SOACS prSOACS =-  PR pDeclExtType pExtType pDeclType pType pType (pSOAC prSOACS) () ()+  PR pExtType pExtType pDeclType pType pType (pSOAC prSOACS) () ()  prSeq :: PR Seq prSeq =-  PR pDeclExtType pExtType pDeclType pType pType empty () ()+  PR pExtType pExtType pDeclType pType pType empty () ()  prSeqMem :: PR SeqMem prSeqMem =@@ -1184,7 +1183,7 @@  prGPU :: PR GPU prGPU =-  PR pDeclExtType pExtType pDeclType pType pType op () ()+  PR pExtType pExtType pDeclType pType pType op () ()   where     op = pHostOp prGPU (pSOAC prGPU) @@ -1196,7 +1195,7 @@  prMC :: PR MC prMC =-  PR pDeclExtType pExtType pDeclType pType pType op () ()+  PR pExtType pExtType pDeclType pType pType op () ()   where     op = pMCOp prMC (pSOAC prMC) @@ -1242,6 +1241,9 @@  parseDeclExtType :: FilePath -> T.Text -> Either T.Text DeclExtType parseDeclExtType = parseFull pDeclExtType++parseExtType :: FilePath -> T.Text -> Either T.Text ExtType+parseExtType = parseFull pExtType  parseDeclType :: FilePath -> T.Text -> Either T.Text DeclType parseDeclType = parseFull pDeclType
src/Futhark/IR/Pretty.hs view
@@ -44,6 +44,10 @@   pretty Commutative = "commutative"   pretty Noncommutative = "noncommutative" +instance Pretty Diet where+  pretty Consume = "*"+  pretty Observe = mempty+ instance (Pretty d) => Pretty (ShapeBase d) where   pretty = mconcat . map (brackets . pretty) . shapeDims @@ -59,46 +63,43 @@   pretty (Space s) = "@" <> pretty s   pretty (ScalarSpace d t) = "@" <> mconcat (map (brackets . pretty) d) <> pretty t -instance (Pretty u) => Pretty (TypeBase Shape u) where+instance (Pretty o) => Pretty (TypeBase Shape o) where   pretty (Prim t) = pretty t-  pretty (Acc acc ispace ts u) =-    pretty u-      <> "acc"+  pretty (Acc acc ispace ts) =+    "acc"       <> apply         [ pretty acc,           pretty ispace,           ppTuple' $ map pretty ts         ]-  pretty (Array et (Shape ds) u) =-    pretty u <> mconcat (map (brackets . pretty) ds) <> pretty et+  pretty (Array et (Shape ds) o) =+    pretty o <> mconcat (map (brackets . pretty) ds) <> pretty et   pretty (Mem s) = "mem" <> pretty s -instance (Pretty u) => Pretty (TypeBase ExtShape u) where+instance (Pretty o) => Pretty (TypeBase ExtShape o) where   pretty (Prim t) = pretty t-  pretty (Acc acc ispace ts u) =-    pretty u-      <> "acc"+  pretty (Acc acc ispace ts) =+    "acc"       <> apply         [ pretty acc,           pretty ispace,           ppTuple' $ map pretty ts         ]-  pretty (Array et (Shape ds) u) =-    pretty u <> mconcat (map (brackets . pretty) ds) <> pretty et+  pretty (Array et (Shape ds) o) =+    pretty o <> mconcat (map (brackets . pretty) ds) <> pretty et   pretty (Mem s) = "mem" <> pretty s -instance (Pretty u) => Pretty (TypeBase Rank u) where+instance (Pretty o) => Pretty (TypeBase Rank o) where   pretty (Prim t) = pretty t-  pretty (Acc acc ispace ts u) =-    pretty u-      <> "acc"+  pretty (Acc acc ispace ts) =+    "acc"       <> apply         [ pretty acc,           pretty ispace,           ppTuple' $ map pretty ts         ]-  pretty (Array et (Rank n) u) =-    pretty u <> mconcat (replicate n $ brackets mempty) <> pretty et+  pretty (Array et (Rank n) o) =+    pretty o <> mconcat (replicate n $ brackets mempty) <> pretty et   pretty (Mem s) = "mem" <> pretty s  instance Pretty Ident where@@ -398,10 +399,10 @@   pretty (TypeOpaque desc) = "opaque" <+> dquotes (pretty desc)  instance Pretty EntryParam where-  pretty (EntryParam name u t) = pretty name <> colon <+> pretty u <> pretty t+  pretty (EntryParam name o t) = pretty name <> colon <+> pretty o <> pretty t  instance Pretty EntryResult where-  pretty (EntryResult u t) = pretty u <> pretty t+  pretty (EntryResult o t) = pretty o <> pretty t  instance (PrettyRep rep) => Pretty (FunDef rep) where   pretty (FunDef entry attrs name rettype fparams body) =
src/Futhark/IR/Prop.hs view
@@ -105,21 +105,21 @@ safeExp (BasicOp op) = safeBasicOp op   where     safeBasicOp (BinOp (SDiv _ Safe) _ _) = True-    safeBasicOp (BinOp (SDivUp _ Safe) _ _) = True+    safeBasicOp (BinOp (SCeilDiv _ Safe) _ _) = True     safeBasicOp (BinOp (SQuot _ Safe) _ _) = True     safeBasicOp (BinOp (UDiv _ Safe) _ _) = True-    safeBasicOp (BinOp (UDivUp _ Safe) _ _) = True+    safeBasicOp (BinOp (UCeilDiv _ Safe) _ _) = True     safeBasicOp (BinOp (SMod _ Safe) _ _) = True     safeBasicOp (BinOp (SRem _ Safe) _ _) = True     safeBasicOp (BinOp (UMod _ Safe) _ _) = True     safeBasicOp (BinOp SDiv {} _ (Constant y)) = not $ zeroIsh y     safeBasicOp (BinOp SDiv {} _ _) = False-    safeBasicOp (BinOp SDivUp {} _ (Constant y)) = not $ zeroIsh y-    safeBasicOp (BinOp SDivUp {} _ _) = False+    safeBasicOp (BinOp SCeilDiv {} _ (Constant y)) = not $ zeroIsh y+    safeBasicOp (BinOp SCeilDiv {} _ _) = False     safeBasicOp (BinOp UDiv {} _ (Constant y)) = not $ zeroIsh y     safeBasicOp (BinOp UDiv {} _ _) = False-    safeBasicOp (BinOp UDivUp {} _ (Constant y)) = not $ zeroIsh y-    safeBasicOp (BinOp UDivUp {} _ _) = False+    safeBasicOp (BinOp UCeilDiv {} _ (Constant y)) = not $ zeroIsh y+    safeBasicOp (BinOp UCeilDiv {} _ _) = False     safeBasicOp (BinOp SMod {} _ (Constant y)) = not $ zeroIsh y     safeBasicOp (BinOp SMod {} _ _) = False     safeBasicOp (BinOp UMod {} _ (Constant y)) = not $ zeroIsh y
src/Futhark/IR/Prop/Aliases.hs view
@@ -88,7 +88,7 @@ funcallAliases ::   [PatElem dec] ->   [(SubExp, Diet)] ->-  [(TypeBase shape Uniqueness, RetAls)] ->+  [(TypeBase shape NoMode, RetAls)] ->   [Names] funcallAliases pes args = map onType   where@@ -138,7 +138,7 @@   mutualAliases (bound <> param_names) pes $ do     (p, als) <-       transitive . zip params $ zipWith (<>) arg_aliases (bodyAliases loopbody)-    if unique $ paramDeclType p+    if consuming $ paramDeclType p       then pure mempty       else pure als   where@@ -155,7 +155,7 @@         look v = maybe mempty snd $ find ((== v) . paramName . fst) merge_and_als         expand als = als <> foldMap look (namesToList als) expAliases pes (Apply _ args t _) =-  funcallAliases pes args $ map (first declExtTypeOf) t+  funcallAliases pes args $ map (first extTypeOf) t expAliases _ (WithAcc inputs lam) =   concatMap inputAliases inputs     ++ drop num_accs (map (`namesSubtract` boundInBody body) $ bodyAliases body)@@ -181,7 +181,7 @@ consumedInExp (Loop merge _ _) =   mconcat     ( map (subExpAliases . snd) $-        filter (unique . paramDeclType . fst) merge+        filter (consuming . paramDeclType . fst) merge     ) consumedInExp (WithAcc inputs lam) =   mconcat (map inputConsumed inputs)
src/Futhark/IR/Prop/Names.hs view
@@ -10,6 +10,7 @@     namesIntMap,     namesIntSet,     nameIn,+    namesNull,     notNameIn,     oneName,     namesFromList,@@ -49,7 +50,6 @@ import Data.IntSet qualified as IS import Data.Map.Strict qualified as M import Data.Set qualified as S-import Futhark.IR.Prop.Pat import Futhark.IR.Syntax import Futhark.IR.Traversals import Futhark.Util.Pretty@@ -80,6 +80,10 @@ instance Pretty Names where   pretty = pretty . namesToList +-- | Is the set of names empty?+namesNull :: Names -> Bool+namesNull (Names vs) = IM.null vs+ -- | Does the set of names contain this name? nameIn :: VName -> Names -> Bool nameIn v (Names vs) = baseTag v `IM.member` vs@@ -90,7 +94,9 @@  -- | Construct a name set from a list.  Slow. namesFromList :: [VName] -> Names-namesFromList vs = Names $ IM.fromList $ zip (map baseTag vs) vs+namesFromList = Names . foldl' insert IM.empty+  where+    insert m v = IM.insert (baseTag v) v m  -- | Turn a name set into a list of names.  Slow. namesToList :: Names -> [VName]@@ -363,11 +369,11 @@ instance FreeIn PrimType where   freeIn' _ = mempty -instance (FreeIn shape) => FreeIn (TypeBase shape u) where+instance (FreeIn shape) => FreeIn (TypeBase shape o) where   freeIn' (Array t shape _) = freeIn' t <> freeIn' shape   freeIn' (Mem s) = freeIn' s   freeIn' Prim {} = mempty-  freeIn' (Acc acc ispace ts _) = freeIn' (acc, ispace, ts)+  freeIn' (Acc acc ispace ts) = freeIn' (acc, ispace, ts)  instance (FreeIn dec) => FreeIn (Param dec) where   freeIn' (Param attrs _ dec) = freeIn' attrs <> freeIn' dec@@ -441,7 +447,9 @@  -- | The names bound by a binding. boundByStm :: Stm rep -> Names-boundByStm = namesFromList . patNames . stmPat+boundByStm = Names . foldl' insert IM.empty . patElems . stmPat+  where+    insert m pe = IM.insert (baseTag (patElemName pe)) (patElemName pe) m  -- | The names bound by the bindings. boundByStms :: Stms rep -> Names
src/Futhark/IR/Prop/Reshape.hs view
@@ -19,6 +19,7 @@      -- * Shape calculations     reshapeIndex,+    unreshapeSlice,     flattenIndex,     unflattenIndex,     sliceSizes,@@ -30,7 +31,7 @@   ) where -import Control.Monad (guard, mplus)+import Control.Monad (foldM, guard, mplus) import Data.Foldable import Data.Maybe import Futhark.IR.Prop.Rearrange (isMapTranspose, rearrangeInverse, rearrangeShape)@@ -92,6 +93,41 @@ reshapeIndex to_dims from_dims is =   unflattenIndex to_dims $ flattenIndex from_dims is +-- | @unreshapeSlice shape newshape slice@ transforms @slice@, which is a+-- slice of an array of shape @shape@ that has been reshaped with+-- @newshape@, into an equivalent slice of the original array. This is done+-- one splice at a time (working backwards), which requires that the+-- dimensions produced by each splice are all indexed with 'DimFix', unless+-- the splice is a coercion. As a consequence, indexing an unflattened+-- dimension requires no division, and indexing a flattened dimension+-- requires only division by the sizes of the dimensions that were+-- flattened. Returns 'Nothing' if the slice cannot be transformed. The+-- slice must be of the same length as the rank of @newshape@.+unreshapeSlice ::+  (IntegralExp num) =>+  ShapeBase num ->+  NewShape num ->+  [DimIndex num] ->+  Maybe [DimIndex num]+unreshapeSlice shape (NewShape ss _) slice =+  foldM onSplice slice $ reverse $ zip (scanl applySplice shape ss) ss+  where+    onSplice is (shape_bef, DimSplice i k s)+      -- A coercion does not change the index space.+      | k == 1,+        shapeRank s == 1 =+          Just is+      | (is_bef, is') <- splitAt i is,+        (is_s, is_aft) <- splitAt (shapeRank s) is',+        length is_s == shapeRank s,+        Just js <- mapM dimFix is_s =+          let flat = flattenIndex (shapeDims s) js+              js'+                | k == 1 = [flat]+                | otherwise = unflattenIndex (take k $ drop i $ shapeDims shape_bef) flat+           in Just $ is_bef ++ map DimFix js' ++ is_aft+      | otherwise = Nothing+ -- | @unflattenIndex dims i@ computes a list of indices into an array -- with dimension @dims@ given the flat index @i@.  The resulting list -- will have the same size as @dims@.@@ -171,7 +207,9 @@       num_b_dims_expanded = length v0_shape - num_map_dims - num_a_dims       num_a_dims_expanded = length v0_shape - num_map_dims - num_b_dims       caseA = do-        guard $ take num_a_dims v0_shape == take num_b_dims v1_shape+        guard $+          take num_a_dims (drop num_map_dims v0_shape)+            == take num_b_dims (drop num_map_dims v1_shape)         let perm' =               [0 .. num_map_dims - 1]                 ++ map (+ num_map_dims) ([1 .. num_b_dims_expanded] ++ [0])@@ -298,8 +336,9 @@       Just $ DimSplice i2 n2 s2 : ss -- -- A flatten with an inverse unflatten turns into nothing.-move (shape_bef, DimSplice i1 n1 _s1) (DimSplice i2 _n2 s2 : ss)+move (shape_bef, DimSplice i1 n1 s1) (DimSplice i2 n2 s2 : ss)   | i1 == i2,+    length s1 == n2,     dimSpan i1 n1 shape_bef == s2 =       Just ss --
src/Futhark/IR/Prop/TypeOf.hs view
@@ -53,7 +53,7 @@ -- element of @arrts@. mapType :: SubExp -> Lambda rep -> [Type] mapType outersize f =-  [ arrayOf t (Shape [outersize]) NoUniqueness+  [ arrayOf t (Shape [outersize]) NoMode   | t <- lambdaReturnType f   ] @@ -64,11 +64,11 @@ basicOpType (Opaque _ se) =   pure <$> subExpType se basicOpType (ArrayVal vs t) =-  pure [arrayOf (Prim t) (Shape [n]) NoUniqueness]+  pure [arrayOf (Prim t) (Shape [n]) NoMode]   where     n = intConst Int64 $ toInteger $ length vs basicOpType (ArrayLit es rt) =-  pure [arrayOf rt (Shape [n]) NoUniqueness]+  pure [arrayOf rt (Shape [n]) NoMode]   where     n = intConst Int64 $ toInteger $ length es basicOpType (BinOp bop _ _) =@@ -94,13 +94,13 @@ basicOpType (FlatUpdate src _ _) =   pure <$> lookupType src basicOpType (Iota n _ _ et) =-  pure [arrayOf (Prim (IntType et)) (Shape [n]) NoUniqueness]+  pure [arrayOf (Prim (IntType et)) (Shape [n]) NoMode] basicOpType (Replicate (Shape []) e) =   pure <$> subExpType e basicOpType (Replicate shape e) =   pure . flip arrayOfShape shape <$> subExpType e basicOpType (Scratch t shape) =-  pure [arrayOf (Prim t) (Shape shape) NoUniqueness]+  pure [arrayOf (Prim t) (Shape shape) NoMode] basicOpType (Reshape e shape) =   result <$> lookupType e   where@@ -126,7 +126,7 @@   (HasScope rep m, TypedOp (OpC rep)) =>   Exp rep ->   m [ExtType]-expExtType (Apply _ _ rt _) = pure $ map (fromDecl . declExtTypeOf . fst) rt+expExtType (Apply _ _ rt _) = pure $ map (extTypeOf . fst) rt expExtType (Match _ _ _ rt) = pure $ map extTypeOf $ matchReturns rt expExtType (Loop merge _ _) =   pure $ loopExtType $ map fst merge
src/Futhark/IR/Prop/Types.hs view
@@ -6,8 +6,7 @@     setArrayShape,     isEmptyArray,     existential,-    uniqueness,-    unique,+    consuming,     staticShapes,     staticShapes1,     primType,@@ -58,7 +57,6 @@     Typed (..),     DeclTyped (..),     ExtTyped (..),-    DeclExtTyped (..),     FixExt (..),   ) where@@ -74,21 +72,21 @@ import Futhark.IR.Syntax.Core  -- | Remove shape information from a type.-rankShaped :: (ArrayShape shape) => TypeBase shape u -> TypeBase Rank u-rankShaped (Array et sz u) = Array et (Rank $ shapeRank sz) u+rankShaped :: (ArrayShape shape) => TypeBase shape o -> TypeBase Rank o+rankShaped (Array et sz o) = Array et (Rank $ shapeRank sz) o rankShaped (Prim pt) = Prim pt-rankShaped (Acc acc ispace ts u) = Acc acc ispace ts u+rankShaped (Acc acc ispace ts) = Acc acc ispace ts rankShaped (Mem space) = Mem space  -- | Return the dimensionality of a type.  For non-arrays, this is -- zero.  For a one-dimensional array it is one, for a two-dimensional -- it is two, and so forth.-arrayRank :: (ArrayShape shape) => TypeBase shape u -> Int+arrayRank :: (ArrayShape shape) => TypeBase shape o -> Int arrayRank = shapeRank . arrayShape  -- | Return the shape of a type - for non-arrays, this is the -- 'mempty'.-arrayShape :: (ArrayShape shape) => TypeBase shape u -> shape+arrayShape :: (ArrayShape shape) => TypeBase shape o -> shape arrayShape (Array _ ds _) = ds arrayShape _ = mempty @@ -96,24 +94,24 @@ modifyArrayShape ::   (ArrayShape newshape) =>   (oldshape -> newshape) ->-  TypeBase oldshape u ->-  TypeBase newshape u-modifyArrayShape f (Array t ds u)+  TypeBase oldshape o ->+  TypeBase newshape o+modifyArrayShape f (Array t ds o)   | shapeRank ds' == 0 = Prim t-  | otherwise = Array t ds' u+  | otherwise = Array t ds' o   where     ds' = f ds modifyArrayShape _ (Prim t) = Prim t-modifyArrayShape _ (Acc acc ispace ts u) = Acc acc ispace ts u+modifyArrayShape _ (Acc acc ispace ts) = Acc acc ispace ts modifyArrayShape _ (Mem space) = Mem space  -- | Set the shape of an array.  If the given type is not an -- array, return the type unchanged. setArrayShape ::   (ArrayShape newshape) =>-  TypeBase oldshape u ->+  TypeBase oldshape o ->   newshape ->-  TypeBase newshape u+  TypeBase newshape o setArrayShape t ds = modifyArrayShape (const ds) t  -- | If the array is statically an empty array (meaning any dimension@@ -130,54 +128,48 @@     ext (Ext _) = True     ext (Free _) = False --- | Return the uniqueness of a type.-uniqueness :: TypeBase shape Uniqueness -> Uniqueness-uniqueness (Array _ _ u) = u-uniqueness (Acc _ _ _ u) = u-uniqueness _ = Nonunique---- | @unique t@ is 'True' if the type of the argument is unique.-unique :: TypeBase shape Uniqueness -> Bool-unique = (== Unique) . uniqueness+-- | @consuming t@ is 'True' if a parameter of this type consumes its+-- argument.+consuming :: TypeBase shape Diet -> Bool+consuming = (== Consume) . diet  -- | Convert types with non-existential shapes to types with -- existential shapes.  Only the representation is changed, so all -- the shapes will be 'Free'.-staticShapes :: [TypeBase Shape u] -> [TypeBase ExtShape u]+staticShapes :: [TypeBase Shape o] -> [TypeBase ExtShape o] staticShapes = map staticShapes1  -- | As 'staticShapes', but on a single type.-staticShapes1 :: TypeBase Shape u -> TypeBase ExtShape u+staticShapes1 :: TypeBase Shape o -> TypeBase ExtShape o staticShapes1 (Prim t) =   Prim t-staticShapes1 (Acc acc ispace ts u) =-  Acc acc ispace ts u-staticShapes1 (Array bt (Shape shape) u) =-  Array bt (Shape $ map Free shape) u+staticShapes1 (Acc acc ispace ts) =+  Acc acc ispace ts+staticShapes1 (Array bt (Shape shape) o) =+  Array bt (Shape $ map Free shape) o staticShapes1 (Mem space) =   Mem space --- | @arrayOf t s u@ constructs an array type.  The convenience+-- | @arrayOf t s o@ constructs an array type.  The convenience -- compared to using the 'Array' constructor directly is that @t@ can -- itself be an array.  If @t@ is an @n@-dimensional array, and @s@ is -- a list of length @n@, the resulting type is of an @n+m@ dimensions.--- The uniqueness of the new array will be @u@, no matter the--- uniqueness of @t@.  If the shape @s@ has rank 0, then the @t@ will--- be returned, although if it is an array, with the uniqueness--- changed to @u@.+-- The mode of the new array will be @o@, no matter the mode of @t@.+-- If the shape @s@ has rank 0, then the @t@ will be returned,+-- although if it is an array, with the mode changed to @o@. arrayOf ::   (ArrayShape shape) =>-  TypeBase shape u_unused ->+  TypeBase shape o_unused ->   shape ->-  u ->-  TypeBase shape u-arrayOf (Array et size1 _) size2 u =-  Array et (size2 <> size1) u-arrayOf (Prim t) shape u+  o ->+  TypeBase shape o+arrayOf (Array et size1 _) size2 o =+  Array et (size2 <> size1) o+arrayOf (Prim t) shape o   | 0 <- shapeRank shape = Prim t-  | otherwise = Array t shape u-arrayOf (Acc acc ispace ts _) _shape u =-  Acc acc ispace ts u+  | otherwise = Array t shape o+arrayOf (Acc acc ispace ts) _shape _ =+  Acc acc ispace ts arrayOf Mem {} _ _ =   error "arrayOf Mem" @@ -185,37 +177,37 @@ -- size is the given dimension.  This is just a convenient wrapper -- around 'arrayOf'. arrayOfRow ::-  TypeBase (ShapeBase d) NoUniqueness ->+  TypeBase (ShapeBase d) NoMode ->   d ->-  TypeBase (ShapeBase d) NoUniqueness-arrayOfRow t size = arrayOf t (Shape [size]) NoUniqueness+  TypeBase (ShapeBase d) NoMode+arrayOfRow t size = arrayOf t (Shape [size]) NoMode  -- | Construct an array whose rows are the given type, and the outer -- size is the given t'Shape'.  This is just a convenient wrapper -- around 'arrayOf'. arrayOfShape :: Type -> Shape -> Type-arrayOfShape t shape = arrayOf t shape NoUniqueness+arrayOfShape t shape = arrayOf t shape NoMode  -- | Set the dimensions of an array.  If the given type is not an -- array, return the type unchanged.-setArrayDims :: TypeBase oldshape u -> [SubExp] -> TypeBase Shape u+setArrayDims :: TypeBase oldshape o -> [SubExp] -> TypeBase Shape o setArrayDims t dims = t `setArrayShape` Shape dims  -- | Replace the size of the outermost dimension of an array.  If the -- given type is not an array, it is returned unchanged. setOuterSize ::-  TypeBase (ShapeBase d) u ->+  TypeBase (ShapeBase d) m ->   d ->-  TypeBase (ShapeBase d) u+  TypeBase (ShapeBase d) m setOuterSize = setDimSize 0  -- | Replace the size of the given dimension of an array.  If the -- given type is not an array, it is returned unchanged. setDimSize ::   Int ->-  TypeBase (ShapeBase d) u ->+  TypeBase (ShapeBase d) m ->   d ->-  TypeBase (ShapeBase d) u+  TypeBase (ShapeBase d) m setDimSize i t e = t `setArrayShape` setDim i (arrayShape t) e  -- | Replace the outermost dimension of an array shape.@@ -233,19 +225,19 @@ -- | @peelArray n t@ returns the type resulting from peeling the first -- @n@ array dimensions from @t@.  Returns @Nothing@ if @t@ has less -- than @n@ dimensions.-peelArray :: Int -> TypeBase Shape u -> Maybe (TypeBase Shape u)+peelArray :: Int -> TypeBase Shape o -> Maybe (TypeBase Shape o) peelArray 0 t = Just t-peelArray n (Array et shape u)+peelArray n (Array et shape o)   | shapeRank shape == n = Just $ Prim et-  | shapeRank shape > n = Just $ Array et (stripDims n shape) u+  | shapeRank shape > n = Just $ Array et (stripDims n shape) o peelArray _ _ = Nothing  -- | @stripArray n t@ removes the @n@ outermost layers of the array. -- Essentially, it is the type of indexing an array of type @t@ with -- @n@ indexes.-stripArray :: Int -> TypeBase (ShapeBase d) u -> TypeBase (ShapeBase d) u-stripArray n (Array et shape u)-  | n < shapeRank shape = Array et (stripDims n shape) u+stripArray :: Int -> TypeBase (ShapeBase d) m -> TypeBase (ShapeBase d) m+stripArray n (Array et shape o)+  | n < shapeRank shape = Array et (stripDims n shape) o   | otherwise = Prim et stripArray _ t = t @@ -258,44 +250,44 @@  -- | Return the dimensions of a type - for non-arrays, this is the -- empty list.-arrayDims :: TypeBase (ShapeBase d) u -> [d]+arrayDims :: TypeBase (ShapeBase d) m -> [d] arrayDims = shapeDims . arrayShape  -- | Return the size of the given dimension.  If the dimension does -- not exist, the zero constant is returned.-arraySize :: Int -> TypeBase Shape u -> SubExp+arraySize :: Int -> TypeBase Shape o -> SubExp arraySize i = shapeSize i . arrayShape  -- | Return the size of the given dimension in the first element of -- the given type list.  If the dimension does not exist, or no types -- are given, the zero constant is returned.-arraysSize :: Int -> [TypeBase Shape u] -> SubExp+arraysSize :: Int -> [TypeBase Shape o] -> SubExp arraysSize _ [] = constant (0 :: Int64) arraysSize i (t : _) = arraySize i t  -- | Return the immediate row-type of an array.  For @[][]t@, this -- would be @[]t@.-rowType :: TypeBase (ShapeBase d) u -> TypeBase (ShapeBase d) u+rowType :: TypeBase (ShapeBase d) m -> TypeBase (ShapeBase d) m rowType = stripArray 1  -- | A type is a primitive type if it is not an array or memory block.-primType :: TypeBase shape u -> Bool+primType :: TypeBase shape o -> Bool primType Prim {} = True primType _ = False  -- | Is this an accumulator?-isAcc :: TypeBase shape u -> Bool+isAcc :: TypeBase shape o -> Bool isAcc Acc {} = True isAcc _ = False  -- | Is this a memory block?-isMem :: TypeBase shape u -> Bool+isMem :: TypeBase shape o -> Bool isMem Mem {} = True isMem _ = False  -- | Returns the bottommost type of an array.  For @[][]i32@, this -- would be @i32@.  If the given type is not an array, it is returned.-elemType :: TypeBase shape u -> PrimType+elemType :: TypeBase shape o -> PrimType elemType (Array t _ _) = t elemType (Prim t) = t elemType Acc {} = error "elemType Acc"@@ -308,7 +300,7 @@ -- | Rearrange the dimensions of the type.  If the length of the -- permutation does not match the rank of the type, the permutation -- will be extended with identity.-rearrangeType :: [Int] -> TypeBase (ShapeBase d) u -> TypeBase (ShapeBase d) u+rearrangeType :: [Int] -> TypeBase (ShapeBase d) m -> TypeBase (ShapeBase d) m rearrangeType perm t =   t `setArrayShape` Shape (rearrangeShape perm' $ arrayDims t)   where@@ -318,12 +310,12 @@ mapOnExtType ::   (Monad m) =>   (SubExp -> m SubExp) ->-  TypeBase ExtShape u ->-  m (TypeBase ExtShape u)+  TypeBase ExtShape o ->+  m (TypeBase ExtShape o) mapOnExtType _ (Prim bt) =   pure $ Prim bt-mapOnExtType f (Acc acc ispace ts u) =-  Acc <$> f' acc <*> traverse f ispace <*> mapM (mapOnType f) ts <*> pure u+mapOnExtType f (Acc acc ispace ts) =+  Acc <$> f' acc <*> traverse f ispace <*> mapM (mapOnType f) ts   where     f' v = do       x <- f $ Var v@@ -332,20 +324,20 @@         Constant {} -> pure v mapOnExtType _ (Mem space) =   pure $ Mem space-mapOnExtType f (Array t shape u) =+mapOnExtType f (Array t shape o) =   Array t     <$> (Shape <$> mapM (traverse f) (shapeDims shape))-    <*> pure u+    <*> pure o  -- | Transform any t'SubExp's in the type. mapOnType ::   (Monad m) =>   (SubExp -> m SubExp) ->-  TypeBase Shape u ->-  m (TypeBase Shape u)+  TypeBase Shape o ->+  m (TypeBase Shape o) mapOnType _ (Prim bt) = pure $ Prim bt-mapOnType f (Acc acc ispace ts u) =-  Acc <$> f' acc <*> traverse f ispace <*> mapM (mapOnType f) ts <*> pure u+mapOnType f (Acc acc ispace ts) =+  Acc <$> f' acc <*> traverse f ispace <*> mapM (mapOnType f) ts   where     f' v = do       x <- f $ Var v@@ -353,38 +345,37 @@         Var v' -> pure v'         Constant {} -> pure v mapOnType _ (Mem space) = pure $ Mem space-mapOnType f (Array t shape u) =+mapOnType f (Array t shape o) =   Array t     <$> (Shape <$> mapM f (shapeDims shape))-    <*> pure u+    <*> pure o  -- | @diet t@ returns a description of how a function parameter of--- type @t@ might consume its argument.-diet :: TypeBase shape Uniqueness -> Diet+-- type @t@ might consume its argument.  An accumulator is consumed by+-- any use, so it is unconditionally 'Consume'.+diet :: TypeBase shape Diet -> Diet diet Prim {} = Observe-diet (Acc _ _ _ Unique) = Consume-diet (Acc _ _ _ Nonunique) = Observe-diet (Array _ _ Unique) = Consume-diet (Array _ _ Nonunique) = Observe+diet Acc {} = Consume+diet (Array _ _ o) = o diet Mem {} = Observe --- | Add the given uniqueness information to the types.+-- | Add the given 'Diet' to the types. toDecl ::-  TypeBase shape NoUniqueness ->-  Uniqueness ->-  TypeBase shape Uniqueness+  TypeBase shape NoMode ->+  Diet ->+  TypeBase shape Diet toDecl (Prim t) _ = Prim t-toDecl (Acc acc ispace ts _) u = Acc acc ispace ts u-toDecl (Array et shape _) u = Array et shape u+toDecl (Acc acc ispace ts) _ = Acc acc ispace ts+toDecl (Array et shape _) o = Array et shape o toDecl (Mem space) _ = Mem space --- | Remove uniqueness information from the type.+-- | Remove the mode from the type. fromDecl ::-  TypeBase shape Uniqueness ->-  TypeBase shape NoUniqueness+  TypeBase shape o ->+  TypeBase shape NoMode fromDecl (Prim t) = Prim t-fromDecl (Acc acc ispace ts _) = Acc acc ispace ts NoUniqueness-fromDecl (Array et shape _) = Array et shape NoUniqueness+fromDecl (Acc acc ispace ts) = Acc acc ispace ts+fromDecl (Array et shape _) = Array et shape NoMode fromDecl (Mem space) = Mem space  -- | If an existential, then return its existential index.@@ -401,7 +392,7 @@ -- of the values returned by the function, return the existential -- shape context.  That is, those sizes that are existential in the -- return type.-extractShapeContext :: [TypeBase ExtShape u] -> [[a]] -> [a]+extractShapeContext :: [TypeBase ExtShape o] -> [[a]] -> [a] extractShapeContext ts shapes =   evalState (concat <$> zipWithM extract ts shapes) S.empty   where@@ -417,24 +408,24 @@     extract' (Free _) _ = pure Nothing  -- | The 'Ext' integers used for existential sizes in the given types.-shapeContext :: [TypeBase ExtShape u] -> S.Set Int+shapeContext :: [TypeBase ExtShape o] -> S.Set Int shapeContext = S.fromList . concatMap (mapMaybe isExt . shapeDims . arrayShape)  -- | If all dimensions of the given 'ExtShape' are statically known, -- change to the corresponding t'Shape'.-hasStaticShape :: TypeBase ExtShape u -> Maybe (TypeBase Shape u)+hasStaticShape :: TypeBase ExtShape o -> Maybe (TypeBase Shape o) hasStaticShape (Prim bt) = Just $ Prim bt-hasStaticShape (Acc acc ispace ts u) = Just $ Acc acc ispace ts u+hasStaticShape (Acc acc ispace ts) = Just $ Acc acc ispace ts hasStaticShape (Mem space) = Just $ Mem space-hasStaticShape (Array bt (Shape shape) u) =-  Array bt <$> (Shape <$> mapM isFree shape) <*> pure u+hasStaticShape (Array bt (Shape shape) o) =+  Array bt <$> (Shape <$> mapM isFree shape) <*> pure o  -- | Given two lists of 'ExtType's of the same length, return a list of -- 'ExtType's that generalises the two operands. generaliseExtTypes ::-  [TypeBase ExtShape u] ->-  [TypeBase ExtShape u] ->-  [TypeBase ExtShape u]+  [TypeBase ExtShape o] ->+  [TypeBase ExtShape o] ->+  [TypeBase ExtShape o] generaliseExtTypes rt1 rt2 =   evalState (zipWithM unifyExtShapes rt1 rt2) (0, M.empty)   where@@ -474,7 +465,7 @@     checkDim d = d  -- | Produce a mapping for the dimensions context.-shapeExtMapping :: [TypeBase ExtShape u] -> [TypeBase Shape u1] -> M.Map Int SubExp+shapeExtMapping :: [TypeBase ExtShape o] -> [TypeBase Shape o1] -> M.Map Int SubExp shapeExtMapping = dimMapping arrayDims arrayDims match mappend   where     match Free {} _ = mempty@@ -556,14 +547,7 @@   extTypeOf = id  instance ExtTyped DeclExtType where-  extTypeOf = fromDecl . declExtTypeOf---- | Typeclass for things that contain 'DeclExtType's.-class (FixExt t) => DeclExtTyped t where-  declExtTypeOf :: t -> DeclExtType--instance DeclExtTyped DeclExtType where-  declExtTypeOf = id+  extTypeOf = fromDecl  -- | Something with an existential context that can be (partially) -- fixed.@@ -575,7 +559,7 @@   -- | Map a function onto any existential.   mapExt :: (Int -> Int) -> t -> t -instance (FixExt shape, ArrayShape shape) => FixExt (TypeBase shape u) where+instance (FixExt shape, ArrayShape shape) => FixExt (TypeBase shape o) where   fixExt i se = modifyArrayShape $ fixExt i se   mapExt f = modifyArrayShape $ mapExt f
src/Futhark/IR/Rep.hs view
@@ -13,7 +13,7 @@ import Data.Kind qualified import Futhark.IR.Prop.Types import Futhark.IR.RetType-import Futhark.IR.Syntax.Core (DeclExtType, DeclType, ExtType, Type)+import Futhark.IR.Syntax.Core (DeclType, ExtType, Type)  -- | Returns nothing and does nothing.  Placeholder for when we don't -- really want an operation.@@ -82,10 +82,12 @@    type LParamInfo l = Type -  -- | The return type decoration of function calls.+  -- | The return type decoration of function calls.  Note that this+  -- carries no mode: whether a result aliases anything is recorded in+  -- the accompanying 'RetAls', not in the type.   type RetType l :: Data.Kind.Type -  type RetType l = DeclExtType+  type RetType l = ExtType    -- | The return type decoration of branches.   type BranchType l :: Data.Kind.Type
src/Futhark/IR/RetType.hs view
@@ -28,7 +28,7 @@ -- a list of these will be used.  It should contain at least the -- information contained in an 'ExtType', but may have more, notably -- an existential context.-class (Show rt, Eq rt, Ord rt, ExtTyped rt, DeclExtTyped rt) => IsRetType rt where+class (Show rt, Eq rt, Ord rt, ExtTyped rt) => IsRetType rt where   -- | Contruct a return type from a primitive type.   primRetType :: PrimType -> rt @@ -56,7 +56,7 @@           | Just se <- M.lookup v parammap = se         f se = se -instance IsRetType DeclExtType where+instance IsRetType ExtType where   primRetType = Prim    applyRetType extret params args =
src/Futhark/IR/SOACS/SOAC.hs view
@@ -769,9 +769,9 @@ substNamesInType _ t@Prim {} = t substNamesInType _ t@Acc {} = t substNamesInType _ (Mem space) = Mem space-substNamesInType subs (Array btp shp u) =+substNamesInType subs (Array btp shp o) =   let shp' = Shape $ map (substNamesInSubExp subs) (shapeDims shp)-   in Array btp shp' u+   in Array btp shp' o  substNamesInSubExp :: M.Map VName SubExp -> SubExp -> SubExp substNamesInSubExp _ e@(Constant _) = e
src/Futhark/IR/SOACS/Simplify.hs view
@@ -18,6 +18,7 @@     simplifyMapIota,     SOACS,     eliminate,+    eliminateWithDeps,     eliminateByRes,     prunePreLambdaResults,     dedupInput,@@ -95,13 +96,13 @@   shape' <- traverse Engine.simplify shape   arr' <- mapM Engine.simplify arr   vec' <- mapM Engine.simplify vec-  (lam', hoisted) <- Engine.simplifyLambda mempty lam+  (lam', hoisted) <- Engine.enterLoop $ Engine.simplifyLambda mempty lam   pure (VJP shape' arr' vec' lam', hoisted) simplifySOAC (JVP shape arr vec lam) = do   shape' <- traverse Engine.simplify shape   arr' <- mapM Engine.simplify arr   vec' <- mapM Engine.simplify vec-  (lam', hoisted) <- Engine.simplifyLambda mempty lam+  (lam', hoisted) <- Engine.enterLoop $ Engine.simplifyLambda mempty lam   pure (JVP shape' arr' vec' lam', hoisted) simplifySOAC (WithVJP args lam lam_adj) = do   args' <- mapM Engine.simplify args@@ -1177,17 +1178,33 @@ -- | Eliminate statements if it is not an dependency used to form the -- names given. eliminate :: (Buildable rep) => Names -> Stms rep -> Stms rep-eliminate = auxiliary (stmsFromList [])+eliminate deps = snd . eliminateWithDeps deps++-- | As 'eliminate', but also return everything the retained statements and the+-- results depend upon. A lambda parameter is live exactly when it is in this+-- set, which saves traversing the pruned body again just to find its free+-- variables. The pair is lazy in its second component, so a caller that only+-- wants to know what is live need not pay for rebuilding the statements.+eliminateWithDeps :: (Buildable rep) => Names -> Stms rep -> (Names, Stms rep)+eliminateWithDeps deps stms+  -- If nothing needs preserving then nothing is live, as a statement is kept+  -- only when it binds a name already needed, and the set of needed names grows+  -- only from statements we keep.+  | namesNull deps = (mempty, mempty)+  | otherwise = (final_deps, stmsFromList kept)   where-    auxiliary stms' deps stms-      | Just (stms'', stm@(Let v aux e)) <- stmsLast stms =-          if namesIntersect deps $ namesFromList $ patNames v-            then-              auxiliary (oneStm stm <> stms') (freeIn (aux, e) <> deps) stms''-            else-              auxiliary stms' deps stms''-      | otherwise = stms'+    -- Walking the statements as a list and rebuilding the sequence once is much+    -- cheaper than peeling them off the right of the sequence, which allocates+    -- a new sequence per statement in both directions.+    (final_deps, kept) = auxiliary deps (reverse (stmsToList stms)) [] +    auxiliary deps' [] kept' = (deps', kept')+    auxiliary deps' (stm@(Let v aux e) : stms') kept'+      | any (`nameIn` deps') (patNames v) =+          auxiliary (freeIn (aux, e) <> deps') stms' (stm : kept')+      | otherwise =+          auxiliary deps' stms' kept'+ -- | Eliminate statements inside a lambda if they are not used to -- compute the result. eliminateByRes :: (Buildable rep) => Lambda rep -> Lambda rep@@ -1288,8 +1305,8 @@     temp_post_lam = eliminateByRes post_lam     deps = freeIn $ lambdaBody temp_post_lam --- | Prunes all unused results from the pre-lambda in a ScremaForm--- (fixed-point).+-- | Prunes all unused results from the pre-lambda in a ScremaForm with scans or+-- reduces (fixed-point). -- -- Repeatedly prunes unused scan and map results until no further -- changes occur.  This is necessary because eliminating some results@@ -1303,16 +1320,33 @@ -- Returns: A ScremaForm with all transitively unused pre-lambda -- results eliminated. prunePreLambdaResults :: (Buildable rep) => ScremaForm rep -> ScremaForm rep-prunePreLambdaResults form =-  if form == form' then form' else prunePreLambdaResults form'+prunePreLambdaResults form+  -- Performance weak: without scans or reductions, every pre-lambda result is a+  -- map result that the post-lambda consumes directly, so there is nothing here+  -- that the ordinary simplifier will not remove later.+  | null (scremaScans form), null (scremaReduces form) = form+  | otherwise =+      if extent form == extent form' then form' else prunePreLambdaResults form'   where     form' = prunePreLambdaScanResults $ prunePreLambdaMapResults form+    -- Both prunings only ever remove results, parameters and statements, so a+    -- round that changes nothing leaves all of these counts alone.  Comparing+    -- them detects a change without comparing the lambda bodies, which may be+    -- very large when this is called on a repeatedly fused SOAC.+    extent (ScremaForm pre scan red post) =+      ( length $ bodyResult $ lambdaBody pre,+        length $ bodyStms $ lambdaBody pre,+        length $ lambdaParams post,+        length $ bodyStms $ lambdaBody post,+        scanResults scan,+        redResults red+      )  -- | Removes duplicate inputs from a ScremaForm's lambda parameters. -- -- When the same input appears multiple times in the input list (with -- corresponding duplicate lambda parameters), this function: 1. Keeps--- only one copy of each unique input 2. Creates let-bindings in the+-- only one copy of each distinct input 2. Creates let-bindings in the -- lambda body to alias the duplicates -- -- Example: If inputs [x, y, x] map to lambda params [a, b, c], the
src/Futhark/IR/SegOp.hs view
@@ -681,14 +681,13 @@   Type ->   m Type mapOnSegOpType _tv t@Prim {} = pure t-mapOnSegOpType tv (Acc acc ispace ts u) =+mapOnSegOpType tv (Acc acc ispace ts) =   Acc     <$> mapOnSegOpVName tv acc     <*> traverse (mapOnSegOpSubExp tv) ispace     <*> traverse (bitraverse (traverse (mapOnSegOpSubExp tv)) pure) ts-    <*> pure u-mapOnSegOpType tv (Array et shape u) =-  Array et <$> traverse (mapOnSegOpSubExp tv) shape <*> pure u+mapOnSegOpType tv (Array et shape o) =+  Array et <$> traverse (mapOnSegOpSubExp tv) shape <*> pure o mapOnSegOpType _tv (Mem s) = pure $ Mem s  rephraseBinOp ::@@ -888,14 +887,29 @@       add =         SegOpMapper pure (pure . informLambda) (pure . informLambda) (pure . informBody) pure pure +-- | The element at the given index of an array literal with the given prim-typed+-- elements, as a chain of conditionals. The index is assumed to be in bounds,+-- so the last element is selected without testing for it.+indexArrayLit ::+  PrimType -> TPrimExp Int64 VName -> [PrimExp VName] -> Maybe (PrimExp VName)+indexArrayLit t i = select 0+  where+    select _ [] = Nothing+    select _ [x] = Just x+    select j (x : xs) = do+      y <- select (j + 1) xs+      pure $ FunExp (condFun t) [untyped (i .==. fromInteger j), x, y] t+ instance (ASTRep rep) => ST.IndexOp (SegOp lvl rep) where   indexOp vtable k (SegMap _ space _ kbody) is = do     Returns ResultMaySimplify _ se <- maybeNth k $ bodyResult kbody     guard $ length gtids <= length is     let idx_table = M.fromList $ zip gtids $ map (ST.Indexed mempty . untyped) is-        idx_table' = foldl' expandIndexedTable idx_table $ bodyStms kbody     case se of-      Var v -> M.lookup v idx_table'+      Var v ->+        M.lookup v $+          foldl' expandIndexedTable idx_table $+            dependedOn v (bodyStms kbody)       _ -> Nothing     where       (gtids, _) = unzip $ unSegSpace space@@ -903,6 +917,17 @@       -- segment dimensions.       excess_is = drop (length gtids) is +      -- The table entry for a variable depends only on the statements+      -- that variable is (transitively) computed from, and computing an+      -- entry is expensive, so skip the rest. See Note [Pruning the+      -- index table].+      dependedOn v = snd . foldr onStm (oneName v, [])+        where+          onStm stm (needed, acc)+            | any ((`nameIn` needed) . patElemName) (patElems (stmPat stm)) =+                (freeIn stm <> needed, stm : acc)+            | otherwise = (needed, acc)+       expandIndexedTable table stm         | [v] <- patNames $ stmPat stm,           Just (pe, cs) <-@@ -919,6 +944,12 @@                     arr                     (fixSlice (fmap isInt64 slice') excess_is)              in M.insert v idx table+        | [v] <- patNames $ stmPat stm,+          BasicOp (ArrayLit ses (Prim t)) <- stmExp stm,+          [i] <- excess_is,+          Just (pes, cs) <- runWriterT $ mapM (primExpFromSubExpM (asPrimExp table)) ses,+          Just pe <- indexArrayLit t i pes =+            M.insert v (ST.Indexed (stmCerts stm <> cs) pe) table         | otherwise =             table @@ -1479,3 +1510,22 @@   extReturns <$> opType k segOpReturns (SegHist _ _ _ _ ops) =   concat <$> mapM (mapM varReturns . histDest) ops++-- Note [Pruning the index table]+--+-- The 'ST.IndexOp' instance for 'SegMap' answers the question "what is the+-- value of element @is@ of the array produced by this kernel?". It does so by+-- symbolically evaluating the kernel body into a table mapping each variable to+-- a 'ST.Indexed', then looking up the variable returned by the kernel.+--+-- Only one entry of that table is ever read, and an entry depends solely on the+-- entries of the variables that are free in the statement that binds it. Hence+-- the answer is unchanged if we first drop every statement that the result does+-- not transitively depend on, which is what 'dependedOn' does.+--+-- This matters because building an entry is expensive (it constructs a+-- 'PrimExp' for the entire statement), while deciding whether a statement is+-- depended upon is a set membership test and a set union. Kernel bodies are+-- often large while the slice that computes any single result is small, and the+-- simplifier asks this question once per indexing of the array, in every one of+-- its many passes; without pruning, that is quadratic in the size of the kernel.
src/Futhark/IR/SeqMem.hs view
@@ -42,7 +42,7 @@   checkFParamDec = checkMemInfo   checkLParamDec = checkMemInfo   checkLetBoundDec = checkMemInfo-  checkRetType = mapM_ (TC.checkExtType . declExtTypeOf)+  checkRetType = mapM_ (TC.checkExtType . extTypeOf)   primFParam name t = pure $ Param mempty name (MemPrim t)   matchPat = matchPatToExp   matchReturnType = matchFunctionReturnType
src/Futhark/IR/Syntax.hs view
@@ -7,14 +7,13 @@ -- -- == Types and values ----- The core language type system is much more restricted than the core--- language.  This is a theme that repeats often.  The only types that--- are supported in the core language are various primitive types--- t'PrimType' which can be combined in arrays (ignore v'Mem' and--- v'Acc' for now).  Types are represented as t'TypeBase', which is--- parameterised by the shape of the array and whether we keep--- uniqueness information.  The t'Type' alias, which is the most--- commonly used, uses t'Shape' and t'NoUniqueness'.+-- The core language type system is much more restricted than the core language.+-- This is a theme that repeats often. The only types that are supported in the+-- core language are various primitive types t'PrimType' which can be combined+-- in arrays (ignore v'Mem' and v'Acc' for now). Types are represented as+-- t'TypeBase', which is parameterised by the shape of the array and whether we+-- keep a mode. The t'Type' alias, which is the most commonly used, uses+-- t'Shape' and t'NoMode'. -- -- This means that the records, tuples, and sum types of the source -- language are represented merely as collections of primitives and@@ -107,8 +106,8 @@     module Futhark.IR.Syntax.Core,      -- * Types-    Uniqueness (..),-    NoUniqueness (..),+    Diet (..),+    NoMode (..),     Rank (..),     ArrayShape (..),     Space (..),@@ -606,14 +605,15 @@ -- | An entry point parameter, comprising its name and original type. data EntryParam = EntryParam   { entryParamName :: Name,-    entryParamUniqueness :: Uniqueness,+    entryParamDiet :: Diet,     entryParamType :: EntryPointType   }   deriving (Eq, Show, Ord)  -- | An entry point result type. data EntryResult = EntryResult-  { entryResultUniqueness :: Uniqueness,+  { -- | Here we overload "consumable" as "fresh".+    entryResultFreshness :: Diet,     entryResultType :: EntryPointType   }   deriving (Eq, Show, Ord)
src/Futhark/IR/Syntax/Core.hs view
@@ -11,7 +11,6 @@      -- * Types     Commutativity (..),-    Uniqueness (..),     ShapeBase (..),     Shape,     stripDims,@@ -38,6 +37,8 @@     ValueType (..),     OpaqueType (..),     OpaqueTypes (..),+    lookupOpaqueType,+    opaquePayload,     Signedness (..),     EntryPointType (..), @@ -210,20 +211,24 @@ -- | A string representing a specific non-default memory space. type SpaceId = String --- | The type of a value.  When comparing types for equality with--- '==', shapes must match.-data TypeBase shape u+-- | The type of a value. When comparing types for equality with '==', shapes+-- must match. The @o@ parameter is the /mode/; denoting based on context how+-- the values of the type may be used. In the IR it is 'Diet' or 'NoMode',+-- although we still use the term "fresh" to denote a value with no aliases.+data TypeBase shape o   = Prim PrimType-  | -- | Token, index space, element type, and uniqueness.-    Acc VName Shape [Type] u-  | Array PrimType shape u+  | -- | Token, index space, and element type. Accumulators carry no mode: every+    -- use of an accumulator consumes it ('diet' is unconditionally 'Consume'),+    -- so there is no way for a function to merely observe one.+    Acc VName Shape [Type]+  | Array PrimType shape o   | Mem Space   deriving (Show, Eq, Ord)  instance Bitraversable TypeBase where-  bitraverse f g (Array t shape u) = Array t <$> f shape <*> g u+  bitraverse f g (Array t shape o) = Array t <$> f shape <*> g o   bitraverse _ _ (Prim pt) = pure $ Prim pt-  bitraverse _ g (Acc arrs ispace ts u) = Acc arrs ispace ts <$> g u+  bitraverse _ _ (Acc arrs ispace ts) = pure $ Acc arrs ispace ts   bitraverse _ _ (Mem s) = pure $ Mem s  instance Functor (TypeBase shape) where@@ -243,33 +248,39 @@  -- | A type with shape information, used for describing the type of -- variables.-type Type = TypeBase Shape NoUniqueness+type Type = TypeBase Shape NoMode  -- | A type with existentially quantified shapes - used as part of -- function (and function-like) return types.  Generally only makes -- sense when used in a list.-type ExtType = TypeBase ExtShape NoUniqueness+type ExtType = TypeBase ExtShape NoMode --- | A type with shape and uniqueness information, used declaring--- return- and parameters types.-type DeclType = TypeBase Shape Uniqueness+-- | A type with shape and 'Diet' information, used for declaring+-- function and loop parameters.+type DeclType = TypeBase Shape Diet --- | An 'ExtType' with uniqueness information, used for function--- return types.-type DeclExtType = TypeBase ExtShape Uniqueness+-- | An 'ExtType' with 'Diet' information, used as the input to alias+-- inference during internalisation.  It is not an IR return type;+-- those carry no mode.+type DeclExtType = TypeBase ExtShape Diet  -- | Information about which parts of a value/type are consumed.  For -- example, we might say that a function taking three arguments of -- types @([int], *[int], [int])@ has diet @[Observe, Consume, -- Observe]@. data Diet-  = -- | Consumes this value.-    Consume-  | -- | Only observes value in this position, does-    -- not consume.  A result may alias this.+  = -- | Only observes the value in this position, does not consume it.     Observe-  deriving (Eq, Ord, Show)+  | -- | Consumes the value in this position.+    Consume+  deriving (Eq, Ord, Show, Bounded) +instance Semigroup Diet where+  (<>) = max++instance Monoid Diet where+  mempty = Observe+ -- | An identifier consists of its name and the type of the value -- bound to the identifier. data Ident = Ident@@ -615,6 +626,27 @@ instance Semigroup OpaqueTypes where   OpaqueTypes x <> OpaqueTypes y =     OpaqueTypes $ x <> filter ((`notElem` map fst x) . fst) y++-- | Look up the representation of a named opaque type.+lookupOpaqueType :: Name -> OpaqueTypes -> OpaqueType+lookupOpaqueType v (OpaqueTypes types) =+  case lookup v types of+    Just (t, _) -> t+    Nothing -> error $ "Unknown opaque type: " ++ show v++-- | The values used to represent an opaque type.+opaquePayload :: OpaqueTypes -> OpaqueType -> [ValueType]+opaquePayload _ (OpaqueSum ts _) = ts+opaquePayload _ (OpaqueArray _ _ ts) = ts+opaquePayload _ (OpaqueRecord []) = [ValueType Signed (Rank 0) Unit]+opaquePayload types (OpaqueRecord fs) = concatMap f fs+  where+    f (_, TypeOpaque s) = opaquePayload types $ lookupOpaqueType s types+    f (_, TypeTransparent v) = [v]+opaquePayload types (OpaqueRecordArray _ _ fs) = concatMap f fs+  where+    f (_, TypeOpaque s) = opaquePayload types $ lookupOpaqueType s types+    f (_, TypeTransparent v) = [v]  -- | Information about what in the original program a given IR statement -- corresponds to. See Note [Tracking Source Locations].
src/Futhark/IR/Traversals.hs view
@@ -259,7 +259,7 @@  walkOnType :: (Monad m) => Walker rep m -> Type -> m () walkOnType _ Prim {} = pure ()-walkOnType tv (Acc acc ispace ts _) = do+walkOnType tv (Acc acc ispace ts) = do   walkOnVName tv acc   traverse_ (walkOnSubExp tv) ispace   mapM_ (walkOnType tv) ts
src/Futhark/IR/TypeCheck.hs view
@@ -76,8 +76,6 @@   | ParameterMismatch (Maybe Name) [Type] [Type]   | SlicingError Shape Int   | BadAnnotation String Type Type-  | ReturnAliased Name VName-  | UniqueReturnAliased Name   | NotAnArray VName Type   | PermutationError [Int] Int (Maybe VName) @@ -149,16 +147,6 @@       ++ ", but derived to be "       ++ prettyString got       ++ "."-  show (ReturnAliased fname name) =-    "Unique return value of function "-      ++ nameToString fname-      ++ " is aliased to "-      ++ prettyString name-      ++ ", which is not consumed."-  show (UniqueReturnAliased fname) =-    "A unique tuple element of return value of function "-      ++ nameToString fname-      ++ " is aliased to some other tuple component."   show (NotAnArray e t) =     "The expression "       ++ prettyString e@@ -538,7 +526,7 @@ checkAccIdent v = do   t <- lookupType v   case t of-    Acc _ ispace ts _ ->+    Acc _ ispace ts ->       pure (ispace, ts)     _ ->       bad . TypeError $@@ -622,7 +610,7 @@   context ("In function " <> nameToText fname)     $ checkFun'       ( fname,-        map (first declExtTypeOf) rettype,+        map (first extTypeOf) rettype,         funParamsToNameInfos params       )       (Just consumable)@@ -634,7 +622,7 @@     consumable =       [ (paramName param, mempty)       | param <- params,-        unique $ paramDeclType param+        consuming $ paramDeclType param       ]  funParamsToNameInfos ::@@ -675,7 +663,7 @@ checkFun' ::   (Checkable rep) =>   ( Name,-    [(DeclExtType, RetAls)],+    [(ExtType, RetAls)],     [(VName, NameInfo (Aliases rep))]   ) ->   Maybe [(VName, Names)] ->@@ -696,13 +684,13 @@      isParam = (`elem` param_names) -    unique_names = namesFromList $ do+    consumable_names = namesFromList $ do       (v, FParamName t) <- params-      guard $ unique $ declTypeOf t+      guard $ consuming $ declTypeOf t       pure v      allowedArgAliases pals =-      namesFromList (map (param_names !!) pals) <> unique_names+      namesFromList (map (param_names !!) pals) <> consumable_names      checkReturnAlias retals = zipWithM_ checkRet (zip [(0 :: Int) ..] rettype) retals       where@@ -904,14 +892,15 @@ checkBasicOp (Update _ src slice se) = do   (src_shape, src_pt) <- checkArrIdent src +  src_aliases <- lookupAliases src   se_aliases <- subExpAliasesM se-  when (src `nameIn` se_aliases) $+  when (src_aliases `namesIntersect` se_aliases) $     bad $       TypeError "The target of an Update must not alias the value to be written." -  checkSlice (arrayOf (Prim src_pt) src_shape NoUniqueness) slice-  require (arrayOf (Prim src_pt) (sliceShape slice) NoUniqueness) se-  consume =<< lookupAliases src+  checkSlice (arrayOf (Prim src_pt) src_shape NoMode) slice+  require (arrayOf (Prim src_pt) (sliceShape slice) NoMode) se+  consume src_aliases checkBasicOp (FlatIndex ident slice) = do   vt <- lookupType ident   observe ident@@ -921,14 +910,15 @@   (src_shape, src_pt) <- checkArrIdent src   when (shapeRank src_shape /= 1) $ bad $ SlicingError src_shape 1 +  src_aliases <- lookupAliases src   v_aliases <- lookupAliases v-  when (src `nameIn` v_aliases) $+  when (src_aliases `namesIntersect` v_aliases) $     bad $       TypeError "The target of an Update must not alias the value to be written."    checkFlatSlice slice-  requireI (arrayOf (Prim src_pt) (Shape (flatSliceDims slice)) NoUniqueness) v-  consume =<< lookupAliases src+  requireI (arrayOf (Prim src_pt) (Shape (flatSliceDims slice)) NoMode) v+  consume src_aliases checkBasicOp (Iota e x s et) = do   require (Prim int64) e   require (Prim $ IntType et) x@@ -1070,14 +1060,18 @@    checkLoopArgs +  -- The loop consumes the initial values of its consuming parameters when it+  -- starts, so neither its body nor anything after it may use them.+  consumeArgs (map paramDeclType mergepat) =<< mapM (checkArg . snd) merge+   binding (scopeOfLoopForm form) $ do     checkForm form -    let rettype = map paramDeclType mergepat+    let rettype = map paramType mergepat         consumable =           [ (paramName param, mempty)           | param <- mergepat,-            unique $ paramDeclType param+            consuming $ paramDeclType param           ]      context "Inside the loop body"@@ -1167,7 +1161,7 @@       Nothing ->         pure () -    pure (Acc (paramName p) shape elem_ts NoUniqueness, mempty)+    pure (Acc (paramName p) shape elem_ts, mempty)    checkAnyLambda False checkLambdaBody lam $     replicate num_accs (Prim Unit, mempty) ++ acc_args@@ -1204,10 +1198,10 @@  checkType ::   (Checkable rep) =>-  TypeBase Shape u ->+  TypeBase Shape o ->   TypeM rep () checkType (Mem (ScalarSpace d _)) = mapM_ (require (Prim int64)) d-checkType (Acc cert shape ts _) = do+checkType (Acc cert shape ts) = do   requireI (Prim Unit) cert   mapM_ (require (Prim int64)) $ shapeDims shape   mapM_ checkType ts@@ -1215,7 +1209,7 @@  checkExtType ::   (Checkable rep) =>-  TypeBase ExtShape u ->+  TypeBase ExtShape o ->   TypeM rep () checkExtType = mapM_ checkExtDim . shapeDims . arrayShape   where@@ -1373,16 +1367,26 @@         map argType args   consumeArgs paramts args +-- | Consume the arguments passed for consuming parameters. A consumed argument+-- may not alias any other argument. consumeArgs ::   [DeclType] ->   [Arg] ->   TypeM rep ()-consumeArgs paramts args =-  forM_ (zip (map diet paramts) args) $ \(d, (_, als)) ->-    occur [consumption (consumeArg als d)]+consumeArgs paramts args = do+  forM_ (zip [0 :: Int ..] args_cons) $ \(i, (cons_als, _)) ->+    forM_ (map (snd . snd) . filter ((/= i) . fst) $ zip [0 ..] args_cons) $ \als ->+      case namesToList $ cons_als `namesIntersection` als of+        [] -> pure ()+        v : _ ->+          bad . TypeError $+            "Consumed argument aliases another argument through " <> prettyText v <> "."+  forM_ args_cons $ \(cons_als, _) ->+    occur [consumption cons_als]   where-    consumeArg als Consume = als-    consumeArg _ _ = mempty+    args_cons = zipWith consumeArg (map diet paramts) args+    consumeArg Consume (_, als) = (als, als)+    consumeArg _ (_, als) = (mempty, als)  -- The boolean indicates whether we only allow consumption of -- parameters.@@ -1400,7 +1404,7 @@       -- Consumption for this is done explicitly elsewhere.       checkFuncall         Nothing-        (map ((`toDecl` Nonunique) . paramType) params)+        (map ((`toDecl` Observe) . paramType) params)         $ map noArgAliases args       let consumable =             if soac@@ -1497,8 +1501,8 @@   default checkLetBoundDec :: (LetDec rep ~ Type) => VName -> LetDec rep -> TypeM rep ()   checkLetBoundDec _ = checkType -  default checkRetType :: (RetType rep ~ DeclExtType) => [RetType rep] -> TypeM rep ()-  checkRetType = mapM_ $ checkExtType . declExtTypeOf+  default checkRetType :: (RetType rep ~ ExtType) => [RetType rep] -> TypeM rep ()+  checkRetType = mapM_ checkExtType    default matchPat :: Pat (LetDec (Aliases rep)) -> Exp (Aliases rep) -> TypeM rep ()   matchPat pat = matchExtPat pat <=< expExtType@@ -1506,8 +1510,8 @@   default primFParam :: (FParamInfo rep ~ DeclType) => VName -> PrimType -> TypeM rep (FParam (Aliases rep))   primFParam name t = pure $ Param mempty name (Prim t) -  default matchReturnType :: (RetType rep ~ DeclExtType) => [RetType rep] -> Result -> TypeM rep ()-  matchReturnType = matchExtReturnType . map fromDecl+  default matchReturnType :: (RetType rep ~ ExtType) => [RetType rep] -> Result -> TypeM rep ()+  matchReturnType = matchExtReturnType    default matchBranchType :: (BranchType rep ~ ExtType) => [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()   matchBranchType = matchExtBranchType
src/Futhark/Internalise/AccurateSizes.hs view
@@ -28,7 +28,7 @@      f t1@Array {} t2@Array {} =       pure $ M.fromList $ mapMaybe match $ zip (arrayDims t1) (arrayDims t2)-    f (Acc acc1 ispace1 ts1 _) (Acc acc2 ispace2 ts2 _) = do+    f (Acc acc1 ispace1 ts1) (Acc acc2 ispace2 ts2) = do       let ispace_m =             M.fromList . mapMaybe match $               zip (shapeDims ispace1) (shapeDims ispace2)@@ -106,10 +106,10 @@ -- shape declarations.  Not used to change rank of arguments.  Assumes -- everything is otherwise type-correct. ensureArgShapes ::-  (Typed (TypeBase Shape u)) =>+  (Typed (TypeBase Shape o)) =>   ErrorMsg SubExp ->   [VName] ->-  [TypeBase Shape u] ->+  [TypeBase Shape o] ->   [SubExp] ->   InternaliseM [SubExp] ensureArgShapes msg shapes paramts args =
src/Futhark/Internalise/Bindings.hs view
@@ -32,6 +32,8 @@   pure $ I.AttrName v internaliseAttr (E.AttrAtom (E.AtomInt x) _) =   pure $ I.AttrInt x+internaliseAttr (E.AttrAtom (E.AtomVar v) _) =+  pure $ I.AttrName $ nameFromText $ prettyText v internaliseAttr (E.AttrComp f attrs _) =   I.AttrComp f <$> mapM internaliseAttr attrs @@ -93,14 +95,14 @@   where     fixAccParams ps =       first catMaybes $ unzip $ map fixAccParam ps-    fixAccParam (I.Param attrs pv (I.Acc acc ispace ts u)) =+    fixAccParam (I.Param attrs pv (I.Acc acc ispace ts)) =       ( Just (I.Param attrs acc $ I.Prim I.Unit),-        I.Param attrs pv (I.Acc acc ispace ts u)+        I.Param attrs pv (I.Acc acc ispace ts)       )     fixAccParam p = (Nothing, p)      chunkValues ::-      [[Tree (I.TypeBase I.Shape Uniqueness)]] ->+      [[Tree (I.TypeBase I.Shape I.Diet)]] ->       [[I.FParam I.SOACS]] ->       [Tree (I.FParam I.SOACS)]     chunkValues tss vss =@@ -201,7 +203,7 @@     m ps  -- | Flatten a pattern.  Returns a list of identifiers.-flattenPat :: (MonadFreshNames m) => E.Pat (TypeBase Size u) -> m [(E.Ident (TypeBase Size u), [E.AttrInfo VName])]+flattenPat :: (MonadFreshNames m) => E.Pat (TypeBase Size o) -> m [(E.Ident (TypeBase Size o), [E.AttrInfo VName])] flattenPat = flattenPat'   where     flattenPat' (E.PatParens p _) =
src/Futhark/Internalise/Defunctionalise.hs view
@@ -26,13 +26,16 @@ -- The Ord instance here is really important, as it is used for the memoisation -- machinery that handles recursive functions. data StaticVal-  = Dynamic ParamType+  = -- | A first-order value.  The freshness slot is meaningful only where the+    -- value is used as a parameter, and is converted at those boundaries; see+    -- 'paramTypeFromSV'.+    Dynamic ResType   | -- | The Env is the lexical closure of the lambda.     LambdaSV (Pat ParamType) ResRetType Exp Env   | RecordSV [(Name, StaticVal)]   | -- | The constructor that is actually present, plus     -- the others that are not.-    SumSV Name [StaticVal] [(Name, [ParamType])]+    SumSV Name [StaticVal] [(Name, [ResType])]   | -- | The pair is the StaticVal and residual expression of this     -- function as a whole, while the second StaticVal is its     -- body. (Don't trust this too much, my understanding may have@@ -68,8 +71,8 @@  replaceTypeSizes ::   M.Map VName SizeSubst ->-  TypeBase Size als ->-  TypeBase Size als+  TypeBase Size o ->+  TypeBase Size o replaceTypeSizes substs = first onDim   where     onDim (Var v typ loc) =@@ -300,9 +303,9 @@   deriving (Eq, Ord, Show)  dimMapping ::-  (Monoid a) =>-  TypeBase Size a ->-  TypeBase Size a ->+  (Monoid o) =>+  TypeBase Size o ->+  TypeBase Size o ->   M.Map VName SizeSubst dimMapping t1 t2 = execState (matchDims f t1 t2) mempty   where@@ -317,9 +320,9 @@     f _ d _ = pure d  dimMapping' ::-  (Monoid a) =>-  TypeBase Size a ->-  TypeBase Size a ->+  (Monoid o) =>+  TypeBase Size o ->+  TypeBase Size o ->   M.Map VName VName dimMapping' t1 t2 = M.mapMaybe f $ dimMapping t1 t2   where@@ -352,10 +355,10 @@ -- expression. This is necessary since the original type may contain additional -- information (e.g., shape restrictions) from the user given annotation. combineTypeShapes ::-  (Monoid as) =>-  TypeBase Size as ->-  TypeBase Size as ->-  TypeBase Size as+  (Monoid o) =>+  TypeBase Size o ->+  TypeBase Size o ->+  TypeBase Size o combineTypeShapes (Scalar (Record ts1)) (Scalar (Record ts2))   | M.keys ts1 == M.keys ts2 =       Scalar $@@ -378,16 +381,16 @@       d1       (combineTypeShapes a1 a2)       (RetType dims1 (combineTypeShapes b1 b2))-combineTypeShapes (Scalar (TypeVar u v targs1)) (Scalar (TypeVar _ _ targs2)) =-  Scalar $ TypeVar u v $ zipWith f targs1 targs2+combineTypeShapes (Scalar (TypeVar o v targs1)) (Scalar (TypeVar _ _ targs2)) =+  Scalar $ TypeVar o v $ zipWith f targs1 targs2   where     f (TypeArgType t1) (TypeArgType t2) = TypeArgType (combineTypeShapes t1 t2)     f targ _ = targ-combineTypeShapes (Array u shape1 et1) (Array _ _shape2 et2) =+combineTypeShapes (Array o shape1 et1) (Array _ _shape2 et2) =   arrayOfWithAliases-    u+    o     shape1-    (combineTypeShapes (setUniqueness (Scalar et1) u) (setUniqueness (Scalar et2) u))+    (combineTypeShapes (setMode (Scalar et1) o) (setMode (Scalar et2) o)) combineTypeShapes _ t = t  -- When we instantiate a polymorphic StaticVal, we rename all the@@ -438,7 +441,7 @@         [pat'] -> (pat', ret, e0)         (pat' : pats') ->           ( pat',-            RetType [] $ second (const Nonunique) $ funType pats' ret,+            RetType [] $ second (const Nonfresh) $ funType pats' ret,             Lambda pats' e0 Nothing (Info ret) loc           ) @@ -487,13 +490,13 @@ -- the associated static value in the defunctionalization monad. defuncExp :: Exp -> DefM (Exp, StaticVal) defuncExp e@Literal {} =-  pure (e, Dynamic $ toParam Observe $ typeOf e)+  pure (e, Dynamic $ toRes Nonfresh $ typeOf e) defuncExp e@IntLit {} =-  pure (e, Dynamic $ toParam Observe $ typeOf e)+  pure (e, Dynamic $ toRes Nonfresh $ typeOf e) defuncExp e@FloatLit {} =-  pure (e, Dynamic $ toParam Observe $ typeOf e)+  pure (e, Dynamic $ toRes Nonfresh $ typeOf e) defuncExp e@StringLit {} =-  pure (e, Dynamic $ toParam Observe $ typeOf e)+  pure (e, Dynamic $ toRes Nonfresh $ typeOf e) defuncExp (Parens e loc) = do   (e', sv) <- defuncExp e   pure (Parens e' loc, sv)@@ -531,17 +534,17 @@                   (baseName vn, sv)                 ) defuncExp e@(ArrayVal vs t loc) =-  pure (ArrayVal vs t loc, Dynamic $ toParam Observe $ typeOf e)+  pure (ArrayVal vs t loc, Dynamic $ toRes Nonfresh $ typeOf e) defuncExp (ArrayLit es t@(Info t') loc) = do   es' <- mapM defuncExp' es-  pure (ArrayLit es' t loc, Dynamic $ toParam Observe t')+  pure (ArrayLit es' t loc, Dynamic $ toRes Nonfresh t') defuncExp (AppExp (Range e1 me incl loc) res) = do   e1' <- defuncExp' e1   me' <- mapM defuncExp' me   incl' <- mapM defuncExp' incl   pure     ( AppExp (Range e1' me' incl' loc) res,-      Dynamic $ toParam Observe $ appResType $ unInfo res+      Dynamic $ toRes Nonfresh $ appResType $ unInfo res     ) defuncExp e@(Var qn (Info t) loc) = do   sv <- lookupVar (toStruct t) (qualLeaf qn)@@ -549,12 +552,12 @@     -- If the variable refers to a dynamic function, we eta-expand it     -- so that we do not have to duplicate its definition.     DynamicFun {} -> do-      (params, body, ret) <- etaExpand (RetType [] $ toRes Nonunique t) e+      (params, body, ret) <- etaExpand (RetType [] $ toRes Nonfresh t) e       defuncFun [] params body ret mempty     -- Intrinsic functions used as variables are eta-expanded, so we     -- can get rid of them.     IntrinsicSV -> do-      (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonunique t) e+      (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonfresh t) e       defuncExp $ Lambda pats body Nothing (Info tp) mempty     HoleSV _ hole_loc ->       pure (Hole (Info t) hole_loc, sv)@@ -628,7 +631,7 @@   pure (AppExp (Loop sparams pat (LoopInitExplicit e1') form' e3' loc) res, sv)   where     insertIdent (Ident vn (Info tp) _) =-      M.insert vn $ Binding Nothing $ Dynamic $ toParam Observe tp+      M.insert vn $ Binding Nothing $ Dynamic $ toRes Nonfresh tp defuncExp e@(AppExp BinOp {} _) =   error $ "defuncExp: unexpected binary operator: " ++ prettyString e defuncExp (Project vn e0 tp@(Info tp') loc) = do@@ -637,7 +640,7 @@     RecordSV svs -> case lookup vn svs of       Just sv -> pure (Project vn e0' (Info $ structTypeFromSV sv) loc, sv)       Nothing -> error "Invalid record projection."-    Dynamic _ -> pure (Project vn e0' tp loc, Dynamic $ toParam Observe tp')+    Dynamic _ -> pure (Project vn e0' tp loc, Dynamic $ toRes Nonfresh tp')     HoleSV _ hloc -> pure (Project vn e0' tp loc, HoleSV tp' hloc)     _ -> error $ "Projection of an expression with static value " ++ show sv0 defuncExp (AppExp LetWith {} _) =@@ -647,7 +650,7 @@   idxs' <- mapM defuncDimIndex idxs   pure     ( AppExp (Index e0' idxs' loc) res,-      Dynamic $ toParam Observe $ typeOf expr+      Dynamic $ toRes Nonfresh $ typeOf expr     )  -- Note that we might change the type of the record field here.  This@@ -688,26 +691,26 @@   let sv =         SumSV name svs $           M.toList $-            name `M.delete` M.map (map (toParam Observe . defuncType)) all_fs+            name `M.delete` M.map (map (toRes Nonfresh . defuncType)) all_fs       sum_t' = combineTypeShapes sum_t (structTypeFromSV sv)   pure (Constr name es' (Info sum_t') loc, sv)   where     defuncType ::-      (Monoid als) =>-      TypeBase Size als ->-      TypeBase Size als-    defuncType (Array u shape t) = Array u shape (defuncScalar t)+      (Monoid o) =>+      TypeBase Size o ->+      TypeBase Size o+    defuncType (Array o shape t) = Array o shape (defuncScalar t)     defuncType (Scalar t) = Scalar $ defuncScalar t      defuncScalar ::-      (Monoid als) =>-      ScalarTypeBase Size als ->-      ScalarTypeBase Size als+      (Monoid o) =>+      ScalarTypeBase Size o ->+      ScalarTypeBase Size o     defuncScalar (Record fs) = Record $ M.map defuncType fs     defuncScalar Arrow {} = Record mempty     defuncScalar (Sum fs) = Sum $ M.map (map defuncType) fs     defuncScalar (Prim t) = Prim t-    defuncScalar (TypeVar u tn targs) = TypeVar u tn targs+    defuncScalar (TypeVar o tn targs) = TypeVar o tn targs defuncExp (Constr name _ (Info t) loc) =   error $     "Constructor "@@ -760,7 +763,7 @@   pure $ Lambda params e0' decl tp loc defuncSoacExp e   | Scalar Arrow {} <- typeOf e = do-      (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonunique $ typeOf e) e+      (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonfresh $ typeOf e) e       env <- askEnv       let env' = foldl' envFromPat env pats       body' <- local (second (const env')) $ defuncExp' body@@ -846,7 +849,7 @@     ( [],       [],       body',-      imposeType sv $ resToParam rettype,+      imposeType sv rettype,       resTypeFromSV sv     )   where@@ -898,7 +901,7 @@           pure (Var qn (Info (foldFunType argtypes' $ RetType [] rettype')) loc, sv)       | all orderZero argtypes,         orderZero rettype -> do-          (params, body, ret) <- etaExpand (RetType [] $ toRes Nonunique t) e+          (params, body, ret) <- etaExpand (RetType [] $ toRes Nonfresh t) e           defuncFun [] params body ret mempty       | otherwise -> do           fname <- newVName $ "dyn_" <> baseName (qualLeaf qn)@@ -982,7 +985,7 @@       fname <- newVName fname_s       let memo_ret = RetType (retDims lam_e_t) (retType lam_e_t)       when is_body $-        insertLift key (fname, memo_ret, Dynamic $ resToParam $ retType memo_ret)+        insertLift key (fname, memo_ret, Dynamic $ retType memo_ret)       (lam_e', sv) <-         localNewEnv env' $           defuncExp lam_e@@ -993,7 +996,7 @@       globals <- asks $ M.keysSet . fst        -- Lift lambda to top-level function definition.  We put in-      -- a lot of effort to try to infer the uniqueness attributes+      -- a lot of effort to try to infer the freshness attributes       -- of the lifted function, but this is ultimately all a sham       -- and a hack.  There is some piece we're missing.       let params = [closure_pat, pat']@@ -1078,9 +1081,9 @@       -- immediately any time we encounter a non-fully-applied       -- intrinsic?       if null $ fst $ unfoldFunType $ appResType appres-        then pure (e', Dynamic $ toParam Observe $ appResType appres)+        then pure (e', Dynamic $ toRes Nonfresh $ appResType appres)         else do-          (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonunique $ typeOf e') e'+          (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonfresh $ typeOf e') e'           defuncExp $ Lambda pats body Nothing (Info tp) mempty  -- | Check if a 'StaticVal' and a given application depth corresponds@@ -1117,7 +1120,7 @@   RecordPat fs _ -> foldl' envFromPat env $ map snd fs   PatParens p _ -> envFromPat env p   PatAttr _ p _ -> envFromPat env p-  Id vn (Info t) _ -> M.insert vn (Binding Nothing $ Dynamic t) env+  Id vn (Info t) _ -> M.insert vn (Binding Nothing $ Dynamic $ paramToRes t) env   Wildcard _ _ -> env   PatAscription p _ _ -> envFromPat env p   PatLit {} -> env@@ -1138,34 +1141,34 @@  -- | Compute the corresponding type for the *representation* of a -- given static value (not the original possibly higher-order value).-typeFromSV :: StaticVal -> ParamType-typeFromSV (Dynamic tp) =+resTypeFromSV :: StaticVal -> ResType+resTypeFromSV (Dynamic tp) =   tp-typeFromSV (LambdaSV _ _ _ env) =+resTypeFromSV (LambdaSV _ _ _ env) =   Scalar . Record . M.fromList $-    map (bimap (nameFromText . prettyText) (typeFromSV . bindingSV)) $+    map (bimap (nameFromText . prettyText) (resTypeFromSV . bindingSV)) $       M.toList env-typeFromSV (RecordSV ls) =-  let ts = map (fmap typeFromSV) ls+resTypeFromSV (RecordSV ls) =+  let ts = map (fmap resTypeFromSV) ls    in Scalar $ Record $ M.fromList ts-typeFromSV (DynamicFun (_, sv) _) =-  typeFromSV sv-typeFromSV (SumSV name svs fields) =-  let svs' = map typeFromSV svs+resTypeFromSV (DynamicFun (_, sv) _) =+  resTypeFromSV sv+resTypeFromSV (SumSV name svs fields) =+  let svs' = map resTypeFromSV svs    in Scalar $ Sum $ M.insert name svs' $ M.fromList fields-typeFromSV (HoleSV t _) =-  toParam Observe t-typeFromSV IntrinsicSV =+resTypeFromSV (HoleSV t _) =+  toRes Nonfresh t+resTypeFromSV IntrinsicSV =   error "Tried to get the type from the static value of an intrinsic." -resTypeFromSV :: StaticVal -> ResType-resTypeFromSV = paramToRes . typeFromSV- structTypeFromSV :: StaticVal -> StructType-structTypeFromSV = toStruct . typeFromSV+structTypeFromSV = toStruct . resTypeFromSV +-- | The 'Diet' of the result means something else than the freshness it is+-- converted from: that the function may consume the parameter.  The two agree+-- on what matters, since a function owns what it consumes. paramTypeFromSV :: StaticVal -> ParamType-paramTypeFromSV = typeFromSV+paramTypeFromSV = resToParam . resTypeFromSV  -- | Construct the type for a fully-applied dynamic function from its -- static value and the original types of its arguments.@@ -1196,7 +1199,7 @@   -- (but probably reveals a flaw in our bookkeeping).   pure $     if orderZero t-      then dim_env <> M.insert vn (Binding Nothing $ Dynamic t) env+      then dim_env <> M.insert vn (Binding Nothing $ Dynamic $ paramToRes t) env       else dim_env <> M.insert vn (Binding Nothing sv) env   where     -- Extract all sizes that are potentially bound here. This is@@ -1224,7 +1227,7 @@   | otherwise =       error $ "matchPatSV: missing constructor in type: " ++ prettyString c1 matchPatSV env pat (Dynamic t) = matchPatSV env pat $ svFromType t-matchPatSV env pat (HoleSV t _) = matchPatSV env pat $ svFromType $ toParam Observe t+matchPatSV env pat (HoleSV t _) = matchPatSV env pat $ svFromType $ toRes Nonfresh t matchPatSV _ pat sv =   error $     "Tried to match pattern\n"@@ -1277,7 +1280,7 @@ updatePat (PatConstr c1 _ ps loc) (Dynamic t) =   PatConstr c1 (Info $ toParam Observe t) ps loc updatePat pat (Dynamic t) = updatePat pat (svFromType t)-updatePat pat (HoleSV t _) = updatePat pat (svFromType $ toParam Observe t)+updatePat pat (HoleSV t _) = updatePat pat (svFromType $ toRes Nonfresh t) updatePat pat sv =   error $     "Tried to update pattern\n"@@ -1288,7 +1291,7 @@ -- | Convert a record (or tuple) type to a record static value. This -- is used for "unwrapping" tuples and records that are nested in -- 'Dynamic' static values.-svFromType :: ParamType -> StaticVal+svFromType :: ResType -> StaticVal svFromType (Scalar (Record fs)) = RecordSV . M.toList $ M.map svFromType fs svFromType t = Dynamic t @@ -1308,7 +1311,7 @@       Just $ go params   | otherwise = Nothing   where-    ret_sv = Dynamic $ resToParam rettype+    ret_sv = Dynamic rettype     go [] = ret_sv     go (_ : ps) =       let inner = go ps@@ -1391,7 +1394,7 @@           valBindRetType =             Info $               if null params'-                then RetType ret_dims' $ rettype' `setUniqueness` Nonunique+                then RetType ret_dims' $ rettype' `setMode` Nonfresh                 else RetType ret_dims' rettype',           valBindTypeParams = map (`TypeParamDim` mempty) tparams'',           valBindParams = params'',
src/Futhark/Internalise/Entry.hs view
@@ -17,7 +17,7 @@ import Futhark.Util (chunks) import Futhark.Util.Pretty (prettyTextOneLine) import Language.Futhark qualified as E hiding (TypeArg)-import Language.Futhark.Core (L (..), Name, Uniqueness (..), VName, nameFromText, unLoc)+import Language.Futhark.Core (L (..), Name, VName, nameFromText, unLoc) import Language.Futhark.Semantic qualified as E  -- | The types that are visible to the outside world.@@ -37,7 +37,13 @@ findType :: VName -> VisibleTypes -> Maybe (E.TypeExp E.Exp VName) findType v (VisibleTypes ts) = E.typeExp <$> find ((== v) . E.typeAlias) ts -valueType :: I.TypeBase I.Rank Uniqueness -> I.ValueType+-- | The mode of an array type.  Anything else is at the bottom of the+-- mode lattice: 'I.Observe' for a parameter, 'E.Nonfresh' for a result.+modeOf :: (Bounded o) => I.TypeBase shape o -> o+modeOf (I.Array _ _ o) = o+modeOf _ = minBound++valueType :: I.TypeBase I.Rank o -> I.ValueType valueType (I.Prim pt) = I.ValueType I.Signed (I.Rank 0) pt valueType (I.Array pt rank _) = I.ValueType I.Signed rank pt valueType I.Acc {} = error "valueType Acc"@@ -51,7 +57,7 @@  rootType :: E.TypeExp E.Exp VName -> E.TypeExp E.Exp VName rootType (E.TEApply te E.TypeArgExpSize {} _) = rootType te-rootType (E.TEUnique te _) = rootType te+rootType (E.TEStar te _) = rootType te rootType (E.TEDim _ te _) = rootType te rootType (E.TEParens te _) = rootType te rootType te = te@@ -118,9 +124,10 @@       map (fmap (`E.EntryType` Nothing)) $ E.sortFields fs  opaqueRecord ::+  (Ord o, Bounded o) =>   VisibleTypes ->   [(Name, E.EntryType)] ->-  [I.TypeBase I.Rank Uniqueness] ->+  [I.TypeBase I.Rank o] ->   GenOpaque [(Name, I.EntryPointType)] opaqueRecord _ [] _ = pure [] opaqueRecord types ((f, t) : fs) ts = do@@ -138,10 +145,11 @@     [0 .. rank - 1]  opaqueRecordArray ::+  (Ord o, Bounded o) =>   VisibleTypes ->   Int ->   [(Name, E.EntryType)] ->-  [I.TypeBase I.Rank Uniqueness] ->+  [I.TypeBase I.Rank o] ->   GenOpaque [(Name, I.EntryPointType)] opaqueRecordArray _ _ [] _ = pure [] opaqueRecordArray types rank ((f, t) : fs) ts = do@@ -178,9 +186,10 @@       map (fmap (map (`E.EntryType` Nothing))) $ E.sortConstrs cs  opaqueSum ::+  (Ord o, Bounded o) =>   VisibleTypes ->   [(Name, ([E.EntryType], [Int]))] ->-  [I.TypeBase I.Rank Uniqueness] ->+  [I.TypeBase I.Rank o] ->   GenOpaque [(Name, [(I.EntryPointType, [Int])])] opaqueSum types cs ts = mapM (traverse f) cs   where@@ -199,7 +208,7 @@  elemTypeExp :: E.TypeExp E.Exp VName -> Maybe (E.TypeExp E.Exp VName) elemTypeExp (E.TEArray _ te _) = Just te-elemTypeExp (E.TEUnique te _) = elemTypeExp te+elemTypeExp (E.TEStar te _) = elemTypeExp te elemTypeExp (E.TEParens te _) = elemTypeExp te elemTypeExp _ = Nothing @@ -208,23 +217,24 @@ rowTypeExp r te = rowTypeExp (r - 1) =<< elemTypeExp te  entryPointType ::+  (Ord o, Bounded o) =>   VisibleTypes ->   E.EntryType ->-  [I.TypeBase I.Rank Uniqueness] ->-  GenOpaque (Uniqueness, I.EntryPointType)+  [I.TypeBase I.Rank o] ->+  GenOpaque (o, I.EntryPointType) entryPointType types t ts   | E.Scalar (E.Prim E.Unsigned {}) <- E.entryType t,     [I.Prim ts0] <- ts =-      pure (u, I.TypeTransparent $ I.ValueType I.Unsigned (I.Rank 0) ts0)+      pure (o, I.TypeTransparent $ I.ValueType I.Unsigned (I.Rank 0) ts0)   | E.Array _ _ (E.Prim E.Unsigned {}) <- E.entryType t,     [I.Array ts0 r _] <- ts =-      pure (u, I.TypeTransparent $ I.ValueType I.Unsigned r ts0)+      pure (o, I.TypeTransparent $ I.ValueType I.Unsigned r ts0)   | E.Scalar E.Prim {} <- E.entryType t,     [I.Prim ts0] <- ts =-      pure (u, I.TypeTransparent $ I.ValueType I.Signed (I.Rank 0) ts0)+      pure (o, I.TypeTransparent $ I.ValueType I.Signed (I.Rank 0) ts0)   | E.Array _ _ E.Prim {} <- E.entryType t,     [I.Array ts0 r _] <- ts =-      pure (u, I.TypeTransparent $ I.ValueType I.Signed r ts0)+      pure (o, I.TypeTransparent $ I.ValueType I.Signed r ts0)   | otherwise = do       case E.entryType t of         E.Scalar (E.Record fs) -> do@@ -255,32 +265,42 @@             map valueType ts         _ -> error $ "entryPointType: " <> E.prettyString (E.entryType t) -      pure (u, I.TypeOpaque desc)+      pure (o, I.TypeOpaque desc)   where     doc = Nothing-    u = foldl max Nonunique $ map I.uniqueness ts+    -- The mode of a composite is that of its most-restrictive+    -- component: consumed for a parameter, fresh for a result.+    o = foldl max minBound $ map modeOf ts     desc =       maybe (nameFromText $ prettyTextOneLine t') typeExpOpaqueName $         E.entryAscribed t-    t' = E.noSizes (E.entryType t) `E.setUniqueness` Nonunique+    t' = E.noSizes (E.entryType t) `E.setMode` E.Nonfresh     strip k (I.Array pt (I.Rank r) t_u) =       I.arrayOf (I.Prim pt) (I.Rank (r - k)) t_u     strip _ ts_t = ts_t +-- | An entry point result is either fresh or not; the IR has no freshness type,+-- so this is recorded as a 'I.Diet' where 'I.Consume' means fresh. See+-- 'I.EntryResult'. This is a bit wonky, but it is just an intermediate thing+-- during internalisation.+freshnessAsDiet :: E.Freshness -> I.Diet+freshnessAsDiet E.Nonfresh = I.Observe+freshnessAsDiet E.Fresh = I.Consume+ entryPoint ::   VisibleTypes ->   Name ->   Maybe T.Text ->   [(E.EntryParam, [I.Param I.DeclType])] ->   ( E.EntryType,-    [[I.TypeBase I.Rank I.Uniqueness]]+    [[I.TypeBase I.Rank E.Freshness]]   ) ->   (I.EntryPoint, I.OpaqueTypes) entryPoint types name doc params (eret, crets) =   runGenOpaque $     (name,,,doc)       <$> mapM onParam params-      <*> ( uncurry I.EntryResult+      <*> ( uncurry (I.EntryResult . freshnessAsDiet)               <$> entryPointType types eret (concat crets)           )   where
src/Futhark/Internalise/Exps.hs view
@@ -16,6 +16,7 @@ import Data.Map.Strict qualified as M import Data.Set qualified as S import Data.Text qualified as T+import Futhark.Error (compilerLimitation) import Futhark.IR.SOACS as I hiding (stmPat) import Futhark.Internalise.AccurateSizes import Futhark.Internalise.Bindings@@ -64,7 +65,7 @@   [I.FParam I.SOACS] ->   [[Tree (I.FParam I.SOACS)]] ->   E.ResRetType ->-  ([Tree (I.FParam I.SOACS)], [I.DeclExtType], [(I.DeclExtType, RetAls)], FunInfo)+  ([Tree (I.FParam I.SOACS)], [I.ExtType], [(I.ExtType, RetAls)], FunInfo) funHeader shapeparams params' rettype =   (all_params, rettype', fun_rettype, info)   where@@ -116,7 +117,7 @@     when (null params') $       bindExtSizes (E.AppRes (E.toStruct $ E.retType rettype) (E.retDims rettype)) body_res -    ensureResultExtShape msg (map I.fromDecl rettype') $ subExpsRes body_res+    ensureResultExtShape msg rettype' $ subExpsRes body_res    attrs' <- internaliseAttrs attrs @@ -178,7 +179,7 @@         ("entry_" <> baseName ofname)         ( ctx_ts             ++ zip-              (zeroExts (concat entry_rettype))+              (map I.fromDecl (zeroExts (concat entry_rettype)))               (map (shiftRetAls num_ctx) $ concat retals)         )         (shapeparams ++ foldMap (foldMap toList) params')@@ -367,7 +368,7 @@     certifying cs $       letSubExp "num_elems" $         I.BasicOp $-          I.BinOp (SDivUp Int64 I.Unsafe) distance pos_step+          I.BinOp (SCeilDiv Int64 I.Unsafe) distance pos_step    se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it)   pure [se]@@ -571,7 +572,18 @@            -- Careful not to clobber anything.           loop_end_cond_body <- renameBody <=< buildBody_ $ do-            forM_ (zip shapepat shapeargs) $ \(p, se) ->+            -- Shape arguments may refer to other shape parameters, which+            -- must not be clobbered before they are read.+            let shapepat_names = map I.paramName shapepat+            shapeargs' <- forM (zip shapepat shapeargs) $ \case+              (p, I.Var v)+                | v /= I.paramName p,+                  v `elem` shapepat_names -> do+                    v' <- newVName $ baseName v <> "_tmp"+                    letBindNames [v'] $ I.BasicOp $ I.SubExp $ I.Var v+                    pure $ I.Var v'+              (_, se) -> pure se+            forM_ (zip shapepat shapeargs') $ \(p, se) ->               unless (se == I.Var (I.paramName p)) $                 letBindNames [I.paramName p] $                   BasicOp $@@ -758,7 +770,7 @@             ++ ["] cannot match shape of type \""]             ++ dt'             ++ ["\"."]-    ensureExtShape (errorMsg parts) (I.fromDecl t') desc e'+    ensureExtShape (errorMsg parts) t' desc e' internaliseExp desc (E.Negate e loc) = locating loc $ do   e' <- internaliseExp1 "negate_arg" e   et <- subExpType e'@@ -907,10 +919,10 @@           ++ prettyString t      indexType :: E.StructType -> [E.DimIndex] -> E.StructType-    indexType (E.Array u (E.Shape dims) et) idxs =+    indexType (E.Array o (E.Shape dims) et) idxs =       case dims' of         [] -> E.Scalar et-        ds -> E.Array u (E.Shape ds) et+        ds -> E.Array o (E.Shape ds) et       where         dims' = keptPrefix <> suffix         keptPrefix = [d | (d, i) <- zip prefix idxs, keepDim i]@@ -1391,7 +1403,7 @@    -- reshape neutral element to have same size as the destination array   ne_shp <- forM (zip ne' hist') $ \(n, h) -> do-    rowtype <- I.stripArray 1 <$> lookupType h+    rowtype <- I.stripArray dim <$> lookupType h     ensureShape       "Row shape of destination array does not match shape of neutral element"       rowtype@@ -1436,7 +1448,7 @@   acc_cert_v <- newVName "acc_cert"   dest_ts <- mapM lookupType dest'   let dest_w = arraysSize 0 dest_ts-      acc_t = Acc acc_cert_v (I.Shape [dest_w]) (map rowType dest_ts) NoUniqueness+      acc_t = Acc acc_cert_v (I.Shape [dest_w]) (map rowType dest_ts)   acc_p <- newParam "acc_p" acc_t   withacc_lam <- mkLambda [Param mempty acc_cert_v (I.Prim I.Unit), acc_p] $ do     bs_ts <- mapM lookupType bs'@@ -1869,6 +1881,7 @@           handleSOACs,           handleAccs,           handleAD,+          handleIO,           handleRest         ]   msum [h args $ baseName $ qualLeaf qname | h <- handlers]@@ -2077,6 +2090,11 @@       flatUpdateHelper desc arr1 offset [s1, s2, s3, s4] arr2     handleRest _ _ = Nothing +    handleIO _ s+      | Just f <- T.stripPrefix "io_" (nameToText s) = Just $ \_ ->+          compilerLimitation $ "io." <> f <> " is only supported in interpreted code."+    handleIO _ _ = Nothing+     toSigned int_to e desc = do       e' <- internaliseExp1 "trunc_arg" e       case E.typeOf e of@@ -2280,7 +2298,7 @@       e' <- internaliseExp1 "size" e       pure ["[", ErrorVal int64 e', "]"] -typeExpForError :: E.TypeBase Size u -> InternaliseM [ErrorMsgPart SubExp]+typeExpForError :: E.TypeBase Size o -> InternaliseM [ErrorMsgPart SubExp] typeExpForError (E.Scalar (E.Prim t)) = pure [ErrorString $ prettyText t] typeExpForError (E.Scalar (E.TypeVar _ v args)) = do   args' <- concat <$> mapM onArg args
src/Futhark/Internalise/LiftLambdas.hs view
@@ -82,8 +82,8 @@ bindingForm (ForIn p _) = bindingLetPat [] p bindingForm While {} = id -toRet :: TypeBase Size u -> TypeBase Size Uniqueness-toRet = second (const Nonunique)+toRet :: TypeBase Size o -> TypeBase Size Freshness+toRet = second (const Nonfresh)  liftFunction :: VName -> [TypeParam] -> [Pat ParamType] -> ResRetType -> Exp -> LiftM (StructType -> Exp) liftFunction fname tparams params (RetType dims ret) funbody = do@@ -108,7 +108,7 @@       isSize (v, _) = v `S.member` fvVars sizes_in_types       (free_dims, free_nondims) = partition isSize free -      free_ts = map (second (`setUniqueness` Nonunique)) $ free_dims ++ free_nondims+      free_ts = map (second (`setMode` Nonfresh)) $ free_dims ++ free_nondims    addValBind $     ValBind@@ -145,10 +145,10 @@ transformSubExps :: ASTMapper LiftM transformSubExps = identityMapper {mapOnExp = transformExp} -transformType :: TypeBase Exp u -> LiftM (TypeBase Exp u)+transformType :: TypeBase Exp o -> LiftM (TypeBase Exp o) transformType = bitraverse transformExp pure -transformPat :: PatBase Info VName (TypeBase Exp u) -> LiftM (PatBase Info VName (TypeBase Exp u))+transformPat :: PatBase Info VName (TypeBase Exp o) -> LiftM (PatBase Info VName (TypeBase Exp o)) transformPat = traverse transformType  transformExp :: Exp -> LiftM Exp
src/Futhark/Internalise/Monad.hs view
@@ -37,7 +37,7 @@   ( [VName],     [DeclType],     [FParam SOACS],-    [(SubExp, Type)] -> Maybe [(DeclExtType, RetAls)]+    [(SubExp, Type)] -> Maybe [(ExtType, RetAls)]   )  type FunTable = M.Map VName FunInfo
src/Futhark/Internalise/Monomorphise.hs view
@@ -50,7 +50,7 @@ import Language.Futhark.Traversals import Language.Futhark.TypeChecker.Types -i64 :: TypeBase dim als+i64 :: TypeBase dim o i64 = Scalar $ Prim $ Signed Int64  -- The monomorphization monad reads 'PolyBinding's and writes@@ -303,7 +303,8 @@ scoping argset m =   withArgs argset m >>= unscoping argset --- Given instantiated type of function, produce size arguments.+-- Given instantiated type of function, produce the arguments it must be+-- applied to: its size arguments, and @()@ for a polymorphic value. type InferSizeArgs = StructType -> MonoM [Exp]  -- | The integer encodes an equivalence class, so we can keep@@ -323,14 +324,14 @@ -- | The kind of type relative to which we monomorphise. What is most important -- to us is not the specific dimensions, but merely whether they are known or -- anonymous/local.-type MonoType = TypeBase MonoSize NoUniqueness+type MonoType = TypeBase MonoSize NoMode -monoType :: TypeBase Size als -> MonoType+monoType :: TypeBase Size o -> MonoType monoType = noExts . (`evalState` (0, mempty)) . traverseDims onDim . toStruct   where     -- Remove exts from return types because we don't use them anymore.-    noExts :: TypeBase MonoSize u -> TypeBase MonoSize u-    noExts (Array u shape t) = Array u shape $ noExtsScalar t+    noExts :: TypeBase MonoSize o -> TypeBase MonoSize o+    noExts (Array o shape t) = Array o shape $ noExtsScalar t     noExts (Scalar t) = Scalar $ noExtsScalar t     noExtsScalar (Record fs) = Record $ M.map noExts fs     noExtsScalar (Sum fs) = Sum $ M.map (map noExts) fs@@ -430,35 +431,37 @@       case (maybe_fname, maybe_funbind) of         -- The function has already been monomorphised.         (Just (fname', infer), _) ->-          applySizeArgs fname' (toRes Nonunique t') <$> infer t'+          applyArgs fname' (toRes Nonfresh t') <$> infer t'         -- An intrinsic function.         (Nothing, Nothing) -> pure $ var fname t'         -- A polymorphic function.         (Nothing, Just funbind) -> do           (fname', infer) <- monomorphiseBinding funbind mono_t-          applySizeArgs fname' (toRes Nonunique t') <$> infer t'+          applyArgs fname' (toRes Nonfresh t') <$> infer t'   where     var fname' t' = Var fname' (Info t') loc -    applySizeArg t (i, f) size_arg =-      ( i - 1,+    argType = toParam Observe . typeOf++    applyArg t (arg_ts, f) arg =+      ( drop 1 arg_ts,         mkApply           f-          [(Nothing, size_arg)]-          (AppRes (foldFunType (replicate i i64) (RetType [] t)) [])+          [(Nothing, arg)]+          (AppRes (foldFunType (drop 1 arg_ts) (RetType [] t)) [])       ) -    applySizeArgs fname' t size_args =+    applyArgs fname' t args =       setApplyLoc loc . snd $         foldl'-          (applySizeArg t)-          ( length size_args - 1,+          (applyArg t)+          ( map argType args,             Var               (qualName fname')-              (Info (foldFunType (map (const i64) size_args) (RetType [] t)))+              (Info (foldFunType (map argType args) (RetType [] t)))               loc           )-          size_args+          args  -- | General-purpose size transformation for a type, used everywhere except when -- reconstructing the type of a function reference (see 'transformFNameType').@@ -472,7 +475,7 @@ -- depends on what the caller of 'transformType' does with the resulting -- 'ExpReplacements' afterwards; 'transformType' itself does not add any -- parameters. See Note [Higher-Order Parameter Sizes].-transformType :: TypeBase Size u -> MonoM (TypeBase Size u)+transformType :: TypeBase Size o -> MonoM (TypeBase Size o) transformType = traverseDims onDim   where     onDim _ pos e@@ -506,15 +509,15 @@ -- same type, so each 'Arrow' we cross must, before returning, re-scope any -- such size locally to its own return type (via 'transformRetTypeSizesWith'). -- See Note [Higher-Order Parameter Sizes].-transformFNameType :: TypeBase Size u -> MonoM (TypeBase Size u)+transformFNameType :: TypeBase Size o -> MonoM (TypeBase Size o) transformFNameType typ =   case typ of     Scalar scalar ->       Scalar <$> transformScalarSizes scalar-    Array u shape scalar ->-      Array u <$> mapM onDim shape <*> transformScalarSizes scalar+    Array o shape scalar ->+      Array o <$> mapM onDim shape <*> transformScalarSizes scalar   where-    transformScalarSizes :: ScalarTypeBase Size u -> MonoM (ScalarTypeBase Size u)+    transformScalarSizes :: ScalarTypeBase Size o -> MonoM (ScalarTypeBase Size o)     transformScalarSizes (Record fs) =       Record <$> traverse transformFNameType fs     transformScalarSizes (Sum cs) =@@ -528,8 +531,8 @@           case argName of             Unnamed -> mempty             Named vn -> S.singleton vn-    transformScalarSizes (TypeVar u qn args) =-      TypeVar u qn <$> mapM onArg args+    transformScalarSizes (TypeVar o qn args) =+      TypeVar o qn <$> mapM onArg args       where         onArg (TypeArgDim dim) = TypeArgDim <$> onDim dim         onArg (TypeArgType ty) = TypeArgType <$> transformFNameType ty@@ -546,17 +549,17 @@ -- be a top-level named parameter (those names are not in scope outside), so it -- is instead added to the return type's own existentially-bound sizes. transformRetTypeSizesWith ::-  (TypeBase Size as -> MonoM (TypeBase Size as)) ->+  (TypeBase Size o -> MonoM (TypeBase Size o)) ->   S.Set VName ->-  RetTypeBase Size as ->-  MonoM (RetTypeBase Size as)+  RetTypeBase Size o ->+  MonoM (RetTypeBase Size o) transformRetTypeSizesWith f argset (RetType dims ty) = do   ty' <- withArgs argset $ withMono dims $ f ty   rl <- parametrizing argset   let dims' = dims <> map snd rl   pure $ RetType dims' ty' -transformRetTypeSizes :: S.Set VName -> RetTypeBase Size as -> MonoM (RetTypeBase Size as)+transformRetTypeSizes :: S.Set VName -> RetTypeBase Size o -> MonoM (RetTypeBase Size o) transformRetTypeSizes = transformRetTypeSizesWith transformType  sizesForPat :: (MonadFreshNames m) => Pat ParamType -> m ([VName], Pat ParamType)@@ -846,7 +849,7 @@         mkApply           op           [(xext, e1)]-          (AppRes (Scalar $ Arrow mempty yp (diet ytype) (toStruct ytype) (RetType [] $ toRes Nonunique t')) [])+          (AppRes (Scalar $ Arrow mempty yp (diet ytype) (toStruct ytype) (RetType [] $ toRes Nonfresh t')) [])       onDim (Var d typ _)         | Named p <- xp, qualLeaf d == p = Var (qualName v1) typ loc         | Named p <- yp, qualLeaf d == p = Var (qualName v2) typ loc@@ -910,15 +913,15 @@     isFix _ = False desugarUpdateSection _ t _ = error $ "desugarUpdateSection: not a function type: " ++ prettyString t -transformPat :: Pat (TypeBase Size u) -> MonoM (Pat (TypeBase Size u))+transformPat :: Pat (TypeBase Size o) -> MonoM (Pat (TypeBase Size o)) transformPat = traverse transformType  type DimInst = M.Map VName Size  dimMapping ::-  (Monoid a) =>-  TypeBase Size a ->-  TypeBase Size a ->+  (Monoid o) =>+  TypeBase Size o ->+  TypeBase Size o ->   ExpReplacements ->   ExpReplacements ->   DimInst@@ -988,14 +991,14 @@ noNamedParams :: MonoType -> MonoType noNamedParams = f   where-    f :: TypeBase MonoSize u -> TypeBase MonoSize u-    f (Array u shape t) = Array u shape (f' t)+    f :: TypeBase MonoSize o -> TypeBase MonoSize o+    f (Array o shape t) = Array o shape (f' t)     f (Scalar t) = Scalar $ f' t-    f' :: ScalarTypeBase MonoSize u -> ScalarTypeBase MonoSize u+    f' :: ScalarTypeBase MonoSize o -> ScalarTypeBase MonoSize o     f' (Record fs) = Record $ fmap f fs     f' (Sum cs) = Sum $ fmap (map f) cs-    f' (Arrow u _ d1 t1 (RetType dims t2)) =-      Arrow u Unnamed d1 (f t1) (RetType dims (f t2))+    f' (Arrow o _ d1 t1 (RetType dims t2)) =+      Arrow o Unnamed d1 (f t1) (RetType dims (f t2))     f' t = t  -- | arrowArg takes a return type and returns it@@ -1005,8 +1008,8 @@   S.Set VName -> -- scope   S.Set VName -> -- set of argument   [VName] -> -- size parameters-  RetTypeBase Size as ->-  (RetTypeBase Size as, S.Set VName)+  RetTypeBase Size o ->+  (RetTypeBase Size o, S.Set VName) arrowArg scope argset args_params rety =   let (rety', (funArgs, _)) = runWriter (arrowArgRetType (scope, mempty) argset rety)       new_params = funArgs `S.union` S.fromList args_params@@ -1020,8 +1023,8 @@     arrowArgRetType ::       (S.Set VName, [VName]) ->       S.Set VName ->-      RetTypeBase Size as' ->-      Writer (S.Set VName, S.Set VName) (RetTypeBase Size as')+      RetTypeBase Size o' ->+      Writer (S.Set VName, S.Set VName) (RetTypeBase Size o')     arrowArgRetType (scope', dimsToPush) argset' (RetType dims ty) = pass $ do       let dims' = dims <> dimsToPush       (ty', (_, canExt)) <- listen $ arrowArgType (argset' `S.union` scope', dims') ty@@ -1042,8 +1045,8 @@           case argName of             Unnamed -> argset'             Named vn -> S.insert vn argset'-    arrowArgScalar env (TypeVar u qn args) =-      TypeVar u qn <$> mapM arrowArgArg args+    arrowArgScalar env (TypeVar o qn args) =+      TypeVar o qn <$> mapM arrowArgArg args       where         arrowArgArg (TypeArgDim dim) = TypeArgDim <$> arrowArgSize dim         arrowArgArg (TypeArgType ty) = TypeArgType <$> arrowArgType env ty@@ -1051,10 +1054,10 @@      arrowArgType ::       (S.Set VName, [VName]) ->-      TypeBase Size as' ->-      Writer (S.Set VName, S.Set VName) (TypeBase Size as')-    arrowArgType env (Array u shape scalar) =-      Array u <$> traverse arrowArgSize shape <*> arrowArgScalar env scalar+      TypeBase Size o' ->+      Writer (S.Set VName, S.Set VName) (TypeBase Size o')+    arrowArgType env (Array o shape scalar) =+      Array o <$> traverse arrowArgSize shape <*> arrowArgScalar env scalar     arrowArgType env (Scalar ty) =       Scalar <$> arrowArgScalar env ty @@ -1062,27 +1065,27 @@     arrowArgSize s = pure s      -- \| arrowClean cleans the mess in the type-    arrowCleanRetType :: S.Set VName -> RetTypeBase Size as -> RetTypeBase Size as+    arrowCleanRetType :: S.Set VName -> RetTypeBase Size o -> RetTypeBase Size o     arrowCleanRetType paramed (RetType dims ty) =       RetType (nubOrd $ filter (`S.notMember` paramed) dims) (arrowCleanType (paramed `S.union` S.fromList dims) ty) -    arrowCleanScalar :: S.Set VName -> ScalarTypeBase Size as -> ScalarTypeBase Size as+    arrowCleanScalar :: S.Set VName -> ScalarTypeBase Size o -> ScalarTypeBase Size o     arrowCleanScalar paramed (Record fs) =       Record $ M.map (arrowCleanType paramed) fs     arrowCleanScalar paramed (Sum cs) =       Sum $ (M.map . map) (arrowCleanType paramed) cs     arrowCleanScalar paramed (Arrow as argName d argT retT) =       Arrow as argName d argT (arrowCleanRetType paramed retT)-    arrowCleanScalar paramed (TypeVar u qn args) =-      TypeVar u qn $ map arrowCleanArg args+    arrowCleanScalar paramed (TypeVar o qn args) =+      TypeVar o qn $ map arrowCleanArg args       where         arrowCleanArg (TypeArgDim dim) = TypeArgDim dim         arrowCleanArg (TypeArgType ty) = TypeArgType $ arrowCleanType paramed ty     arrowCleanScalar _ ty = ty -    arrowCleanType :: S.Set VName -> TypeBase Size as -> TypeBase Size as-    arrowCleanType paramed (Array u shape scalar) =-      Array u shape $ arrowCleanScalar paramed scalar+    arrowCleanType :: S.Set VName -> TypeBase Size o -> TypeBase Size o+    arrowCleanType paramed (Array o shape scalar) =+      Array o shape $ arrowCleanScalar paramed scalar     arrowCleanType paramed (Scalar ty) =       Scalar $ arrowCleanScalar paramed ty @@ -1090,7 +1093,60 @@ 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.+-- | Copy freshness from the instantiated type into the result of the declared+-- one. See 'freshenFromInst'.+freshenAsType :: TypeBase d Freshness -> TypeBase Size u -> TypeBase Size u+freshenAsType+  (Scalar (Arrow _ _ _ _ (RetType _ ir)))+  (Scalar (Arrow u pn d a (RetType ext r))) =+    Scalar $ Arrow u pn d a $ RetType ext (freshenAs ir r)+freshenAsType _ t = t++freshenAs :: TypeBase d Freshness -> ResType -> ResType+freshenAs it@(Scalar Arrow {}) t = freshenAsType it t+freshenAs (Scalar (Record ifs)) (Scalar (Record fs))+  | M.keys ifs == M.keys fs =+      Scalar $ Record $ M.intersectionWith freshenAs ifs fs+freshenAs (Scalar (Sum ics)) (Scalar (Sum cs))+  | M.keys ics == M.keys cs =+      Scalar $ Sum $ M.intersectionWith (zipWith freshenAs) ics cs+freshenAs it t+  -- 'setMode' writes every node, and 'freshness' of a record is Fresh+  -- if *any* field is, so this must not be reached for compound types.+  | compound it || compound t = t+  | freshness it == Fresh = t `setMode` Fresh+  | otherwise = t+  where+    compound (Scalar Record {}) = True+    compound (Scalar Sum {}) = True+    compound _ = False++-- | Consumption checking may refine the instantiated type of a polymorphic name+-- to say that its result is *fresh*, which the declared type cannot express.+-- The instantiation can, so take the freshness of the result from there, past+-- the given parameters. The declared return type must already have the type+-- substitution applied: a type parameter has a single mode, so where it is+-- instantiated at a record or sum, freshness can only be copied component by+-- component once the parameter has been replaced. See Note [Parametric+-- results] in Language.Futhark.TypeChecker.Consumption.+freshenFromInst :: TypeBase d Freshness -> [Pat ParamType] -> ResRetType -> ResRetType+freshenFromInst (Scalar (Arrow _ _ _ _ (RetType _ ir))) (_ : ps) rt =+  freshenFromInst ir ps rt+freshenFromInst it [] (RetType ext t) = RetType ext (freshenAs it t)+freshenFromInst _ _ rt = rt++-- | Recursion is monomorphic, so a recursive reference in the body of an+-- instance is to that same instance. Its type is the declared one, however,+-- without the freshness that 'freshenFromInst' copied into the instance, and+-- would otherwise give rise to a second instance that does not justify it.+freshenRecursive :: VName -> MonoType -> Exp -> Exp+freshenRecursive name inst_t = onExp+  where+    onExp (Var v (Info t) loc)+      | qualLeaf v == name =+          Var v (Info $ freshenAsType (second (const Nonfresh) inst_t) t) loc+    onExp e = runIdentity $ astMap identityMapper {mapOnExp = pure . onExp} e+ -- Monomorphises the body of the function as well. Returns the fresh name of the -- generated monomorphic function as well a function for constructing additional -- size arguments.@@ -1098,25 +1154,30 @@   PolyBinding ->   MonoType ->   MonoM (VName, InferSizeArgs)-monomorphiseBinding (PolyBinding (entry, name, tparams, params, rettype, body, attrs, loc)) inst_t = isolateNormalisation $ do-  let bind_t = funType params rettype+monomorphiseBinding (PolyBinding (entry, name, tparams, params0, rettype0, body, attrs, loc)) inst_t = isolateNormalisation $ do+  let bind_t = funType params0 rettype0   (substs, t_shape_params) <-     typeSubstsM loc bind_t $ noNamedParams inst_t   let shape_names = S.fromList $ map typeParamName $ shape_params ++ t_shape_params       substs' = M.map (Subst []) substs       substStructType =         substTypesAny (fmap (fmap (second (const mempty))) . (`M.lookup` substs'))-      params' = map (substPat substStructType) params+      params' = map (substPat substStructType) params0+      rettype =+        freshenFromInst+          (second (const Nonfresh) inst_t)+          params'+          (applySubst (`M.lookup` substs') rettype0)   params'' <- withArgs shape_names $ mapM transformPat params'   exp_naming <- getExpReplacements <* putExpReplacements mempty -  let args = S.fromList $ foldMap patNames params+  let args = S.fromList $ foldMap patNames params0       arg_params = map snd exp_naming    rettype' <-     withParams exp_naming $       withArgs (args <> shape_names) $-        hardTransformRetType (applySubst (`M.lookup` substs') rettype)+        hardTransformRetType rettype   extNaming <- getExpReplacements <* putExpReplacements mempty   scope <- S.union shape_names <$> askScope'   let (rettype'', new_params) = arrowArg scope args arg_params rettype'@@ -1138,20 +1199,21 @@   -- does not depend on the body.   seen_before <- elem name . map fst . M.keys <$> getLifts   name' <--    if null tparams && isNothing entry && not seen_before+    if not (any isTypeParam tparams) && isNothing entry && not seen_before       then pure name       else newName name -  let infer =+  let infer         -- If the function is an entry point, then it cannot possibly         -- need any explicit size arguments (checked by type checker).-        if isJust entry-          then const $ pure []-          else inferSizeArgs shape_params_explicit bind_t'' bind_r+        | isJust entry = const $ pure []+        | poly_value =+            fmap (<> [TupLit [] loc]) . inferSizeArgs shape_params_explicit bind_t'' bind_r+        | otherwise = inferSizeArgs shape_params_explicit bind_t'' bind_r    addLifted name inst_t (name', infer) -  body' <- updateExpTypes (`M.lookup` substs') body+  body' <- freshenRecursive name inst_t <$> updateExpTypes (`M.lookup` substs') body   body'' <- withParams exp_naming' $ withArgs (shape_names <> args) $ transformExp body'   scope' <- S.union (shape_names <> args) <$> askScope'   body''' <-@@ -1170,16 +1232,22 @@         toValBinding           name'           shape_params_implicit-          (map shapeParam shape_params_explicit ++ params'')+          (map shapeParam shape_params_explicit ++ params'' ++ unit_param)           rettype''           body'''    pure (name', infer)   where-    askScope' = S.filter (`notElem` retDims rettype) <$> askScope+    askScope' = S.filter (`notElem` retDims rettype0) <$> askScope      shape_params = filter (not . isTypeParam) tparams +    -- A polymorphic value becomes a function of @()@, so that each use computes+    -- it anew, as a size-polymorphic value is a function of its sizes.+    -- Consumption checking relies on this; see Note [Parametric results].+    poly_value = null params0 && any isTypeParam tparams && isNothing entry+    unit_param = [Wildcard (Info $ Scalar $ Record mempty) loc | poly_value]+     updateExpTypes substs = astMap (mapper substs)      hardTransformRetType (RetType dims ty) = do@@ -1248,7 +1316,7 @@     sub (Scalar Prim {}) (Scalar Prim {}) = pure ()     sub (Scalar (Arrow _ _ _ t1a (RetType _ t1b))) (Scalar (Arrow _ _ _ t2a t2b)) = do       sub t1a t2a-      subRet (toStruct t1b) (second (const NoUniqueness) t2b)+      subRet (toStruct t1b) (second (const NoMode) t2b)     sub (Scalar (Sum cs1)) (Scalar (Sum cs2)) =       zipWithM_ typeSubstClause (sortConstrs cs1) (sortConstrs cs2)       where
src/Futhark/Internalise/ReplaceRecords.hs view
@@ -58,7 +58,7 @@ lookupRecordReplacement :: VName -> RecordM (Maybe RecordReplacement) lookupRecordReplacement v = asks $ M.lookup v . envRecordReplacements -wildcard :: TypeBase Size u -> SrcLoc -> Pat (TypeBase Size u)+wildcard :: TypeBase Size o -> SrcLoc -> Pat (TypeBase Size o) wildcard (Scalar (Record fs)) loc =   RecordPat (zip (map (L noLoc) (M.keys fs)) $ map ((`Wildcard` loc) . Info) $ M.elems fs) loc wildcard t loc =@@ -93,14 +93,14 @@     }  transformPat ::-  (TypeBase Size u -> RecordM (TypeBase Size u)) ->-  Pat (TypeBase Size u) ->-  RecordM (Pat (TypeBase Size u), RecordReplacements)-transformPat _ (Id v (Info (Scalar (Record fs))) loc) = do+  (TypeBase Size o -> RecordM (TypeBase Size o)) ->+  Pat (TypeBase Size o) ->+  RecordM (Pat (TypeBase Size o), RecordReplacements)+transformPat onType (Id v (Info (Scalar (Record fs))) loc) = do   let fs' = M.toList fs   (fs_ks, fs_ts) <- fmap unzip $     forM fs' $ \(f, ft) ->-      (,) <$> newVName f <*> pure ft+      (,) <$> newVName f <*> onType ft   pure     ( RecordPat         (zip (map (L noLoc . fst) fs') (zipWith3 Id fs_ks (map Info fs_ts) $ repeat loc))@@ -193,7 +193,14 @@ onValBind vb = do   (params', rrs) <- mapAndUnzipM (transformPat transformParamType) $ valBindParams vb   e' <- withRecordReplacements (mconcat rrs) $ transformExp $ valBindBody vb-  ret <- traverse (bitraverse transformExp pure) $ valBindRetType vb+  -- The return type may mention record parameters through projections+  -- (e.g. a size @g.n@), so it must see the same substitutions as the+  -- body.  Otherwise the projection would be left referring to a+  -- parameter that the record pattern has replaced.+  ret <-+    withRecordReplacements (mconcat rrs) $+      traverse (bitraverse transformExp pure) $+        valBindRetType vb   memoClear   pure $     vb
src/Futhark/Internalise/TypesValues.hs view
@@ -38,10 +38,22 @@ import Futhark.Util (chunkLike) import Language.Futhark qualified as E -internaliseUniqueness :: E.Uniqueness -> I.Uniqueness-internaliseUniqueness E.Nonunique = I.Nonunique-internaliseUniqueness E.Unique = I.Unique+-- | The 'E.Diet' of a source parameter becomes the 'I.Diet' of the+-- internalised parameter; the two types coincide.+internaliseDiet :: E.Diet -> I.Diet+internaliseDiet E.Observe = I.Observe+internaliseDiet E.Consume = I.Consume +-- | The mode of an array type, if it is an array. Used to ask whether aliasing+-- is permitted at a position, which is 'E.Nonfresh' for a result and+-- 'I.Observe' for a parameter.+arrayMode :: TypeBase shape o -> Maybe o+arrayMode (Array _ _ o) = Just o+arrayMode _ = Nothing++aliasableArray :: (o -> Bool) -> TypeBase shape o -> Bool+aliasableArray p = maybe False p . arrayMode+ newtype TypeState = TypeState {typeCounter :: Int}  newtype InternaliseTypeM a@@ -56,12 +68,12 @@  internaliseParamTypes ::   [E.ParamType] ->-  InternaliseM [[Tree (I.TypeBase Shape Uniqueness)]]+  InternaliseM [[Tree (I.TypeBase Shape I.Diet)]] internaliseParamTypes ts =   mapM (mapM (mapM mkAccCerts)) . runInternaliseTypeM $-    mapM (fmap (map (fmap onType)) . internaliseTypeM mempty . E.paramToRes) ts+    mapM (fmap (map (fmap onType)) . internaliseTypeM mempty) ts   where-    onType = fromMaybe bad . hasStaticShape+    onType = second internaliseDiet . fromMaybe bad . hasStaticShape     bad = error $ "internaliseParamTypes: " ++ prettyString ts  -- Replace an accumulator's token, index space, and element types with those of@@ -70,25 +82,25 @@ -- and a guessed index space. The known type is computed elsewhere (from -- concrete loop values, or from an accumulator parameter). fixupAcc :: TypeBase shape1 u1 -> (TypeBase shape2 u2, b) -> (TypeBase shape2 u2, b)-fixupAcc (Acc acc ispace ts _) (Acc _ _ _ u, b) = (Acc acc ispace ts u, b)+fixupAcc (Acc acc ispace ts) (Acc {}, b) = (Acc acc ispace ts, b) fixupAcc _ t = t  -- Fix up accumulators using a positionally-matching list of concrete -- types (e.g. the actual types of loop values). fixupKnownTypes ::-  [TypeBase shape1 u1] ->-  [(TypeBase shape2 u2, b)] ->-  [(TypeBase shape2 u2, b)]+  [TypeBase shape1 o1] ->+  [(TypeBase shape2 o2, b)] ->+  [(TypeBase shape2 o2, b)] fixupKnownTypes = zipWith fixupAcc  -- Generate proper certificates for the placeholder accumulator -- certificates produced by internaliseType (identified with tag 0). -- Only needed when we cannot use 'fixupKnownTypes'.-mkAccCerts :: TypeBase shape u -> InternaliseM (TypeBase shape u)-mkAccCerts (Array pt shape u) =-  pure $ Array pt shape u-mkAccCerts (Acc c shape ts u) =-  Acc <$> c' <*> pure shape <*> pure ts <*> pure u+mkAccCerts :: TypeBase shape o -> InternaliseM (TypeBase shape o)+mkAccCerts (Array pt shape o) =+  pure $ Array pt shape o+mkAccCerts (Acc c shape ts) =+  Acc <$> c' <*> pure shape <*> pure ts   where     c'       | baseTag c == 0 = newVName "acc_cert"@@ -97,8 +109,8 @@  internaliseLoopParamType ::   E.ParamType ->-  [TypeBase shape u] ->-  InternaliseM [I.TypeBase Shape Uniqueness]+  [TypeBase shape o] ->+  InternaliseM [I.TypeBase Shape Diet] internaliseLoopParamType et ts =   map fst . fixupKnownTypes ts . map (,()) . concatMap (concatMap toList)     <$> internaliseParamTypes [et]@@ -116,10 +128,6 @@ numberTrees :: [Tree a] -> [Tree (a, Int)] numberTrees = map (uncurry $ flip numberFrom) . withOffsets -nonuniqueArray :: TypeBase shape Uniqueness -> Bool-nonuniqueArray t@Array {} = not $ unique t-nonuniqueArray _ = False- matchTrees :: Tree a -> Tree b -> Maybe (Tree (a, b)) matchTrees (Pure a) (Pure b) = Just $ Pure (a, b) matchTrees (Free as) (Free bs)@@ -137,21 +145,23 @@  -- See Note [Alias Inference]. inferAliases ::-  [Tree (I.TypeBase Shape Uniqueness)] ->-  [Tree (I.TypeBase ExtShape Uniqueness)] ->-  [[(I.TypeBase ExtShape Uniqueness, RetAls)]]+  [Tree (I.TypeBase Shape I.Diet)] ->+  [Tree (I.TypeBase ExtShape E.Freshness)] ->+  [[(I.TypeBase ExtShape E.Freshness, RetAls)]] inferAliases all_param_ts all_res_ts =   map onRes all_res_ts   where     all_res_ts' = numberTrees all_res_ts     all_param_ts' = numberTrees all_param_ts-    aliasable_param_ts = filter (all $ nonuniqueArray . fst) all_param_ts'-    aliasable_res_ts = filter (all $ nonuniqueArray . fst) all_res_ts'+    observed = aliasableArray (== I.Observe)+    nonfresh = aliasableArray (== E.Nonfresh)+    aliasable_param_ts = filter (all $ observed . fst) all_param_ts'+    aliasable_res_ts = filter (all $ nonfresh . fst) all_res_ts'     onRes (Pure res_t) =       -- Necessarily a non-array.       [(res_t, RetAls mempty mempty)]     onRes (Free res_ts) =-      [ if nonuniqueArray res_t+      [ if nonfresh res_t           then (res_t, RetAls pals rals)           else (res_t, mempty)       | (res_t, pals, rals) <- zip3 (toList (Free res_ts)) palss ralss@@ -165,12 +175,15 @@         palss = infer aliasable_param_ts         ralss = infer aliasable_res_ts +-- | The mode of the source-level return type is used to compute the+-- 'RetAls', and then discarded: an IR return type says nothing about+-- aliasing on its own. internaliseReturnType ::-  [Tree (I.TypeBase Shape Uniqueness)] ->+  [Tree (I.TypeBase Shape I.Diet)] ->   E.ResRetType ->-  [(I.TypeBase ExtShape Uniqueness, RetAls)]+  [(I.TypeBase ExtShape NoMode, RetAls)] internaliseReturnType paramts (E.RetType dims et) =-  fixupAccs . concat . inferAliases paramts $+  map (first I.fromDecl) . fixupAccs . concat . inferAliases paramts $     runInternaliseTypeM' dims (internaliseTypeM exts et)   where     exts = M.fromList $ zip dims [0 ..]@@ -183,9 +196,9 @@ -- | As 'internaliseReturnType', but returns components of a top-level -- tuple type piecemeal. internaliseEntryReturnType ::-  [Tree (I.TypeBase Shape Uniqueness)] ->+  [Tree (I.TypeBase Shape I.Diet)] ->   E.ResRetType ->-  [[(I.TypeBase ExtShape Uniqueness, RetAls)]]+  [[(I.TypeBase ExtShape E.Freshness, RetAls)]] internaliseEntryReturnType paramts (E.RetType dims et) =   let et' = runInternaliseTypeM' dims . mapM (internaliseTypeM exts) $         case E.isTupleRecord et of@@ -197,22 +210,22 @@  internaliseCoerceType ::   E.StructType ->-  [I.TypeBase ExtShape Uniqueness]+  [I.TypeBase ExtShape NoMode] internaliseCoerceType et =-  map fst $ internaliseReturnType [] (E.RetType [] $ E.toRes E.Nonunique et)+  map fst $ internaliseReturnType [] (E.RetType [] $ E.toRes E.Nonfresh et)  internaliseLambdaReturnType ::   E.ResType ->-  [TypeBase shape u] ->-  InternaliseM [I.TypeBase Shape NoUniqueness]+  [TypeBase shape o] ->+  InternaliseM [I.TypeBase Shape NoMode] internaliseLambdaReturnType et ts =   map fromDecl <$> internaliseLoopParamType (E.resToParam et) ts  internaliseType ::-  E.TypeBase E.Size NoUniqueness ->-  [Tree (I.TypeBase I.ExtShape Uniqueness)]+  E.TypeBase E.Size NoMode ->+  [Tree (I.TypeBase I.ExtShape NoMode)] internaliseType =-  runInternaliseTypeM . internaliseTypeM mempty . E.toRes E.Nonunique+  runInternaliseTypeM . internaliseTypeM mempty  newId :: InternaliseTypeM Int newId = do@@ -244,16 +257,21 @@ -- have a 'Pure' at the top level.  See Note [Alias Inference]. type Tree = Free [] +-- | Internalise a source type, preserving whatever mode it carries: a+-- 'E.Diet' for a parameter type, a 'E.Freshness' for a return type.+-- Which of the two it is matters to 'inferAliases', so it is not+-- collapsed here. internaliseTypeM ::+  (Pretty o) =>   M.Map VName Int ->-  E.ResType ->-  InternaliseTypeM [Tree (I.TypeBase ExtShape Uniqueness)]+  E.TypeBase E.Size o ->+  InternaliseTypeM [Tree (I.TypeBase ExtShape o)] internaliseTypeM exts orig_t =   case orig_t of-    E.Array u shape et -> do+    E.Array o shape et -> do       dims <- internaliseShape shape-      ets <- internaliseTypeM exts $ E.toRes E.Nonunique $ E.Scalar et-      let f et' = I.arrayOf et' (Shape dims) $ internaliseUniqueness u+      ets <- internaliseTypeM exts $ E.Scalar et+      let f et' = I.arrayOf et' (Shape dims) o       pure [array $ map (fmap f) ets]     E.Scalar (E.Prim bt) ->       pure [Pure $ I.Prim $ internalisePrimType bt]@@ -263,16 +281,15 @@       | null ets -> pure [Pure $ I.Prim I.Unit]       | otherwise ->           concat <$> mapM (internaliseTypeM exts . snd) (E.sortFields ets)-    E.Scalar (E.TypeVar u tn [E.TypeArgType arr_t])+    E.Scalar (E.TypeVar _ tn [E.TypeArgType arr_t])       | E.isIntrinsic (E.qualLeaf tn),         baseName (E.qualLeaf tn) == "acc" -> do           ts <--            foldMap (toList . fmap (fromDecl . onAccType))-              <$> internaliseTypeM exts (E.toRes Nonunique arr_t)+            foldMap (toList . fmap onAccType)+              <$> internaliseTypeM exts arr_t           let acc_param = VName "PLACEHOLDER" 0 -- See mkAccCerts.               acc_shape = Shape [arraysSize 0 ts]-              u' = internaliseUniqueness u-              acc_t = Acc acc_param acc_shape (map rowType ts) u'+              acc_t = Acc acc_param acc_shape (map rowType ts)           pure [Pure acc_t]     E.Scalar E.TypeVar {} ->       error $ "internaliseTypeM: cannot handle type variable: " ++ prettyString orig_t@@ -296,23 +313,24 @@  -- | Only exposed for testing purposes. internaliseConstructors ::-  M.Map Name [Tree (I.TypeBase ExtShape Uniqueness)] ->-  ( [Tree (I.TypeBase ExtShape Uniqueness)],+  M.Map Name [Tree (I.TypeBase ExtShape o)] ->+  ( [Tree (I.TypeBase ExtShape o)],     [(Name, [Int])]   ) internaliseConstructors cs =   L.mapAccumL onConstructor mempty $ E.sortConstrs cs   where+    unmoded = fromDecl     onConstructor ts (c, c_ts) =       let (_, js, new_ts) =-            foldl' f (withOffsets (map (fmap fromDecl) ts), mempty, mempty) c_ts+            foldl' f (withOffsets (map (fmap unmoded) ts), mempty, mempty) c_ts        in (ts ++ new_ts, (c, js))       where         size = sum . map length         f (ts', js, new_ts) t           | all primType t,-            Just (_, j) <- find ((== fmap fromDecl t) . fst) ts' =-              ( delete (fmap fromDecl t, j) ts',+            Just (_, j) <- find ((== fmap unmoded t) . fst) ts' =+              ( delete (fmap unmoded t, j) ts',                 js ++ take (length t) [j ..],                 new_ts               )@@ -324,18 +342,18 @@  internaliseSumTypeRep ::   M.Map Name [E.StructType] ->-  ( [I.TypeBase ExtShape Uniqueness],+  ( [I.TypeBase ExtShape NoMode],     [(Name, [Int])]   ) internaliseSumTypeRep cs =   first (foldMap toList) . runInternaliseTypeM $     internaliseConstructors-      <$> traverse (fmap concat . mapM (internaliseTypeM mempty . E.toRes E.Nonunique)) cs+      <$> traverse (fmap concat . mapM (internaliseTypeM mempty)) cs  internaliseSumType ::   M.Map Name [E.StructType] ->   InternaliseM-    ( [I.TypeBase ExtShape Uniqueness],+    ( [I.TypeBase ExtShape NoMode],       [(Name, [Int])]     ) internaliseSumType =@@ -343,7 +361,7 @@  -- | How many core language values are needed to represent one source -- language value of the given type?-internalisedTypeSize :: E.TypeBase E.Size als -> Int+internalisedTypeSize :: E.TypeBase E.Size o -> Int -- A few special cases for performance. internalisedTypeSize (E.Scalar (E.Prim _)) = 1 internalisedTypeSize (E.Array _ _ (E.Prim _)) = 1@@ -367,7 +385,7 @@ -- -- The core language requires us to precisely indicate the aliasing of -- function results (the RetAls type).  This is a problem when coming--- from the source language, where it is implicit: a non-unique+-- from the source language, where it is implicit: a nonfresh -- function return value aliases every function argument.  The problem -- now occurs because the core language uses a different value -- representation than the source language - in particular, we do not
src/Futhark/LSP/CodeLens.hs view
@@ -26,7 +26,7 @@ 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.Eval (EvalConfig (evalFile, evalPrintWarnings), Evaluation (abort), evalConfig, newInterpreterState, runEvalRecordRef, runExpr) import Futhark.LSP.CommandType qualified as CommandType import Futhark.LSP.Tool (Execute, transformVFS) import Futhark.Util (showText)@@ -287,15 +287,15 @@           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+          let evalConfig' = evalConfig {evalPrintWarnings = False, evalFile = filePath}            -- load the file the expression is located in           interpreterState <--            newFutharkiState interpreterConfig filePath currentVFS+            newInterpreterState evalConfig' currentVFS               >>= either abort pure            liftIO setupLimits
src/Futhark/Optimise/ArrayShortCircuiting.hs view
@@ -56,9 +56,9 @@         MemMem _           | Just entry <- M.lookup name coalstab ->               (oneName (dstmem entry) <> to_remove, Param attrs (dstmem entry) dec : acc)-        MemArray pt shp u (ArrayIn m ixf)+        MemArray pt shp o (ArrayIn m ixf)           | Just entry <- M.lookup m coalstab ->-              (to_remove, Param attrs name (MemArray pt shp u $ ArrayIn (dstmem entry) ixf) : acc)+              (to_remove, Param attrs name (MemArray pt shp o $ ArrayIn (dstmem entry) ixf) : acc)         _ -> (to_remove, Param attrs name dec : acc)  removeAllocsInStms :: Stms rep -> UpdateM inner (Stms rep)@@ -131,10 +131,26 @@   pure $ Let (Pat elems') (StmAux c' a loc d) e'   where     replaceInPatElem :: PatElem LetDecMem -> UpdateM inner (PatElem LetDecMem)-    replaceInPatElem p@(PatElem vname (MemArray _ _ u _)) =-      fromMaybe p <$> lookupAndReplace vname PatElem u+    replaceInPatElem p@(PatElem vname (MemArray _ _ o _)) =+      fromMaybe p <$> lookupAndReplace vname PatElem o+    -- Memory bound here whose arrays now live in the destination is declared in+    -- the space of the destination; see Note [Short-circuiting across memory+    -- spaces]. This concerns only the existential memory of those expressions+    -- whose results we replace, as an allocation that has been coalesced away+    -- merely becomes dead, and keeps its space until then.+    replaceInPatElem p@(PatElem vname (MemMem _))+      | results_replaced = do+          coaltab <- asks envCoalesceTab+          pure $ case M.lookup vname coaltab of+            Just entry -> PatElem vname $ MemMem $ dstspace entry+            Nothing -> p     replaceInPatElem p = pure p +    results_replaced = case e of+      Match {} -> True+      Loop {} -> True+      _ -> False+ replaceInExp ::   (Mem rep inner, LetDec rep ~ LetDecMem) =>   [PatElem LetDecMem] ->@@ -192,15 +208,20 @@ generalizeIxfun   pat_elems   (PatElem vname (MemArray _ _ _ (ArrayIn mem ixf)))-  m@(MemArray pt shp u _) = do+  m@(MemArray pt shp o _) = do     coaltab <- asks envCoalesceTab     if any (M.member vname . vartab) coaltab       then         existentialiseLMAD (map patElemName pat_elems) ixf           & ReturnsInBlock mem-          & MemArray pt shp u+          & MemArray pt shp o           & pure       else pure m+generalizeIxfun _ (PatElem vname (MemMem _)) m@(MemMem _) = do+  coaltab <- asks envCoalesceTab+  pure $ case M.lookup vname coaltab of+    Just entry -> MemMem $ dstspace entry+    Nothing -> m generalizeIxfun _ _ m = pure m  replaceInIfBody :: (Mem rep inner, LetDec rep ~ LetDecMem) => Body rep -> UpdateM (inner rep) (Body rep)@@ -210,23 +231,23 @@   pure $ b {bodyStms = stms', bodyResult = map (replaceResMem coaltab) res}  replaceInFParam :: Param FParamMem -> UpdateM inner (Param FParamMem)-replaceInFParam p@(Param _ vname (MemArray _ _ u _)) = do-  fromMaybe p <$> lookupAndReplace vname (Param mempty) u+replaceInFParam p@(Param _ vname (MemArray _ _ o _)) = do+  fromMaybe p <$> lookupAndReplace vname (Param mempty) o replaceInFParam p = pure p  lookupAndReplace ::   VName ->-  (VName -> MemBound u -> a) ->-  u ->+  (VName -> MemBound o -> a) ->+  o ->   UpdateM inner (Maybe a)-lookupAndReplace vname f u = do+lookupAndReplace vname f o = do   coaltab <- asks envCoalesceTab   case M.lookup vname $ foldMap vartab coaltab of     Just (Coalesced _ (MemBlock pt shp mem ixf) subs) ->       ixf         & fixPoint (LMAD.substitute subs)         & ArrayIn mem-        & MemArray pt shp u+        & MemArray pt shp o         & f vname         & Just         & pure
src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs view
@@ -21,6 +21,7 @@ import Data.Maybe import Data.Sequence (Seq (..)) import Data.Set qualified as S+import Futhark.Analysis.AlgSimplify qualified as AlgSimplify import Futhark.Analysis.LastUse import Futhark.Analysis.PrimExp.Convert import Futhark.IR.Aliases@@ -72,7 +73,10 @@       Pat (VarAliases, LetDecMem) ->       Certs ->       Op (Aliases rep) ->-      Maybe [SSPointInfo]+      Maybe [SSPointInfo],+    -- | Can an array in the second space be moved into a memory block in the+    -- first? See Note [Short-circuiting across memory spaces].+    spaceOK :: Space -> Space -> Bool   }  newtype ShortCircuitM rep a = ShortCircuitM (ReaderT (ShortCircuitReader rep) (State VNameSource) a)@@ -115,7 +119,7 @@ mkCoalsTab prog =   mkCoalsTabProg     (lastUseSeqMem prog)-    (ShortCircuitReader shortCircuitSeqMem genSSPointInfoSeqMem)+    (ShortCircuitReader shortCircuitSeqMem genSSPointInfoSeqMem hostSpaceOK)     (ComputeScalarTableOnOp $ const $ const $ pure mempty)     prog @@ -125,7 +129,7 @@ mkCoalsTabGPU prog =   mkCoalsTabProg     (lastUseGPUMem prog)-    (ShortCircuitReader shortCircuitGPUMem genSSPointInfoGPUMem)+    (ShortCircuitReader shortCircuitGPUMem genSSPointInfoGPUMem (==))     (ComputeScalarTableOnOp (computeScalarTableMemOp computeScalarTableGPUMem))     prog @@ -135,7 +139,7 @@ mkCoalsTabMC prog =   mkCoalsTabProg     (lastUseMCMem prog)-    (ShortCircuitReader shortCircuitMCMem genSSPointInfoMCMem)+    (ShortCircuitReader shortCircuitMCMem genSSPointInfoMCMem hostSpaceOK)     (ComputeScalarTableOnOp (computeScalarTableMemOp computeScalarTableMCMem))     prog @@ -153,7 +157,7 @@     consts_scope = scopeOf (progConsts prog)     onFun fun@(FunDef _ _ fname _ fpars body) = do       -- First compute last-use information-      let unique_mems = getUniqueMemFParam fpars+      let consuming_mems = getConsumingMemFParam fpars           lutab = lutab_prog M.! fname           scalar_table =             runReader@@ -169,7 +173,7 @@           topenv =             emptyTopdownEnv               { scope = consts_scope <> scopeOfFParams fpars,-                alloc = unique_mems,+                alloc = consuming_mems,                 scalarTable = scalar_table,                 nonNegatives = foldMap paramSizes fpars               }@@ -556,7 +560,7 @@               ( active                   <> M.singleton                     return_mem-                    (CoalsEntry pat_mem pat_ixf (oneName pat_mem) vtab mempty mempty pat_certs),+                    (CoalsEntry pat_mem pat_space pat_ixf (oneName pat_mem) vtab mempty mempty pat_certs),                 inhb               )             _ -> (active, inhb)@@ -580,6 +584,7 @@                       return_mem                       ( CoalsEntry                           (dstmem trans)+                          (dstspace trans)                           (dstind trans)                           (oneName pat_mem <> alsmem trans)                           vtab@@ -619,23 +624,28 @@   let succ_tab = successCoals buenv       actv_tab = activeCoals buenv       inhb_tab = inhibit buenv-      -- Allow short-circuiting function parameters that are unique and have-      -- matching index functions, otherwise mark as failed-      handleFunctionParams (a, i, s) (_, u, MemBlock _ _ m ixf) =-        case (u, M.lookup m a) of-          (Unique, Just entry)-            | dstind entry == ixf,+      -- See Note [Short-circuiting function parameters].+      handleFunctionParams (a, i, s, claimed) (p, o, MemBlock pt _ m ixf) =+        case (o, M.lookup m a) of+          (Consume, Just entry)+            | Just (Coalesced _ (MemBlock _ _ _ p_ixf) _) <- M.lookup p $ vartab entry,+              p_ixf == ixf,               Set dst_uses <- dstrefs (memrefs entry),-              dst_uses == mempty ->+              dst_uses == mempty,+              LMAD.isDirect ixf,+              Just size <- M.lookup (dstmem entry) top_allocs,+              sameSize (scalarTable topenv) (pe64 size) $+                primByteSize pt * product (LMAD.shape ixf),+              dstmem entry `notNameIn` claimed ->                 let (a', s') = markSuccessCoal (a, s) m entry-                 in (a', i, s')+                 in (a', i, s', oneName (dstmem entry) <> claimed)           _ ->             let (a', i') = markFailedCoal (a, i) m-             in (a', i', s)-      (actv_tab', inhb_tab', succ_tab') =+             in (a', i', s, claimed)+      (actv_tab', inhb_tab', succ_tab', _) =         foldl           handleFunctionParams-          (actv_tab, inhb_tab, succ_tab)+          (actv_tab, inhb_tab, succ_tab, mempty)           $ getArrMemAssocFParam fpar        (succ_tab'', failed_optdeps) = fixPointFilterDeps succ_tab' M.empty@@ -647,6 +657,10 @@         then pure succ_tab''         else fixPointCoalesce lutab fpar bdy (topenv {inhibited = inhb_tab''})   where+    top_allocs = M.fromList $ mapMaybe isAlloc $ stmsToList $ bodyStms bdy+    isAlloc (Let (Pat [pe]) _ (Op (Alloc size _))) = Just (patElemName pe, size)+    isAlloc _ = Nothing+     fixPointFilterDeps :: CoalsTab -> InhibitTab -> (CoalsTab, InhibitTab)     fixPointFilterDeps coaltab inhbtab =       let (coaltab', inhbtab') = foldl filterDeps (coaltab, inhbtab) (M.keys coaltab)@@ -671,6 +685,13 @@       | Just coal_etry <- M.lookup mr coal = not $ r `M.member` vartab coal_etry     failedOptDep _ _ _ = error "In ArrayCoalescing.hs, fun failedOptDep, impossible case reached!" +-- | Are these two sizes certainly equal, after expanding the scalars in the+-- table?+sameSize :: ScalarTab -> TPrimExp Int64 VName -> TPrimExp Int64 VName -> Bool+sameSize scals x y =+  null . AlgSimplify.simplify0 . fixPoint (substituteInPrimExp scals) . untyped $+    x - y+ -- | Perform short-circuiting on 'Stms'. mkCoalsTabStms ::   (Coalesceable rep inner) =>@@ -1020,6 +1041,9 @@         Var a0 <- ini,         Var r <- bdyres,         Just coal_etry <- M.lookup m_b actv0,+        -- A loop-carried array stays in its own space - see Note+        -- [Short-circuiting across memory spaces].+        memSpace td_env_allocs m_b == Just (dstspace coal_etry),         Just _ <- M.lookup b (vartab coal_etry),         Just (MemBlock _ _ m_a _) <- getScopeMemInfo a (scope td_env_allocs),         Just (MemBlock _ _ m_a0 _) <- getScopeMemInfo a0 (scope td_env_allocs),@@ -1218,7 +1242,7 @@     foldfun safe_4 ((a_acc, inhb), s_acc) (b, MemBlock tp shp mb _b_indfun) =       case M.lookup mb a_acc of         Nothing -> ((a_acc, inhb), s_acc)-        Just info@(CoalsEntry x_mem _ _ vtab _ _ certs) ->+        Just info@(CoalsEntry x_mem _ _ _ vtab _ _ certs) ->           let failed = markFailedCoal (a_acc, inhb) mb            in case M.lookup b vtab of                 Nothing ->@@ -1295,7 +1319,7 @@           -- If it is an array in memory block m_b           case M.lookup m_b acc of             Nothing -> (acc, inhb)-            Just info@(CoalsEntry x_mem _ _ vtab _ _ certs) ->+            Just info@(CoalsEntry x_mem _ _ _ vtab _ _ certs) ->               -- And m_b we're trying to coalesce m_b               let failed = markFailedCoal (acc, inhb) m_b                in -- It is not safe to short circuit if some other pattern@@ -1361,57 +1385,60 @@       let proper_coals_tab = case knd of             InPlaceCoal -> activeCoals_tab             _ -> successCoals_tab-          (m_yx, ind_yx, mem_yx_al, x_deps, certs') =+          (m_yx, space_yx, ind_yx, mem_yx_al, x_deps, certs') =             case M.lookup m_x proper_coals_tab of               Nothing ->-                (m_x, alias_fn ind_x, oneName m_x, M.empty, mempty)-              Just (CoalsEntry m_y ind_y y_al vtab x_deps0 _ certs'') ->+                (m_x, memSpace td_env m_x, alias_fn ind_x, oneName m_x, M.empty, mempty)+              Just (CoalsEntry m_y m_y_space ind_y y_al vtab x_deps0 _ certs'') ->                 let ind = case M.lookup x vtab of                       Just (Coalesced _ (MemBlock _ _ _ ixf) _) ->                         ixf                       Nothing ->                         ind_y-                 in (m_y, alias_fn ind, oneName m_x <> y_al, x_deps0, certs <> certs'')+                 in (m_y, Just m_y_space, alias_fn ind, oneName m_x <> y_al, x_deps0, certs <> certs'')           m_b_aliased_m_yx = areAnyAliased td_env m_b [m_yx] -- m_b \= m_yx-       in if not m_b_aliased_m_yx && isInScope td_env m_yx -- nameIn m_yx (alloc td_env)-      -- Finally update the @activeCoals@ table with a fresh-      --   binding for @m_b@; if such one exists then overwrite.-      -- Also, add all variables from the alias chain of @b@ to-      --   @vartab@, for example, in the case of a sequence:-      --   @ b0 = if cond then ... else ... @-      --   @ b1 = alias0 b0 @-      --   @ b  = alias1 b1 @-      --   @ x[j] = b @-      -- Then @b1@ and @b0@ should also be added to @vartab@ if-      --   @alias1@ and @alias0@ are invertible, otherwise fail early!-            then-              let mem_info = Coalesced knd (MemBlock tp_b shp_b m_yx ind_yx) M.empty-                  opts' =-                    if m_yx == m_x-                      then M.empty-                      else M.insert x m_x x_deps-                  vtab = M.singleton b mem_info-                  mvtab = addInvAliasesVarTab td_env vtab b+          -- Finally update the @activeCoals@ table with a fresh+          --   binding for @m_b@; if such one exists then overwrite.+          -- Also, add all variables from the alias chain of @b@ to+          --   @vartab@, for example, in the case of a sequence:+          --   @ b0 = if cond then ... else ... @+          --   @ b1 = alias0 b0 @+          --   @ b  = alias1 b1 @+          --   @ x[j] = b @+          -- Then @b1@ and @b0@ should also be added to @vartab@ if+          --   @alias1@ and @alias0@ are invertible, otherwise fail early!+       in case space_yx of+            Just space_yx'+              | not m_b_aliased_m_yx,+                isInScope td_env m_yx -> -- nameIn m_yx (alloc td_env)+                  let mem_info = Coalesced knd (MemBlock tp_b shp_b m_yx ind_yx) M.empty+                      opts' =+                        if m_yx == m_x+                          then M.empty+                          else M.insert x m_x x_deps+                      vtab = M.singleton b mem_info+                      mvtab = addInvAliasesVarTab td_env vtab b -                  is_inhibited = case M.lookup m_b $ inhibited td_env of-                    Just nms -> m_yx `nameIn` nms-                    Nothing -> False-               in case (is_inhibited, mvtab) of-                    (True, _) -> acc -- fail due to inhibited-                    (_, Nothing) -> acc -- fail early due to non-invertible aliasing-                    (_, Just vtab') ->-                      -- successfully adding a new coalesced entry-                      let coal_etry =-                            CoalsEntry-                              m_yx-                              ind_yx-                              mem_yx_al-                              vtab'-                              opts'-                              mempty-                              (certs <> certs')-                       in M.insert m_b coal_etry acc-            else acc+                      is_inhibited = case M.lookup m_b $ inhibited td_env of+                        Just nms -> m_yx `nameIn` nms+                        Nothing -> False+                   in case (is_inhibited, mvtab) of+                        (True, _) -> acc -- fail due to inhibited+                        (_, Nothing) -> acc -- fail early due to non-invertible aliasing+                        (_, Just vtab') ->+                          -- successfully adding a new coalesced entry+                          let coal_etry =+                                CoalsEntry+                                  m_yx+                                  space_yx'+                                  ind_yx+                                  mem_yx_al+                                  vtab'+                                  opts'+                                  mempty+                                  (certs <> certs')+                           in M.insert m_b coal_etry acc+            _ -> acc  -- | Information about a particular short-circuit point type SSPointInfo =@@ -1452,8 +1479,8 @@ --  only the values from the 'SegSpace'. -- --  3. The array being indexed is last-used in that statement, is free in the---  'SegMap', is unique or has been recently allocated (specifically, it should---  not be a non-unique argument to the enclosing function), has elements with+--  'SegMap', is consumed or has been recently allocated (specifically, it should+--  not be a non-consumed argument to the enclosing function), has elements with --  the same bit-size as the pattern elements, and has the exact same 'LMAD' as --  the pattern of the 'SegMap' statement. --@@ -1491,8 +1518,8 @@             getScopeMemInfo src scopetab,           src_mem `nameIn` last_uses,           -- The 'alloc' table contains allocated memory blocks, including-          -- unique memory blocks from the enclosing function. It does _not_-          -- include non-unique memory blocks from the enclosing function.+          -- consumed memory blocks from the enclosing function. It does _not_+          -- include non-consumed memory blocks from the enclosing function.           src_mem `M.member` alloc td_env,           src `nameIn` frees,           src_ixf == dst_ixf,@@ -1537,17 +1564,15 @@   | Pat [PatElem x (_, MemArray _ _ _ (ArrayIn m_x ind_x))] <- pat,     Just last_uses <- M.lookup x lutab,     Just (MemBlock tpb shpb m_b ind_b) <- getScopeMemInfo b scopetab,-    sameSpace td_env m_x m_b,     b `nameIn` last_uses =-      pure $ Just [(CopyCoal, id, x, m_x, ind_x, b, m_b, ind_b, tpb, shpb, stmAuxCerts aux)]+      ifMemsCompatible td_env m_x m_b [(CopyCoal, id, x, m_x, ind_x, b, m_b, ind_b, tpb, shpb, stmAuxCerts aux)] -- CASE c) @let x[i] = b^{lu}@ genCoalStmtInfo lutab td_env scopetab (Let pat aux (BasicOp (Update _ x slice_x (Var b))))   | Pat [PatElem x' (_, MemArray _ _ _ (ArrayIn m_x ind_x))] <- pat,     Just last_uses <- M.lookup x' lutab,     Just (MemBlock tpb shpb m_b ind_b) <- getScopeMemInfo b scopetab,-    sameSpace td_env m_x m_b,     b `nameIn` last_uses =-      pure $ Just [(InPlaceCoal, (`updateIndFunSlice` slice_x), x, m_x, ind_x, b, m_b, ind_b, tpb, shpb, stmAuxCerts aux)]+      ifMemsCompatible td_env m_x m_b [(InPlaceCoal, (`updateIndFunSlice` slice_x), x, m_x, ind_x, b, m_b, ind_b, tpb, shpb, stmAuxCerts aux)]   where     updateIndFunSlice :: LMAD -> Slice SubExp -> LMAD     updateIndFunSlice ind_fun slc_x =@@ -1557,9 +1582,8 @@   | Pat [PatElem x' (_, MemArray _ _ _ (ArrayIn m_x ind_x))] <- pat,     Just last_uses <- M.lookup x' lutab,     Just (MemBlock tpb shpb m_b ind_b) <- getScopeMemInfo b scopetab,-    sameSpace td_env m_x m_b,     b `nameIn` last_uses =-      pure $ Just [(InPlaceCoal, (`updateIndFunSlice` slice_x), x, m_x, ind_x, b, m_b, ind_b, tpb, shpb, stmAuxCerts aux)]+      ifMemsCompatible td_env m_x m_b [(InPlaceCoal, (`updateIndFunSlice` slice_x), x, m_x, ind_x, b, m_b, ind_b, tpb, shpb, stmAuxCerts aux)]   where     updateIndFunSlice :: LMAD -> FlatSlice SubExp -> LMAD     updateIndFunSlice ind_fun (FlatSlice offset dims) =@@ -1568,18 +1592,19 @@ -- CASE b) @let x = concat(a, b^{lu})@ genCoalStmtInfo lutab td_env scopetab (Let pat aux (BasicOp (Concat concat_dim (b0 :| bs) _)))   | Pat [PatElem x (_, MemArray _ _ _ (ArrayIn m_x ind_x))] <- pat,-    Just last_uses <- M.lookup x lutab =-      pure $-        let (res, _, _) = foldl (markConcatParts last_uses x m_x ind_x) ([], zero, True) (b0 : bs)-         in if null res then Nothing else Just res+    Just last_uses <- M.lookup x lutab = do+      space_ok <- asks spaceOK+      let compatible = memsCompatible space_ok td_env m_x+          (res, _, _) = foldl (markConcatParts compatible last_uses x m_x ind_x) ([], zero, True) (b0 : bs)+      pure $ if null res then Nothing else Just res   where     zero = pe64 $ intConst Int64 0-    markConcatParts _ _ _ _ acc@(_, _, False) _ = acc-    markConcatParts last_uses x m_x ind_x (acc, offs, True) b+    markConcatParts _ _ _ _ _ acc@(_, _, False) _ = acc+    markConcatParts compatible last_uses x m_x ind_x (acc, offs, True) b       | Just (MemBlock tpb shpb@(Shape dims@(_ : _)) m_b ind_b) <- getScopeMemInfo b scopetab,         Just d <- maybeNth concat_dim dims,         offs' <- offs + pe64 d =-          if b `nameIn` last_uses && sameSpace td_env m_x m_b+          if b `nameIn` last_uses && compatible m_b             then               let slc =                     Slice $@@ -1600,14 +1625,64 @@ -- CASE other than a), b), c), or d) not supported genCoalStmtInfo _ _ _ _ = pure Nothing -sameSpace :: (Coalesceable rep inner) => TopdownEnv rep -> VName -> VName -> Bool-sameSpace td_env m_x m_b-  | Just (MemMem pat_space) <- nameInfoToMemInfo <$> M.lookup m_x scope',-    Just (MemMem return_space) <- nameInfoToMemInfo <$> M.lookup m_b scope' =-      pat_space == return_space-  | otherwise = False+-- | These short-circuit points, but only if an array in @m_b@ may be moved into+-- @m_x@.+ifMemsCompatible ::+  (Coalesceable rep inner) =>+  TopdownEnv rep ->+  VName ->+  VName ->+  [SSPointInfo] ->+  ShortCircuitM rep (Maybe [SSPointInfo])+ifMemsCompatible td_env m_x m_b points = do+  space_ok <- asks spaceOK+  pure $+    if memsCompatible space_ok td_env m_x m_b+      then Just points+      else Nothing++-- | Can an array in the memory block @m_b@ be moved into the memory block+-- @m_x@? See Note [Short-circuiting across memory spaces].+memsCompatible ::+  (Coalesceable rep inner) =>+  (Space -> Space -> Bool) ->+  TopdownEnv rep ->+  VName ->+  VName ->+  Bool+memsCompatible space_ok td_env m_x m_b =+  case (memSpace td_env m_x, memSpace td_env m_b) of+    (Just x_space, Just b_space)+      | x_space == b_space -> True+      | not $ isFParamMem td_env m_b -> space_ok x_space b_space+    _ -> False++-- | Is this memory block a parameter of the enclosing function? The arrays in+-- such a block are never moved elsewhere.+isFParamMem :: TopdownEnv rep -> VName -> Bool+isFParamMem td_env m =+  case M.lookup m (scope td_env) of+    Just FParamName {} -> True+    _ -> False++-- | The space of a memory block, if it is in scope.+memSpace :: (Coalesceable rep inner) => TopdownEnv rep -> VName -> Maybe Space+memSpace td_env m+  | Just (MemMem space) <-+      nameInfoToMemInfo <$> M.lookup m (removeScopeAliases (scope td_env)) =+      Just space+  | otherwise = Nothing++-- | The 'spaceOK' of the host representations: besides the obvious, an array in+-- 'ScalarSpace' may be moved into any other space. See Note [Short-circuiting+-- across memory spaces].+hostSpaceOK :: Space -> Space -> Bool+hostSpaceOK dst_space src_space =+  dst_space == src_space+    || (isScalarSpace src_space && not (isScalarSpace dst_space))   where-    scope' = removeScopeAliases $ scope td_env+    isScalarSpace ScalarSpace {} = True+    isScalarSpace _ = False  data MemBodyResult = MemBodyResult   { patMem :: VName,@@ -1776,3 +1851,75 @@  filterMapM1 :: (Eq k, Monad m) => (v -> m Bool) -> M.Map k v -> m (M.Map k v) filterMapM1 f m = fmap M.fromAscList $ filterM (f . snd) $ M.toAscList m++-- Note [Short-circuiting function parameters]+--+-- A consumed function parameter can be short-circuited, but not in the usual+-- way. Normally the source array is moved into the destination block and the+-- allocation of the source block is removed. The memory of a parameter is not+-- allocated by the function, but given to it by the caller, so the parameter+-- cannot be moved. Instead 'replaceInParams' renames the parameter's memory to+-- the destination block and removes the allocation of the destination, so it+-- is the destination that moves into the memory of the parameter. This is how+-- an in-place 'map' over a consumed parameter is obtained.+--+-- This is only valid under four conditions, which 'fixPointCoalesce' checks:+--+-- 1. The destination block is allocated at the top level of the function, as+--    otherwise there is no allocation to remove. In particular, the+--    destination cannot be the memory of another parameter.+--+-- 2. Everything stored in the destination block fits in the memory of the+--    parameter. All we know about the latter is that it holds the parameter+--    array, so we require that the parameter is stored directly, and that the+--    size of the allocation equals the size of the array. This is a symbolic+--    comparison, and so it may fail for sizes that are in fact equal.+--+-- 3. No other parameter is short-circuited into the same destination, as two+--    parameters cannot be renamed to the same memory.+--+-- 4. The layout of the parameter in the destination block, as recorded in+--    'vartab', is the layout it already has, as renaming the memory does not+--    move any elements. It is not enough that the layout of the destination,+--    'dstind', matches, because the parameter may reach the destination+--    through a change of layout: in @copy (rearrange xs)@, the parameter @xs@+--    would have to be stored transposed.+--+-- Note that it is the final destination that matters: if the destination is+-- itself short-circuited into a larger block, then it is that block which must+-- satisfy the conditions.++-- Note [Short-circuiting across memory spaces]+--+-- Short-circuiting an array means storing it in part of some other memory+-- block, the destination, instead of a block of its own. This does not by+-- itself require the two blocks to be in the same space, because the source+-- block disappears entirely: no memory is aliased across spaces, the array+-- simply moves. The question is only whether the destination space can hold+-- the array at all, which is what the 'spaceOK' of each representation+-- answers.+--+-- For 'GPUMem' the answer for now is that the spaces must be identical, but it+-- is not clear to me whether we could change this in the future. On the host,+-- 'ScalarSpace' is merely a storage representation for memory the host can+-- address, an array of scalars rather than a block of bytes, so such an array+-- can be moved into the default space. This is 'hostSpaceOK'. It holds in one+-- direction only, because the array must fit in the destination, and a+-- 'ScalarSpace' block is exactly one array large.+--+-- Since the space is a property of the memory block, the space of a coalesced+-- array is that of the destination. We record it as 'dstspace', because any+-- declaration of the source block that survives must be updated to match; this+-- is the existential memory bound by a 'Match' or a 'Loop', which+-- "Futhark.Optimise.ArrayShortCircuiting" rewrites along with the results+-- themselves.+--+-- Two kinds of arrays are never moved, even when 'spaceOK' permits it. The+-- first is an array in the memory of a function parameter, where the source+-- block does not in fact disappear: 'replaceInParams' renames the parameter to+-- the destination and removes the destination's allocation, so it is the space+-- of the parameter that survives, and the move would happen in the opposite+-- direction from the one we checked. The second is a loop-carried array, which+-- we refuse in 'mapmbFun' for for performance reasons, as being in+-- 'ScalarSpace' is what keeps such an array out of (heap) memory across all the+-- iterations.
src/Futhark/Optimise/ArrayShortCircuiting/DataStructs.hs view
@@ -25,7 +25,7 @@     getScopeMemInfo,     createsNewArrOK,     getArrMemAssoc,-    getUniqueMemFParam,+    getConsumingMemFParam,     markFailedCoal,     accessSubtract,     markSuccessCoal,@@ -131,6 +131,10 @@ data CoalsEntry = CoalsEntry   { -- | destination memory block     dstmem :: VName,+    -- | the space of the destination, and hence of every array we put there.+    --   Usually also the space of the source, but not always; see Note+    --   [Short-circuiting across memory spaces].+    dstspace :: Space,     -- | index function of the destination (used for rebasing)     dstind :: LMAD,     -- | aliased destination memory blocks can appear@@ -248,16 +252,16 @@ -- the same destination memory and use the same index function, the first -- 'CoalsEntry' is returned. unionCoalsEntry :: CoalsEntry -> CoalsEntry -> CoalsEntry-unionCoalsEntry etry1 (CoalsEntry dstmem2 dstind2 alsmem2 vartab2 optdeps2 memrefs2 certs2) =-  if dstmem etry1 /= dstmem2 || dstind etry1 /= dstind2+unionCoalsEntry etry1 etry2 =+  if dstmem etry1 /= dstmem etry2 || dstind etry1 /= dstind etry2     then etry1     else       etry1-        { alsmem = alsmem etry1 <> alsmem2,-          optdeps = optdeps etry1 <> optdeps2,-          vartab = vartab etry1 <> vartab2,-          memrefs = memrefs etry1 <> memrefs2,-          certs = certs etry1 <> certs2+        { alsmem = alsmem etry1 <> alsmem etry2,+          optdeps = optdeps etry1 <> optdeps etry2,+          vartab = vartab etry1 <> vartab etry2,+          memrefs = memrefs etry1 <> memrefs etry2,+          certs = certs etry1 <> certs etry2         }  -- | Get the names of array 'PatElem's in a 'Pat' and the corresponding@@ -276,28 +280,28 @@  -- | Get the names of arrays in a list of 'FParam' and the corresponding -- 'ArrayMemBound' information for each array.-getArrMemAssocFParam :: [Param FParamMem] -> [(VName, Uniqueness, ArrayMemBound)]+getArrMemAssocFParam :: [Param FParamMem] -> [(VName, Diet, ArrayMemBound)] getArrMemAssocFParam =   mapMaybe     ( \param -> case paramDec param of-        (MemArray tp shp u (ArrayIn mem_nm indfun)) ->-          Just (paramName param, u, MemBlock tp shp mem_nm indfun)+        (MemArray tp shp o (ArrayIn mem_nm indfun)) ->+          Just (paramName param, o, MemBlock tp shp mem_nm indfun)         MemMem _ -> Nothing         MemPrim _ -> Nothing         MemAcc {} -> Nothing     ) --- | Get memory blocks in a list of 'FParam' that are used for unique arrays in--- the same list of 'FParam'.-getUniqueMemFParam :: [Param FParamMem] -> M.Map VName Space-getUniqueMemFParam params =+-- | Get memory blocks in a list of 'FParam' that are used for consumed arrays+-- in the same list of 'FParam'.+getConsumingMemFParam :: [Param FParamMem] -> M.Map VName Space+getConsumingMemFParam params =   let mems = M.fromList $ mapMaybe justMem params       arrayMems = S.fromList $ mapMaybe (justArrayMem . paramDec) params    in mems `M.restrictKeys` arrayMems   where     justMem (Param _ nm (MemMem sp)) = Just (nm, sp)     justMem _ = Nothing-    justArrayMem (MemArray _ _ Unique (ArrayIn mem_nm _)) = Just mem_nm+    justArrayMem (MemArray _ _ Consume (ArrayIn mem_nm _)) = Just mem_nm     justArrayMem _ = Nothing  class HasMemBlock rep where@@ -398,6 +402,6 @@         )  -- | Attempt to extract the 'PrimType' from a 'TypeBase'.-toPrimType :: TypeBase shp u -> Maybe PrimType+toPrimType :: TypeBase shp o -> Maybe PrimType toPrimType (Prim pt) = Just pt toPrimType _ = Nothing
src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs view
@@ -177,7 +177,8 @@           M.toList active_tab             & foldl               ( \state (m_b, entry) ->-                  if not $ null $ patNames (stmPat stm) `intersect` M.keys (vartab entry)+                  if not (null $ patNames (stmPat stm) `intersect` M.keys (vartab entry))+                    || touchesCoal m_b entry                     then markFailedCoal state m_b                     else state               )@@ -210,6 +211,11 @@               (_, inhibit_tab1) = foldl markFailedCoal (failed_tab, inhibit_tab) $ M.keys failed_tab            in (active_tab1, inhibit_tab1)   where+    stm_free = freeIn $ stmExp stm+    touchesCoal m_b entry =+      (namesFromList (m_b : dstmem entry : M.keys (vartab entry)) <> alsmem entry)+        `namesIntersect` stm_free+     checkOverlapAndExpand (stm_wrts, stm_uses) active_tab (m_b, etry) =       let alias_m_b = getAliases mempty m_b           stm_uses' = filter ((`notNameIn` alias_m_b) . tupFst) stm_uses
src/Futhark/Optimise/BlkRegTiling.hs view
@@ -30,6 +30,7 @@ import Futhark.Tools import Futhark.Transform.Rename import Futhark.Transform.Substitute+import Futhark.Util.IntegralExp qualified as IE  se0 :: SubExp se0 = intConst Int64 0@@ -46,11 +47,12 @@ se8 :: SubExp se8 = intConst Int64 8 -isInnerCoal :: Env -> VName -> Stm GPU -> Bool-isInnerCoal (_, ixfn_env) slc_X (Let (Pat [pe]) _ (BasicOp (Index x _)))-  | slc_X == patElemName pe =+isInnerCoal :: Env -> VName -> Stms GPU -> Bool+isInnerCoal (_, ixfn_env) slc_X load_X+  | Just (_, Let (Pat [pe]) _ (BasicOp (Index x slice))) <- stmsLast load_X,+    slc_X == patElemName pe =       -- if not in the table, we assume not-transposed!-      maybe True innerHasStride1 $ M.lookup x ixfn_env+      maybe True (innerHasStride1 . (`LMAD.slice` fmap pe64 slice)) $ M.lookup x ixfn_env   where     innerHasStride1 lmad =       let lmad_dims = LMAD.dims lmad@@ -70,7 +72,7 @@     [Int],     (VName, SubExp, VName, SubExp, SubExp),     (VName, VName),-    (Stm GPU, VName, PrimType, Stm GPU, VName, PrimType),+    (Stms GPU, VName, PrimType, Stms GPU, VName, PrimType),     (Lambda GPU, Lambda GPU)   ) ->   VName ->@@ -79,10 +81,10 @@   Builder GPU [VName] kkLoopBody   env-  ( (rx, ry, tx, ty, tk, tk_div_tx, _tk_div_ty, tx_rx),+  ( (rx, ry, tx, ty, tk, tk_div_tx, _tk_div_ty, _tx_rx),     segthd_lvl,     var_dims,-    (gtid_x, width_B, gtid_y, height_A, common_dim),+    (gtid_x, height_A, gtid_y, width_B, common_dim),     (iii, jjj),     (load_A, inp_A, pt_A, load_B, inp_B, pt_B),     (map_lam, red_lam)@@ -94,39 +96,43 @@     kk <- letExp "kk" =<< toExp (le64 kk0 * pe64 tk)     -- copy A to shared memory     (a_loc, aCopyLoc2Reg) <--      copyGlb2ShMem False kk (gtid_y, iii, map_t1, height_A, inp_A, load_A, a_loc_init')+      copyGlb2ShMem False kk (gtid_x, iii, map_t1, height_A, inp_A, load_A, a_loc_init')      -- copy B from global to shared memory     (b_loc, bCopyLoc2Reg) <--      copyGlb2ShMem True kk (gtid_x, jjj, map_t2, width_B, inp_B, load_B, b_loc_init')+      copyGlb2ShMem True kk (gtid_y, jjj, map_t2, width_B, inp_B, load_B, b_loc_init')      -- inner loop updating this thread's accumulator (loop k in mmm_kernels).     thd_acc <- mkRedomapOneTileBody kk thd_res_merge aCopyLoc2Reg bCopyLoc2Reg True     pure [thd_acc, a_loc, b_loc]     where-      mk_ik is_B is_coal (thd_y, thd_x) (i0, k0)+      mk_ik pad is_coal (thd_x, thd_y) (i0, k0)         | is_coal = do             -- not-transposed case (i.e., already coalesced)             let (t_par, t_seq) = (tx, tk)-            k <- letExp "k" =<< toExp (le64 thd_x + le64 k0 * pe64 t_par)-            i <- letExp "i" =<< toExp (le64 thd_y + le64 i0 * pe64 t_par)-            -- to optimize bank conflicts, we use padding only for B-            -- iff B has the last dimension permuted.-            let pad_term = if is_B then pe64 se1 else pe64 se0-            let e = le64 k + le64 i * (pe64 t_seq + pad_term)+            k <- letExp "k" =<< toExp (le64 thd_y + le64 k0 * pe64 t_par)+            i <- letExp "i" =<< toExp (le64 thd_x + le64 i0 * pe64 t_par)+            -- the rx rows of each thread form a block with a padded stride.+            let e =+                  le64 k+                    + le64 i * pe64 t_seq+                    + le64 i `IE.quot` pe64 rx * (pad (pe64 rx * pe64 t_seq) - pe64 rx * pe64 t_seq)             pure (i, k, e)-      mk_ik _ _ (thd_y, thd_x) (i0, k0) = do+      mk_ik pad _ (thd_x, thd_y) (i0, k0) = do         -- matrix is transposed case (i.e., uncoalesced):-        let (t_par, tr_par) = (tx, tx_rx)-        k <- letExp "k" =<< toExp (le64 thd_y + le64 k0 * pe64 t_par)-        i <- letExp "i" =<< toExp (le64 thd_x + le64 i0 * pe64 t_par)-        -- no padding-        let e = le64 i + le64 k * pe64 tr_par+        let t_par = tx+        k <- letExp "k" =<< toExp (le64 thd_x + le64 k0 * pe64 t_par)+        i <- letExp "i" =<< toExp (le64 thd_y + le64 i0 * pe64 t_par)+        -- the rx elements of each thread form a block with a padded stride.+        let e =+              le64 i+                + le64 i `IE.quot` pe64 rx * (pad (pe64 rx) - pe64 rx)+                + le64 k * pe64 tx * pad (pe64 rx)         pure (i, k, e)       ---      mkCompLoopRxRy fits_ij css_init (a_idx_fn, b_idx_fn) (ltid_y, ltid_x) = do-        css <- forLoop ry [css_init] $ \i [css_merge] -> do-          css <- forLoop rx [css_merge] $ \j [css_merge'] ->+      mkCompLoopRxRy fits_ij css_init (a_idx_fn, b_idx_fn) (ltid_x, ltid_y) = do+        css <- forLoop rx [css_init] $ \i [css_merge] -> do+          css <- forLoop ry [css_merge] $ \j [css_merge'] ->             (resultBodyM <=< letTupExp' "foo")               =<< eIf                 ( toExp $@@ -136,12 +142,12 @@                       -- if i and j are out of range than css[i,j]                       -- is garbage anyways and should not be written.                       -- so fits_ij should be always true!!!-                        (le64 iii + le64 i + pe64 ry * le64 ltid_y .<. pe64 height_A)-                          .&&. (le64 jjj + le64 j + pe64 rx * le64 ltid_x .<. pe64 width_B)+                        (le64 iii + le64 i + pe64 rx * le64 ltid_x .<. pe64 height_A)+                          .&&. (le64 jjj + le64 j + pe64 ry * le64 ltid_y .<. pe64 width_B)                 )                 ( do-                    a <- a_idx_fn ltid_y i-                    b <- b_idx_fn ltid_x j+                    a <- a_idx_fn ltid_x i+                    b <- b_idx_fn ltid_y j                     c <- index "c" css_merge' [i, j]                      map_lam' <- renameLambda map_lam@@ -164,9 +170,9 @@       --       mkRedomapOneTileBody kk css_merge a_idx_fn b_idx_fn fits_ij = do         -- the actual redomap.-        redomap_res <- segMap2D "redomap_res" segthd_lvl ResultPrivate (ty, tx) $-          \(ltid_y, ltid_x) -> do-            css_init <- index "css_init" css_merge [ltid_y, ltid_x]+        redomap_res <- segMap2D "redomap_res" segthd_lvl ResultPrivate (tx, ty) $+          \(ltid_x, ltid_y) -> do+            css_init <- index "css_init" css_merge [ltid_x, ltid_y]              css <- forLoop tk [css_init] $ \k [acc_merge] ->               (resultBodyM <=< letTupExp' "foo")@@ -176,7 +182,7 @@                         then le64 kk + le64 k .<. pe64 common_dim                         else true -- if in prologue, always compute redomap.                   )-                  (mkCompLoopRxRy fits_ij acc_merge (a_idx_fn k, b_idx_fn k) (ltid_y, ltid_x))+                  (mkCompLoopRxRy fits_ij acc_merge (a_idx_fn k, b_idx_fn k) (ltid_x, ltid_y))                   (resultBodyM [Var acc_merge])              pure [varRes css]@@ -185,7 +191,7 @@       copyGlb2ShMem ::         Bool ->         VName ->-        (VName, VName, PrimType, SubExp, VName, Stm GPU, VName) ->+        (VName, VName, PrimType, SubExp, VName, Stms GPU, VName) ->         Builder GPU (VName, VName -> VName -> VName -> Builder GPU VName)       copyGlb2ShMem is_B kk (gtid, ii, ptp_X_el, parlen_X, inp_X, load_X, x_loc_init') = do         let (t_par, r_par, tseq_div_tpar) = (tx, rx, tk_div_tx)@@ -196,6 +202,14 @@             scatterFun is_inner_coal         pure (x_loc, indexLocMem is_inner_coal str_A x_loc)         where+          -- The stride between the blocks of consecutive threads is padded+          -- to be odd, avoiding bank conflicts.  A warp reads A at only a+          -- few distinct addresses, which only conflict in the coalesced+          -- layout.+          pad+            | is_B || isInnerCoal env inp_X load_X = oddUp+            | otherwise = id+          --           indexLocMem ::             Bool ->             Name ->@@ -204,15 +218,14 @@             VName ->             VName ->             Builder GPU VName-          indexLocMem is_inner_coal str_A x_loc k ltid_yx ij = do-            let (r_par, t_seq, tr_par) = (rx, tk, tx_rx)-            let pad_term = if is_B then pe64 se1 else pe64 se0+          indexLocMem is_inner_coal str_A x_loc k ltid ij = do+            let (r_par, t_seq) = (rx, tk)             x_loc_ind_32 <-               letExp (str_A <> "_loc_ind_64")                 =<< toExp                   ( if is_inner_coal -- ToDo: check this is correct + turn to i32-                      then le64 k + (le64 ltid_yx * pe64 r_par + le64 ij) * (pe64 t_seq + pad_term)-                      else le64 ij + le64 ltid_yx * pe64 r_par + le64 k * pe64 tr_par+                      then le64 k + le64 ij * pe64 t_seq + le64 ltid * pad (pe64 r_par * pe64 t_seq)+                      else le64 ij + le64 ltid * pad (pe64 r_par) + le64 k * pe64 tx * pad (pe64 r_par)                   )             index (str_A <> "_loc_elem") x_loc [x_loc_ind_32]           --@@ -221,10 +234,10 @@             [VName] ->             (VName, VName) ->             Builder GPU (SubExp, SubExp)-          scatterFun is_inner_coal [i0, k0] (thd_y, thd_x) = do+          scatterFun is_inner_coal [i0, k0] (thd_x, thd_y) = do             let str_A = baseName inp_X                 t_seq = tk-            (i, k, epx_loc_fi) <- mk_ik is_B is_inner_coal (thd_y, thd_x) (i0, k0)+            (i, k, epx_loc_fi) <- mk_ik pad is_inner_coal (thd_x, thd_y) (i0, k0)             letBindNames [gtid] =<< toExp (le64 ii + le64 i)             a_seqdim_idx <- letExp (str_A <> "_seqdim_idx") =<< toExp (le64 kk + le64 k) @@ -239,7 +252,7 @@                           else true                   )                   ( do-                      addStm load_X+                      addStms load_X                       res <- index "A_elem" inp_X [a_seqdim_idx]                       resultBodyM [Var res]                   )@@ -287,12 +300,11 @@       matchesBlkRegTile seg_space kstms,     checkAccumulatesRedomapRes res_nm code2' redomap_orig_res = do       -- Here we start the implementation ---      let is_B_coal = isInnerCoal env inp_B load_B       ---- in this binder: host code and outer seggroup (ie. the new kernel) ----       (new_kernel, host_stms) <- runBuilder $ do         -- host code         (rx, ry, tx, ty, tk, tk_div_tx, tk_div_ty, tx_rx, ty_ry, a_loc_sz, b_loc_sz) <--          mkTileMemSizes height_A width_B common_dim is_B_coal+          mkTileMemSizes height_A width_B common_dim          rk <- letSubExp "rk" $ BasicOp $ SubExp $ intConst Int64 8 -- 16 and 8 seem good values         tk_rk <- letSubExp "tk_rk" =<< toExp (pe64 tk * pe64 rk)@@ -333,7 +345,7 @@                 ( (rx, ry, tx, ty, tk, tk_div_tx, tk_div_ty, tx_rx),                   segthd_lvl,                   var_dims,-                  (gtid_y, width_B, gtid_x, height_A, common_dim),+                  (gtid_x, height_A, gtid_y, width_B, common_dim),                   (iii, jjj),                   (load_A, inp_A, map_t1, load_B, inp_B, map_t2),                   (map_lam, red_lam)@@ -370,17 +382,17 @@           let redomap_res : _ = redomap_res_lst            -- support for non-empty code2'-          --  segmap (ltid_y < ty, ltid_x < tx) {-          --    for i < ry do-          --      for j < rx do-          --        res = if (iii+ltid_y*ry+i < height_A && jjj+ltid_x*rx+j < width_B)+          --  segmap (ltid_x < tx, ltid_y < ty) {+          --    for i < rx do+          --      for j < ry do+          --        res = if (iii+ltid_x*rx+i < height_A && jjj+ltid_y*ry+j < width_B)           --              then code2' else dummy           --        final_res[i,j] = res           mkEpilogueAccRes             segthd_lvl             (redomap_orig_res, redomap_res)             (res_nm, res_tp)-            (ty, tx, ry, rx)+            (tx, ty, rx, ry)             (iii, jjj)             (gtid_x, gtid_y)             (height_A, width_B, rem_outer_dims)@@ -393,10 +405,10 @@         pure $ Let pat aux $ Op $ SegOp $ SegMap level' space' ts kbody'       pure $ Just (host_stms, new_kernel)   where-    sameAccType acc_sglton (Acc sglton _ _ _) =+    sameAccType acc_sglton (Acc sglton _ _) =       acc_sglton == sglton     sameAccType _ _ = False-    getAccumFV (Acc singleton _shp [_eltp] _) = do+    getAccumFV (Acc singleton _shp [_eltp]) = do       let fvs = namesToList $ freeIn old_kbody -- code       tps <- localScope (scopeOfSegSpace seg_space) $ do         mapM lookupType fvs@@ -423,16 +435,16 @@       segthd_lvl       (redomap_orig_res, redomap_res)       (res_nm, res_tp)-      (ty, tx, ry, rx)+      (tx, ty, rx, ry)       (iii, jjj)-      (gtid_y, gtid_x)+      (gtid_x, gtid_y)       (height_A, width_B, _rem_outer_dims)       code2' = do         rss_init <- getAccumFV res_tp-        rssss_list <- segMap2D "rssss" segthd_lvl ResultMaySimplify (ty, tx) $ \(ltid_y, ltid_x) -> do+        rssss_list <- segMap2D "rssss" segthd_lvl ResultMaySimplify (tx, ty) $ \(ltid_x, ltid_y) -> do           (css, ii, jj) <- getThdRedomapRes (rx, ry) (ltid_x, ltid_y) (iii, jjj, redomap_res)-          rss <- forLoop ry [rss_init] $ \i [rss_merge] -> do-            rss' <- forLoop rx [rss_merge] $ \j [rss_merge'] -> do+          rss <- forLoop rx [rss_init] $ \i [rss_merge] -> do+            rss' <- forLoop ry [rss_merge] $ \j [rss_merge'] -> do               prereqAddCode2 (gtid_x, gtid_y) (ii, i, jj, j) (css, redomap_orig_res)               let code2_subs = substituteNames (M.singleton rss_init rss_merge') code2' @@ -440,9 +452,9 @@                 letSubExp "res_elem"                   =<< eIf                     ( toExp $-                        le64 gtid_y+                        le64 gtid_x                           .<. pe64 height_A-                          .&&. le64 gtid_x+                          .&&. le64 gtid_y                           .<. pe64 width_B                     )                     ( do@@ -481,15 +493,14 @@         ) <-       matchesBlkRegTile seg_space kstms = do       -- Here we start the implementation-      let is_B_coal = isInnerCoal env inp_B load_B       ---- in this binder: host code and outer seggroup (ie. the new kernel) ----       (new_kernel, host_stms) <- runBuilder $ do         -- host code         (rx, ry, tx, ty, tk, tk_div_tx, tk_div_ty, tx_rx, ty_ry, a_loc_sz, b_loc_sz) <--          mkTileMemSizes height_A width_B common_dim is_B_coal+          mkTileMemSizes height_A width_B common_dim -        gridDim_y <- letSubExp "gridDim_y" =<< ceilDiv width_B ty_ry         gridDim_x <- letSubExp "gridDim_x" =<< ceilDiv height_A tx_rx+        gridDim_y <- letSubExp "gridDim_y" =<< ceilDiv width_B ty_ry         let gridxy_pexp = pe64 gridDim_x * pe64 gridDim_y         let grid_pexp =               foldl (\x d -> pe64 d * x) gridxy_pexp $@@ -521,7 +532,7 @@                 ( (rx, ry, tx, ty, tk, tk_div_tx, tk_div_ty, tx_rx),                   segthd_lvl,                   var_dims,-                  (gtid_y, width_B, gtid_x, height_A, common_dim),+                  (gtid_x, height_A, gtid_y, width_B, common_dim),                   (iii, jjj),                   (load_A, inp_A, map_t1, load_B, inp_B, map_t2),                   (map_lam, red_lam)@@ -544,16 +555,16 @@            -- support for non-empty code2'           --  segmap (ltid_x < tx, ltid_y < ty) {-          --    for i < ry do-          --      for j < rx do-          --        res = if (iii+ltid_y*ry+i < height_A && jjj+ltid_x*rx+j < width_B)+          --    for i < rx do+          --      for j < ry do+          --        res = if (iii+ltid_x*rx+i < height_A && jjj+ltid_y*ry+j < width_B)           --              then code2' else dummy           --        final_res[i,j] = res           mkEpiloguePrimRes             segthd_lvl             (redomap_orig_res, redomap_res)             (res_nm, res_tp)-            (ty, tx, ry, rx)+            (tx, ty, rx, ry)             (iii, jjj)             (gtid_x, gtid_y)             (height_A, width_B, rem_outer_dims)@@ -570,29 +581,29 @@       segthd_lvl       (redomap_orig_res, redomap_res)       (res_nm, res_tp)-      (ty, tx, ry, rx)+      (tx, ty, rx, ry)       (iii, jjj)-      (gtid_y, gtid_x)+      (gtid_x, gtid_y)       (height_A, width_B, rem_outer_dims)       code2' = do         epilogue_res <-           if redomap_orig_res == res_nm             then pure redomap_res -- epilogue_res_list             else do-              rssss_list <- segMap2D "rssss" segthd_lvl ResultPrivate (ty, tx) $ \(ltid_y, ltid_x) -> do-                rss_init <- scratch "rss_init" (elemType res_tp) [ry, rx]+              rssss_list <- segMap2D "rssss" segthd_lvl ResultPrivate (tx, ty) $ \(ltid_x, ltid_y) -> do+                rss_init <- scratch "rss_init" (elemType res_tp) [rx, ry]                 (css, ii, jj) <- getThdRedomapRes (rx, ry) (ltid_x, ltid_y) (iii, jjj, redomap_res)-                rss <- forLoop ry [rss_init] $ \i [rss_merge] -> do-                  rss' <- forLoop rx [rss_merge] $ \j [rss_merge'] -> do+                rss <- forLoop rx [rss_init] $ \i [rss_merge] -> do+                  rss' <- forLoop ry [rss_merge] $ \j [rss_merge'] -> do                     prereqAddCode2 (gtid_x, gtid_y) (ii, i, jj, j) (css, redomap_orig_res)                      res_el <-                       letSubExp "res_elem"                         =<< eIf                           ( toExp $-                              le64 gtid_y+                              le64 gtid_x                                 .<. pe64 height_A-                                .&&. le64 gtid_x+                                .&&. le64 gtid_y                                 .<. pe64 width_B                           )                           ( do@@ -609,7 +620,7 @@          let regtile_ret_dims =               map (\(_, sz) -> (sz, se1, se1)) rem_outer_dims-                ++ [(height_A, ty, ry), (width_B, tx, rx)]+                ++ [(height_A, tx, rx), (width_B, ty, ry)]          -- Add dummy dimensions to tile to reflect the outer dimensions.         epilogue_res' <-@@ -633,7 +644,7 @@   Stms GPU ->   Maybe     ( Stms GPU,-      (Stm GPU, VName, PrimType, Stm GPU, VName, PrimType),+      (Stms GPU, VName, PrimType, Stms GPU, VName, PrimType),       SubExp,       [Int],       (Lambda GPU, Lambda GPU, SubExp, VName, PrimType)@@ -666,16 +677,11 @@     [redomap_orig_res] <- patNames pat_redomap,     Just res_red_var <- M.lookup redomap_orig_res variance, -- variance of the reduce result -    -- we furthermore check that code1 is only formed by-    -- 1. statements that slice some globally-declared arrays-    --    to produce the input for the redomap, and-    -- 2. potentially some statements on which the redomap-    --    is independent; these are recorded in `code2''`+    -- we furthermore check that code1 can be split into the+    -- statements producing the input for the redomap, and some+    -- statements that are moved after it; see `processIndirections`.     Just (code2'', tab_inv_stm) <--      foldl-        (processIndirections (namesFromList arrs) res_red_var)-        (Just (Seq.empty, M.empty))-        code1,+      processIndirections (namesFromList arrs) res_red_var (freeIn screma_stmt) code1,     -- identify load_A, load_B     tmp_stms <- mapMaybe (`M.lookup` tab_inv_stm) arrs,     length tmp_stms == length arrs,@@ -700,15 +706,19 @@             ) matchesBlkRegTile _ _ = Nothing --- ceiled division expression+-- | Round up to an odd number.  Shared memory strides are padded like+-- this to avoid bank conflicts.+oddUp :: TPrimExp Int64 VName -> TPrimExp Int64 VName+oddUp x = 2 * (x `IE.quot` 2) + 1++-- | Ceiled division expression. ceilDiv :: (MonadBuilder m) => SubExp -> SubExp -> m (Exp (Rep m))-ceilDiv x y = pure $ BasicOp $ BinOp (SDivUp Int64 Unsafe) x y+ceilDiv x y = pure $ BasicOp $ BinOp (SCeilDiv Int64 Unsafe) x y  mkTileMemSizes ::   SubExp ->   SubExp ->   SubExp ->-  Bool ->   Builder     GPU     ( SubExp,@@ -723,17 +733,17 @@       SubExp,       SubExp     )-mkTileMemSizes height_A _width_B common_dim is_B_not_transp = do+mkTileMemSizes height_A _width_B common_dim = do   tk_name <- nameFromText . prettyText <$> newVName "Tk"-  ty_name <- nameFromText . prettyText <$> newVName "Ty"-  ry_name <- nameFromText . prettyText <$> newVName "Ry"+  tx_name <- nameFromText . prettyText <$> newVName "Tx"+  rx_name <- nameFromText . prettyText <$> newVName "Rx"    -- until we change the copying to use lmads we need to   --   guarantee that Tx=Ty AND Rx = Ry AND Tx | Tk   -- for matrix multiplication it would be safe if they aren't   --   but not for any of the other three cases!-  (ty, ry) <- getParTiles ("Ty", "Ry") (ty_name, ry_name) height_A-  let (tx, rx) = (ty, ry)+  (tx, rx) <- getParTiles ("Tx", "Rx") (tx_name, rx_name) height_A+  let (ty, ry) = (tx, rx)   tk <- getSeqTile "Tk" tk_name common_dim tx ty    tk_div_tx <- letSubExp "tk_div_tx" =<< ceilDiv tk tx@@ -742,19 +752,16 @@   tx_rx <- letSubExp "TxRx" =<< toExp (pe64 tx * pe64 rx)   ty_ry <- letSubExp "TyRy" =<< toExp (pe64 ty * pe64 ry) -  -- let pad_term = sMax64 (pe64 tk) (pe64 ty * pe64 ry)-  let pad_term =-        if is_B_not_transp-          then pe64 ty * pe64 ry-          else pe64 se0+  -- Large enough for either layout, including padding (see mk_ik).   a_loc_sz <-     letSubExp "a_loc_sz"-      =<< toExp (pe64 ty * pe64 ry * pe64 tk)-  -- if B is transposed, its shmem should be [tk][tx*rx]-  -- we pad as above, by assuming tx*rx == ty*ry >= tk+      =<< toExp (pe64 tx * oddUp (pe64 rx * pe64 tk))   b_loc_sz <-     letSubExp "b_loc_sz"-      =<< toExp (pe64 tx * pe64 rx * pe64 tk + pad_term)+      =<< toExp+        ( pe64 ty+            * sMax64 (oddUp (pe64 ry * pe64 tk)) (oddUp (pe64 ry) * pe64 tk)+        )   pure (rx, ry, tx, ty, tk, tk_div_tx, tk_div_ty, tx_rx, ty_ry, a_loc_sz, b_loc_sz)  mkNewSegthdLvl ::@@ -764,14 +771,14 @@   Builder GPU (SubExp, SubExp, SegLevel) mkNewSegthdLvl tx ty grid_pexp = do   grid_size <- letSubExp "grid_size" =<< toExp grid_pexp-  tblock_size <- letSubExp "tblock_size" =<< toExp (pe64 ty * pe64 tx)+  tblock_size <- letSubExp "tblock_size" =<< toExp (pe64 tx * pe64 ty)   let segthd_lvl = SegThreadInBlock (SegNoVirtFull (SegSeqDims []))   pure (grid_size, tblock_size, segthd_lvl)  mkGidsXYF :: Builder GPU (VName, VName, VName) mkGidsXYF = do-  gid_y <- newVName "gid_y"   gid_x <- newVName "gid_x"+  gid_y <- newVName "gid_y"   gid_flat <- newVName "gid_flat"   pure (gid_x, gid_y, gid_flat) @@ -787,10 +794,10 @@   segthd_lvl   red_ne = do     -- initialize register mem with neutral elements.-    cssss_list <- segMap2D "cssss" segthd_lvl ResultPrivate (ty, tx) $ \_ -> do-      css_init <- scratch "css_init" red_t [ry, rx]-      css <- forLoop ry [css_init] $ \i [css_merge] -> do-        css' <- forLoop rx [css_merge] $ \j [css_merge'] -> do+    cssss_list <- segMap2D "cssss" segthd_lvl ResultPrivate (tx, ty) $ \_ -> do+      css_init <- scratch "css_init" red_t [rx, ry]+      css <- forLoop rx [css_init] $ \i [css_merge] -> do+        css' <- forLoop ry [css_merge] $ \j [css_merge'] -> do           css'' <- update "css" css_merge' [i, j] red_ne           resultBodyM [Var css'']         resultBodyM [Var css']@@ -807,9 +814,9 @@   (VName, VName, VName) ->   Builder GPU (VName, VName, VName) getThdRedomapRes (rx, ry) (ltid_x, ltid_y) (iii, jjj, redomap_res) = do-  css <- index "redomap_thd" redomap_res [ltid_y, ltid_x]-  ii <- letExp "ii" =<< toExp (le64 iii + le64 ltid_y * pe64 ry)-  jj <- letExp "jj" =<< toExp (le64 jjj + le64 ltid_x * pe64 rx)+  css <- index "redomap_thd" redomap_res [ltid_x, ltid_y]+  ii <- letExp "ii" =<< toExp (le64 iii + le64 ltid_x * pe64 rx)+  jj <- letExp "jj" =<< toExp (le64 jjj + le64 ltid_y * pe64 ry)   pure (css, ii, jj)  prereqAddCode2 ::@@ -821,8 +828,8 @@   c <- index "redomap_elm" css [i, j]   cpy_stm <- mkLetNamesM [redomap_orig_res] $ BasicOp $ SubExp $ Var c   addStm cpy_stm-  letBindNames [gtid_y] =<< toExp (le64 ii + le64 i)-  letBindNames [gtid_x] =<< toExp (le64 jj + le64 j)+  letBindNames [gtid_x] =<< toExp (le64 ii + le64 i)+  letBindNames [gtid_y] =<< toExp (le64 jj + le64 j)  -- | Tries to identify the following pattern: --   code followed by some Screma followed by more code.@@ -879,25 +886,44 @@                 then Just 1                 else Nothing +-- | Split the statements preceding the redomap into+--+-- 1. the slices that produce the input arrays of the redomap, each+--    preceded by the scalar statements computing its indices (these+--    are re-executed when reading tiles), and+--+-- 2. the remaining statements, which are moved after the redomap.+--    Except for those computing slice indices, the redomap must not+--    depend on these. processIndirections ::   Names -> -- input arrays to redomap   Names -> -- variables on which the result of redomap depends on.-  Maybe (Stms GPU, M.Map VName (Stm GPU)) ->-  Stm GPU ->-  Maybe (Stms GPU, M.Map VName (Stm GPU))-processIndirections arrs _ acc stm@(Let patt _ (BasicOp (Index _ _)))-  | Just (ss, tab) <- acc,-    [p] <- patElems patt,-    p_nm <- patElemName p,-    p_nm `nameIn` arrs =-      Just (ss, M.insert p_nm stm tab)-processIndirections _ res_red_var acc stm'@(Let patt _ _)-  | Just (ss, tab) <- acc,-    ps <- patElems patt,-    all (\p -> patElemName p `notNameIn` res_red_var) ps =-      Just (ss Seq.|> stm', tab)-  | otherwise = Nothing+  Names -> -- free variables of the redomap+  Stms GPU ->+  Maybe (Stms GPU, M.Map VName (Stms GPU))+processIndirections arrs res_red_var red_free code1 = do+  let (loads, rest) = Seq.partition isLoad code1+      withDeps stm = dependencies rest stm Seq.|> stm+      deps = foldMap (dependencies rest) loads+  guard $ all isScalarBasicOp deps+  guard $ not $ boundByStms deps `namesIntersect` red_free+  guard $ not $ (boundByStms rest `namesSubtract` boundByStms deps) `namesIntersect` res_red_var+  pure (rest, M.fromList [(v, withDeps stm) | stm <- stmsToList loads, v <- patNames $ stmPat stm])+  where+    isLoad (Let (Pat [pe]) _ (BasicOp Index {})) = patElemName pe `nameIn` arrs+    isLoad _ = False+    isScalarBasicOp (Let pat _ BasicOp {}) = all primType $ patTypes pat+    isScalarBasicOp _ = False +-- | The statements among the given ones that the statement+-- transitively depends on.+dependencies :: Stms GPU -> Stm GPU -> Stms GPU+dependencies stms stm = snd $ foldr f (freeIn stm, mempty) stms+  where+    f s (needed, deps)+      | boundByStm s `namesIntersect` needed = (needed <> freeIn s, s Seq.<| deps)+      | otherwise = (needed, deps)+ getParTiles :: (Name, Name) -> (Name, Name) -> SubExp -> Builder GPU (SubExp, SubExp) getParTiles (t_str, r_str) (t_name, r_name) len_dim =   case len_dim of@@ -912,9 +938,11 @@       r <- letSubExp r_str $ Op $ SizeOp $ GetSize r_name SizeRegTile       pure (t, r) +-- | The sequential tile size. It is rounded up to a multiple of @tx@, as the+-- tile loops assume that @tx@ divides it. getSeqTile :: Name -> Name -> SubExp -> SubExp -> SubExp -> Builder GPU SubExp-getSeqTile tk_str tk_name len_dim tx ty =-  case (tx, ty) of+getSeqTile tk_str tk_name len_dim tx ty = do+  tk <- case (tx, ty) of     (Constant (IntValue (Int64Value v_x)), Constant (IntValue (Int64Value v_y))) ->       letSubExp tk_str . BasicOp . SubExp . constant $         case len_dim of@@ -922,6 +950,8 @@           _ -> min v_x v_y     _ ->       letSubExp tk_str $ Op $ SizeOp $ GetSize tk_name SizeTile+  tk_div_tx <- letSubExp "tk_div_tx" =<< ceilDiv tk tx+  letSubExp tk_str =<< toExp (pe64 tk_div_tx * pe64 tx)  ---------------------------------------------------------------------------------------------- --- 3D Tiling (RegTiling for the outermost dimension & Block tiling for the innermost two) ---@@ -990,9 +1020,7 @@ --              to exactly one of the three innermost-parallel dimension --              of the kernel. This condition can be relaxed by interchanging --              kernel dimensions whenever possible.---     3. For scalar-code-1:---          a) each of the statements is a slice that produces one of the---             streamed arrays+--     3. For scalar-code-1: see `processIndirections`. -- -- mmBlkRegTiling :: Stm GPU -> TileM (Maybe (Stms GPU, Stm GPU)) -- mmBlkRegTiling (Let pat aux (Op (SegOp (SegMap SegThread{} seg_space ts old_kbody))))@@ -1031,16 +1059,11 @@     res_red_var <- -- variance of the reduce result       mconcat $ mapMaybe ((`M.lookup` variance) . patElemName) redomap_orig_res,     mempty /= res_red_var,-    -- we furthermore check that code1 is only formed by-    -- 1. statements that slice some globally-declared arrays-    --    to produce the input for the redomap, and-    -- 2. potentially some statements on which the redomap-    --    is independent; these are recorded in `code2''`+    -- we furthermore check that code1 can be split into the+    -- statements producing the input for the redomap, and some+    -- statements that are moved after it; see `processIndirections`.     Just (code2'', arr_tab0) <--      foldl-        (processIndirections (namesFromList inp_soac_arrs) res_red_var)-        (Just (Seq.empty, M.empty))-        code1,+      processIndirections (namesFromList inp_soac_arrs) res_red_var (freeIn screma_stmt) code1,     -- check that code1 contains exacly one slice for each of the input array to redomap     tmp_stms <- mapMaybe (`M.lookup` arr_tab0) inp_soac_arrs,     length tmp_stms == length inp_soac_arrs,@@ -1133,7 +1156,7 @@                                 =<< eIf                                   (toExp $ le64 glb_ind .<. pe64 d_Kx)                                   ( do-                                      addStm load_Y+                                      addStms load_Y                                       res <- index "Y_elem" glb_Y_nm [q]                                       resultBodyM [Var res]                                   )@@ -1167,7 +1190,7 @@                           ( do                               inp_scals_invar_outer <-                                 forM (M.toList tab_inn) $ \(inp_arr_nm, load_stm) -> do-                                  addStm load_stm+                                  addStms load_stm                                   index (baseName inp_arr_nm) inp_arr_nm [q]                               -- build the loop of count R whose body is semantically the redomap code                               reg_arr_merge_nms' <-@@ -1296,15 +1319,16 @@     insertTranspose ::       VarianceTable ->       (VName, SubExp) ->-      (M.Map VName (Stm GPU), M.Map VName (PrimType, Stm GPU)) ->-      (VName, Stm GPU) ->-      Builder GPU (M.Map VName (Stm GPU), M.Map VName (PrimType, Stm GPU))-    insertTranspose variance (gidz, _) (tab_inn, tab_out) (p_nm, stm@(Let patt yy (BasicOp (Index arr_nm slc))))-      | [p] <- patElems patt,+      (M.Map VName (Stms GPU), M.Map VName (PrimType, Stms GPU)) ->+      (VName, Stms GPU) ->+      Builder GPU (M.Map VName (Stms GPU), M.Map VName (PrimType, Stms GPU))+    insertTranspose variance (gidz, _) (tab_inn, tab_out) (p_nm, stms)+      | Just (deps, Let patt yy (BasicOp (Index arr_nm slc))) <- stmsLast stms,+        [p] <- patElems patt,         ptp <- elemType $ patElemType p,         p_nm == patElemName p =           case L.findIndices (variantSliceDim variance gidz) (unSlice slc) of-            [] -> pure (M.insert p_nm stm tab_inn, tab_out)+            [] -> pure (M.insert p_nm stms tab_inn, tab_out)             i : _ -> do               arr_tp <- lookupType arr_nm               let perm = [i + 1 .. arrayRank arr_tp - 1] ++ [0 .. i]@@ -1312,7 +1336,7 @@               arr_tr_nm <- letExp arr_tr_str $ BasicOp $ Manifest arr_nm perm               let e_ind' = BasicOp $ Index arr_tr_nm slc               let stm' = Let patt yy e_ind'-              pure (tab_inn, M.insert p_nm (ptp, stm') tab_out)+              pure (tab_inn, M.insert p_nm (ptp, deps Seq.|> stm') tab_out)     insertTranspose _ _ _ _ = error "\nUnreachable case reached in insertTranspose case, doRegTiling3D\n"      variantSliceDim :: VarianceTable -> VName -> DimIndex SubExp -> Bool
src/Futhark/Optimise/CSE.hs view
@@ -45,10 +45,15 @@     removeStmAliases,   ) import Futhark.IR.GPU qualified as GPU+import Futhark.IR.GPUMem qualified as GPUMem import Futhark.IR.MC qualified as MC+import Futhark.IR.MCMem qualified as MCMem import Futhark.IR.Mem qualified as Memory import Futhark.IR.Prop.Aliases+import Futhark.IR.SOACS qualified as SOACS import Futhark.IR.SOACS.SOAC qualified as SOAC+import Futhark.IR.Seq qualified as Seq+import Futhark.IR.SeqMem qualified as SeqMem import Futhark.Pass import Futhark.Transform.Substitute @@ -84,6 +89,17 @@           (newCSEState cse_arrays)     onFun _ = pure . cseInFunDef cse_arrays +-- Specialising here means the importers that instantiate the pass (the+-- pipelines and the dev driver) use these copies instead of each+-- re-specialising the whole pass whenever they are recompiled.+{-# SPECIALIZE performCSE :: Bool -> Pass SOACS.SOACS SOACS.SOACS #-}+{-# SPECIALIZE performCSE :: Bool -> Pass GPU.GPU GPU.GPU #-}+{-# SPECIALIZE performCSE :: Bool -> Pass MC.MC MC.MC #-}+{-# SPECIALIZE performCSE :: Bool -> Pass Seq.Seq Seq.Seq #-}+{-# SPECIALIZE performCSE :: Bool -> Pass SeqMem.SeqMem SeqMem.SeqMem #-}+{-# SPECIALIZE performCSE :: Bool -> Pass GPUMem.GPUMem GPUMem.GPUMem #-}+{-# SPECIALIZE performCSE :: Bool -> Pass MCMem.MCMem MCMem.MCMem #-}+ -- | Perform CSE on a single function. -- -- If the boolean argument is false, the pass will not perform CSE on@@ -132,11 +148,18 @@     -- inlining.     ds = map (retDiet . fst) $ funDefRetType fundec     retDiet t-      | primType $ declExtTypeOf t = Observe+      | primType $ extTypeOf t = Observe       | otherwise = Consume  type CSEM rep = Reader (CSEState rep) +-- | Like 'substituteNames', but leaves the term alone rather than+-- rebuilding an identical one when there is nothing to substitute.+substituteNames' :: (Substitute a) => M.Map VName VName -> a -> a+substituteNames' substs x+  | M.null substs = x+  | otherwise = substituteNames substs x+ cseInBody ::   (Aliased rep, CSEInOp (Op rep)) =>   [Diet] ->@@ -146,7 +169,7 @@   (stms', res') <-     cseInStms (res_cons <> stms_cons) (stmsToList stms) $ do       CSEState (_, nsubsts) _ <- ask-      pure $ substituteNames nsubsts res+      pure $ substituteNames' nsubsts res   pure $ Body bodydec stms' res'   where     (res_als, stms_cons) = mkStmsAliases stms res@@ -204,8 +227,8 @@   CSEM rep a cseInStm consumed (Let pat aux e) m = do   CSEState (esubsts, nsubsts) cse_arrays <- ask-  let e' = substituteNames nsubsts e-      pat' = substituteNames nsubsts pat+  let e' = substituteNames' nsubsts e+      pat' = substituteNames' nsubsts pat   if not (alreadyAliases e) && any (bad cse_arrays) (patElems pat)     then m [Let pat' aux e']     else case M.lookup (stmAuxDec aux, e') esubsts of
src/Futhark/Optimise/DoubleBuffer.hs view
@@ -33,7 +33,7 @@ -- array is always stored in the "first" memory block at the beginning -- of the loop (and also in the final result).  We do need to add an -- extra element to the pattern, however.  The initial copy of @A@--- could be elided if @A@ is unique (thus @A_in_mem=A_mem@).  This is+-- could be elided if @A@ is consuming (thus @A_in_mem=A_mem@).  This is -- because only then is it safe to use @A_mem@ to store loop results. -- We don't currently do this. --@@ -289,17 +289,17 @@           -- the same index function as the result.           arr_v_copy <- newVName $ baseName arr_v <> "_db_copy"           let arr_initial_info =-                MemArray pt shape NoUniqueness $ ArrayIn arr_mem_in arr_lmad+                MemArray pt shape NoMode $ ArrayIn arr_mem_in arr_lmad               arr_initial_pe =                 PatElem arr_v_copy arr_initial_info           addStm . Let (Pat [arr_initial_pe]) (defAux ()) . BasicOp $             Replicate mempty (Var arr_param_initial)-          -- AS a trick we must make the array parameter Unique to+          -- AS a trick we must make the array parameter Consume to           -- avoid unfortunate hoisting (see #1533) because we are           -- invalidating the underlying memory.           let arr_param' =                 Param mempty (paramName arr_param) $-                  MemArray pt shape Unique (ArrayIn (paramName param) param_lmad)+                  MemArray pt shape Consume (ArrayIn (paramName param) param_lmad)            -- We must also update the initial values of the parameters           -- used in the index function of this array parameter, such
src/Futhark/Optimise/Fusion/Screma.hs view
@@ -283,6 +283,8 @@   (MonadFail m, MonadFreshNames m) =>   SuperScrema SOACS ->   m (SuperScrema SOACS)+moveRedScanSuperScrema super_screma@(SuperScrema _ _ _ _ _ _ [] [] _) =+  pure super_screma moveRedScanSuperScrema super_screma = do   ((scan_red_inp_c, scan_red_lam', _), (_, map_lam', _)) <-     splitAtLambdaByRes@@ -306,7 +308,7 @@       new_pars = lambdaParams lam       new_res = scan_res <> scan_res' <> red_res <> red_res' <> map_res       new_body = mkBody (stms <> binds <> stms') new_res-      new_lam = eliminateByRes $ Lambda new_pars new_ts new_body+      new_lam = Lambda new_pars new_ts new_body       (scan_pars', map_pars') =         splitAt (scanResults scan) (lambdaParams lam') @@ -319,7 +321,7 @@         varsRes (map paramName extra_scan_pars')           <> bodyResult (lambdaBody map_lam')       new_body' = mkBody new_stms' new_res'-      new_lam' = eliminateByRes $ Lambda new_pars' new_ts' new_body'+      new_lam' = Lambda new_pars' new_ts' new_body'    pure $     SuperScrema w inp new_lam new_scan new_red new_lam' [] [] lam''@@ -364,7 +366,7 @@       new_stms = stms' <> binds <> stms''       new_res = bodyResult $ lambdaBody temp_lam''       new_body = mkBody new_stms new_res-      new_lam' = eliminateByRes $ Lambda new_pars new_ts new_body+      new_lam' = Lambda new_pars new_ts new_body    new_lam'' <- mkIdentityLambda $ lambdaReturnType lam''   pure $@@ -411,12 +413,14 @@     new_lam' = Lambda new_pars' new_ts' new_body'     pars = lambdaParams lam     stms = bodyStms $ lambdaBody lam-    new_body = mkBody (eliminate (freeIn new_res) stms) new_res-    new_body' = mkBody (eliminate (freeIn new_res') stms) new_res'-    inBody body = (`nameIn` freeIn body) . paramName . fst-    removePars body = unzip $ filter (inBody body) $ zip pars inp-    (new_pars, new_inp) = removePars new_body-    (new_pars', new_inp') = removePars new_body'+    (new_deps, new_stms) = eliminateWithDeps (freeIn new_res) stms+    (new_deps', new_stms') = eliminateWithDeps (freeIn new_res') stms+    new_body = mkBody new_stms new_res+    new_body' = mkBody new_stms' new_res'+    inBody deps = (`nameIn` deps) . paramName . fst+    removePars deps = unzip $ filter (inBody deps) $ zip pars inp+    (new_pars, new_inp) = removePars new_deps+    (new_pars', new_inp') = removePars new_deps'     (new_res, new_res') = splitAt i $ bodyResult $ lambdaBody lam     (new_ts, new_ts') = splitAt i $ lambdaReturnType lam     (new_out, new_out') = splitAt i out
src/Futhark/Optimise/Fusion/TryFusion.hs view
@@ -202,7 +202,10 @@   SOAC ->   FusedSOAC ->   TryFusion FusedSOAC-fuseSOACwithKer mode unfus_set outVars soac_p ker = do+fuseSOACwithKer mode unfus_set outVars soac_p0 ker = do+  -- soac_p0 is not removed from the program until much later, so the copy of it+  -- that ends up inside the fused SOAC must be given fresh names.+  soac_p <- flip SOAC.setLambda soac_p0 <$> renameLambda (SOAC.lambda soac_p0)   -- We are fusing soac_p into soac_c, i.e, the output of soac_p is going   -- into soac_c.   let soac_c = fsSOAC ker@@ -214,15 +217,8 @@       lam_c = SOAC.lambda soac_c       w = SOAC.width soac_p       returned_outvars = filter (`nameIn` unfus_set) outVars-      success res_outnms res_soac = do-        -- Avoid name duplication, because the producer lambda is not-        -- removed from the program until much later.-        uniq_lam <- renameLambda $ SOAC.lambda res_soac-        pure $-          ker-            { fsSOAC = uniq_lam `SOAC.setLambda` res_soac,-              fsOutNames = res_outnms-            }+      success res_outnms res_soac =+        pure $ ker {fsSOAC = res_soac, fsOutNames = res_outnms}    -- Can only fuse SOACs with same width.   guard $ SOAC.width soac_p == SOAC.width soac_c@@ -308,27 +304,27 @@       SOAC.Hist _ _ ops_p _,       Horizontal       ) -> do-        let p_num_buckets = length ops_p-            c_num_buckets = length ops_c+        let p_num_is = sum $ map (shapeRank . histShape) ops_p+            c_num_is = sum $ map (shapeRank . histShape) ops_c             (body_p, body_c) = (lambdaBody lam_p, lambdaBody lam_c)             body' =               Body                 { bodyDec = bodyDec body_p, -- body_p and body_c have the same decorations                   bodyStms = bodyStms body_p <> bodyStms body_c,                   bodyResult =-                    take c_num_buckets (bodyResult body_c)-                      ++ take p_num_buckets (bodyResult body_p)-                      ++ drop c_num_buckets (bodyResult body_c)-                      ++ drop p_num_buckets (bodyResult body_p)+                    take c_num_is (bodyResult body_c)+                      ++ take p_num_is (bodyResult body_p)+                      ++ drop c_num_is (bodyResult body_c)+                      ++ drop p_num_is (bodyResult body_p)                 }             lam' =               Lambda                 { lambdaParams = lambdaParams lam_c ++ lambdaParams lam_p,                   lambdaBody = body',                   lambdaReturnType =-                    replicate (c_num_buckets + p_num_buckets) (Prim int64)-                      ++ drop c_num_buckets (lambdaReturnType lam_c)-                      ++ drop p_num_buckets (lambdaReturnType lam_p)+                    replicate (c_num_is + p_num_is) (Prim int64)+                      ++ drop c_num_is (lambdaReturnType lam_c)+                      ++ drop p_num_is (lambdaReturnType lam_p)                 }         success (fsOutNames ker ++ returned_outvars) $           SOAC.Hist w (inp_c_arr <> inp_p_arr) (ops_c <> ops_p) lam'@@ -775,9 +771,24 @@     all       ((== MapNest.depth mapnest) . arrayRank)       (MapNest.typeOf mapnest)-  mapnest' <- MapNest.reshape cs (newShape newshape) mapnest+  -- Reshaping the nest changes its parallel dimensions, e.g. an unflattening+  -- splits one dimension into several. When the innermost lambda contains a+  -- SOAC (such as a reduction), this can inhibit later optimisations: a matrix+  -- multiplication whose result is unflattened becomes a nest where one operand+  -- varies with two of the dimensions, which tiling cannot handle (see+  -- tests/tiling/tiling_mm_unflatten.fut). In that case we only allow+  -- coercions. As a simple heuristic, we only look at the top-level statements+  -- of the innermost lambda. The proper solution is for tiling to handle such+  -- nests.+  guard $+    reshapeKind newshape == ReshapeCoerce+      || not (any (isSOAC . stmExp) (bodyStms (lambdaBody (MapNest.mapNestLambda mapnest))))+  mapnest' <- MapNest.reshape cs newshape mapnest   soac' <- MapNest.toSOAC mapnest'   pure (soac', ots')+  where+    isSOAC Op {} = True+    isSOAC _ = False  -- Tie it all together in exposeInputs (for making inputs to a -- consumer available) and pullOutputTransforms (for moving
src/Futhark/Optimise/GenRedOpt.hs view
@@ -202,7 +202,7 @@     --     getAccLambda acc_tp =       case acc_tp of-        (Acc tp_id _shp el_tps _) ->+        (Acc tp_id _shp el_tps) ->           case M.lookup tp_id (fst env) of             Just lam -> Just (lam, el_tps)             _ -> Nothing
src/Futhark/Optimise/MergeGPUBodies.hs view
@@ -203,7 +203,7 @@     WithAcc inputs lambda -> do       accs <- mapM (transformWithAccInput aliases) inputs       let (inputs', input_deps) = unzip accs-      -- The lambda parameters are all unique and thus have no aliases.+      -- The lambda parameters are all consuming and thus have no aliases.       (lambda', deps) <- transformLambda aliases lambda       pure (WithAcc inputs' lambda', deps <> fold input_deps)     Op {} ->@@ -580,15 +580,15 @@ rewriteCerts (Certs cs) =   Certs <$> mapM rewriteName cs -rewriteType :: TypeBase Shape u -> RewriteM (TypeBase Shape u)+rewriteType :: TypeBase Shape o -> RewriteM (TypeBase Shape o) -- Note: mapOnType also maps the VName token of accumulators rewriteType = mapOnType rewriteSubExp -rewriteExtType :: TypeBase ExtShape u -> RewriteM (TypeBase ExtShape u)+rewriteExtType :: TypeBase ExtShape o -> RewriteM (TypeBase ExtShape o) -- Note: mapOnExtType also maps the VName token of accumulators rewriteExtType = mapOnExtType rewriteSubExp -rewriteParam :: Param (TypeBase Shape u) -> RewriteM (Param (TypeBase Shape u))+rewriteParam :: Param (TypeBase Shape o) -> RewriteM (Param (TypeBase Shape o)) rewriteParam (Param attrs n t) =   Param attrs n <$> rewriteType t
src/Futhark/Optimise/ReduceDeviceSyncs.hs view
@@ -40,9 +40,11 @@   where     onConsts consts_mt stms =       runReduceM consts_mt (optimizeStms stms)-    onFun hof consts_mt fd = do-      let mt = consts_mt <> analyseFunDef hof fd-      runReduceM mt (optimizeFunDef fd)+    onFun hof consts_mt fd+      | "cpu_function" `inAttrs` funDefAttrs fd = pure fd+      | otherwise = do+          let mt = consts_mt <> analyseFunDef hof fd+          runReduceM mt (optimizeFunDef fd)  -------------------------------------------------------------------------------- --                            AD HOC OPTIMIZATION                             --@@ -130,7 +132,7 @@                 n' <- newName n                 -- v_kept_on_device implies that v is a scalar.                 let dims' = dims ++ [intConst Int64 1]-                let arr_t' = Array (elemType arr_t) (Shape dims') NoUniqueness+                let arr_t' = Array (elemType arr_t) (Shape dims') NoMode                 let pat' = Pat [PatElem n' arr_t']                 let e' = BasicOp $ Replicate (Shape dims) (Var v')                 let repl = Let pat' (stmAux stm) e'@@ -209,7 +211,7 @@                -- Migrate the parameter.               pn' <- newName pn-              let pt' = toDecl (patElemType pe') Nonunique+              let pt' = toDecl (patElemType pe') Observe               let pval' = Var arr               let param' = (Param mempty pn' pt', pval') @@ -250,7 +252,7 @@         -- Read migrated scalars that are used on host.         foldM addRead (out' |> stm') (zip pes pes')       WithAcc inputs lmd -> do-        let getAcc (Acc a _ _ _) = a+        let getAcc (Acc a _ _) = a             getAcc _ =               compilerBugS                 "Type error: WithAcc expression did not return accumulator."@@ -775,7 +777,7 @@ -- | Rewrite the binding introduced by a single parameter (to ensure it is -- unique) and fix any dependencies that are broken as a result of migration or -- rewriting.-rewriteParam :: Param (TypeBase Shape u) -> RewriteM (Param (TypeBase Shape u))+rewriteParam :: Param (TypeBase Shape o) -> RewriteM (Param (TypeBase Shape o)) rewriteParam (Param attrs n t) = do   n' <- rewriteName n   t' <- renameType t@@ -826,12 +828,12 @@  -- | Update the variable names within a type to account for migration and -- rewriting.-renameType :: TypeBase Shape u -> RewriteM (TypeBase Shape u)+renameType :: TypeBase Shape o -> RewriteM (TypeBase Shape o) -- Note: mapOnType also maps the VName token of accumulators renameType = mapOnType renameSubExp  -- | Update the variable names within an existential type to account for -- migration and rewriting.-renameExtType :: TypeBase ExtShape u -> RewriteM (TypeBase ExtShape u)+renameExtType :: TypeBase ExtShape o -> RewriteM (TypeBase ExtShape o) -- Note: mapOnExtType also maps the VName token of accumulators renameExtType = mapOnExtType renameSubExp
src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs view
@@ -295,7 +295,7 @@ isScalar :: (Typed t) => t -> Bool isScalar = isScalarType . typeOf -isScalarType :: TypeBase shape u -> Bool+isScalarType :: TypeBase shape o -> Bool isScalarType (Prim Unit) = False isScalarType (Prim _) = True isScalarType _ = False@@ -303,7 +303,7 @@ isArray :: (Typed t) => t -> Bool isArray = isArrayType . typeOf -isArrayType :: (ArrayShape shape) => TypeBase shape u -> Bool+isArrayType :: (ArrayShape shape) => TypeBase shape o -> Bool isArrayType = (0 <) . arrayRank  --------------------------------------------------------------------------------@@ -580,7 +580,7 @@  -- | Graph an 'UpdateAcc' statement. graphUpdateAcc :: Binding -> Exp GPU -> Grapher ()-graphUpdateAcc b e | (_, Acc a _ _ _) <- b =+graphUpdateAcc b e | (_, Acc a _ _) <- b =   -- The actual graphing is delayed to the corrensponding 'WithAcc' parent.   modify $ \st ->     let accs = stateUpdateAccs st@@ -915,7 +915,7 @@   ret <- mapM (onlyGraphedScalarSubExp . resSubExp) res   mapM_ (uncurry createNode) $ zip (drop (length arrs) bs) ret   where-    graph (Acc a _ types _, (_, _, comb)) = do+    graph (Acc a _ types, (_, _, comb)) = do       let i = nameToId a        delayed <- fromMaybe [] <$> gets (IM.lookup i . stateUpdateAccs)@@ -1042,7 +1042,7 @@     collectStm (Let pat _ ua)       | BasicOp UpdateAcc {} <- ua,         Pat [pe] <- pat,-        Acc a _ _ _ <- typeOf pe =+        Acc a _ _ <- typeOf pe =           -- Capture the tokens of accumulators used on host.           captureAcc a >> collectBasic ua     collectStm stm = collect (stmExp stm)@@ -1058,7 +1058,7 @@       collectBody (lambdaBody f)       used_accs <- gets snd       let accs = take (length inputs) (lambdaReturnType f)-      let used = map (\(Acc a _ _ _) -> S.member a used_accs) accs+      let used = map (\(Acc a _ _) -> S.member a used_accs) accs       mapM_ collectAcc (zip used inputs)      collectAcc (_, (_, _, Nothing)) = pure ()
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -255,14 +255,14 @@ makeSafe :: Exp rep -> Maybe (Exp rep) makeSafe (BasicOp (BinOp (SDiv t _) x y)) =   Just $ BasicOp (BinOp (SDiv t Safe) x y)-makeSafe (BasicOp (BinOp (SDivUp t _) x y)) =-  Just $ BasicOp (BinOp (SDivUp t Safe) x y)+makeSafe (BasicOp (BinOp (SCeilDiv t _) x y)) =+  Just $ BasicOp (BinOp (SCeilDiv t Safe) x y) makeSafe (BasicOp (BinOp (SQuot t _) x y)) =   Just $ BasicOp (BinOp (SQuot t Safe) x y) makeSafe (BasicOp (BinOp (UDiv t _) x y)) =   Just $ BasicOp (BinOp (UDiv t Safe) x y)-makeSafe (BasicOp (BinOp (UDivUp t _) x y)) =-  Just $ BasicOp (BinOp (UDivUp t Safe) x y)+makeSafe (BasicOp (BinOp (UCeilDiv t _) x y)) =+  Just $ BasicOp (BinOp (UCeilDiv t Safe) x y) makeSafe (BasicOp (BinOp (SMod t _) x y)) =   Just $ BasicOp (BinOp (SMod t Safe) x y) makeSafe (BasicOp (BinOp (SRem t _) x y)) =@@ -430,7 +430,7 @@ nonrecSimplifyStm (Let pat (StmAux cs attrs loc (_, dec)) e) = do   cs' <- simplify cs   e' <- simplifyExpBase e-  (pat', pat_cs) <- collectCerts $ traverse simplify $ removePatWisdom pat+  (pat', pat_cs) <- collectCerts $ traverse (simplify . snd) pat   let aux' = StmAux (cs' <> pat_cs) attrs loc dec   pure $ mkWiseStm pat' aux' e' @@ -754,10 +754,6 @@ simplifyBodyNoHoisting usage res_usages body =   snd <$> simplifyBody (isFalse False) usage res_usages body -usageFromDiet :: Diet -> UT.Usages-usageFromDiet Consume = UT.consumedU-usageFromDiet _ = mempty- -- | Simplify a single 'Result'. simplifyResult ::   (SimplifiableRep rep) => [UT.Usages] -> Result -> SimpleM rep (Result, UT.UsageTable)@@ -875,7 +871,7 @@       $ do         let params_usages =               map-                (\p -> if unique (paramDeclType p) then UT.consumedU else mempty)+                (\p -> if consuming (paramDeclType p) then UT.consumedU else mempty)                 params'         (res, uses) <- simplifyResult params_usages $ bodyResult loopbody         pure (res, uses <> isLoopResult res)@@ -887,7 +883,7 @@     consumeMerge =       localVtable $ flip (foldl' (flip ST.consume)) $ namesToList consumed_by_merge     consumed_by_merge =-      freeIn $ map snd $ filter (unique . paramDeclType . fst) merge+      freeIn $ map snd $ filter (consuming . paramDeclType . fst) merge     withRes (p, x) y = (p, x, y) simplifyExp _ _ (Op op) = do   (op', stms) <- simplifyOp op@@ -1056,11 +1052,11 @@ instance Simplifiable PrimType where   simplify = pure -instance (Simplifiable shape) => Simplifiable (TypeBase shape u) where-  simplify (Array et shape u) =-    Array <$> simplify et <*> simplify shape <*> pure u-  simplify (Acc acc ispace ts u) =-    Acc <$> simplify acc <*> simplify ispace <*> simplify ts <*> pure u+instance (Simplifiable shape) => Simplifiable (TypeBase shape o) where+  simplify (Array et shape o) =+    Array <$> simplify et <*> simplify shape <*> pure o+  simplify (Acc acc ispace ts) =+    Acc <$> simplify acc <*> simplify ispace <*> simplify ts   simplify (Mem space) =     Mem <$> simplify space   simplify (Prim bt) =@@ -1118,6 +1114,7 @@   pure (Lambda params' rettype' body', hoisted)  instance Simplifiable Certs where+  simplify (Certs []) = pure (Certs [])   simplify (Certs ocs) = Certs . nubOrd . concat <$> mapM check ocs     where       check idd = do@@ -1145,9 +1142,16 @@     aliasable_rets =       map snd $ filter (aliasable . extTypeOf . fst . fst) $ zip rettype [0 ..]     restricted als = any (`notElem` als)-    usageFromRet (t, RetAls pals rals) =-      usageFromDiet (diet $ declExtTypeOf t)-        <> if restricted pals aliasable_params-          || restricted rals aliasable_rets-          then UT.consumedU-          else mempty+    -- A non-Prim result is marked consumed when simplification must not+    -- introduce aliasing at that position. For arrays the 'RetAls' decide this+    -- on their own: a fresh result has empty alias sets, which is the maximally+    -- restricted case, so it needs no separate test. An accumulator is+    -- different - it carries no aliasing information at all, being linear+    -- rather than aliased - and every use of one consumes it.+    usageFromRet (t, RetAls pals rals)+      | isAcc $ extTypeOf t = UT.consumedU+      | primType $ extTypeOf t = mempty+      | restricted pals aliasable_params+          || restricted rals aliasable_rets =+          UT.consumedU+      | otherwise = mempty
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -79,20 +79,19 @@       Simplify $ auxing aux $ letBindNames [patElemName d] $ BasicOp $ SubExp $ Var v   where     v_not_used_again = not (v `UT.used` used)-    v_is_fresh = v `ST.lookupAliases` vtable == mempty+    -- A parameter has no aliases, but is not fresh: it is the array of+    -- whoever supplied it, so the result must not come to alias it.+    v_is_fresh =+      isJust (ST.lookupStm v vtable) && v `ST.lookupAliases` vtable == mempty     -- We need to make sure we can even consume the original.  The big     -- missing piece here is that we cannot do copy removal inside of     -- 'map' and other SOACs, but that is handled by SOAC-specific rules.     consumable = fromMaybe False $ do       e <- ST.lookup v vtable       guard $ ST.entryDepth e == ST.loopDepth vtable-      consumableStm e `mplus` consumableFParam e+      (True <$ guard v_is_fresh) `mplus` consumableFParam e     consumableFParam =-      Just . maybe False (unique . declTypeOf) . ST.entryFParam-    consumableStm e = do-      void $ ST.entryStm e -- Must be a stm.-      guard v_is_fresh-      pure True+      Just . maybe False (consuming . declTypeOf) . ST.entryFParam removeUnnecessaryCopy _ _ _ _ = Skip  constantFoldPrimFun :: (BuilderOps rep) => TopDownRuleGeneric rep@@ -145,7 +144,7 @@  simplifyIndex :: (BuilderOps rep) => BottomUpRuleBasicOp rep simplifyIndex (vtable, used) pat@(Pat [pe]) aux (Index idd inds)-  | Just m <- simplifyIndexing vtable seType idd inds consumed consuming =+  | Just m <- simplifyIndexing vtable seType idd inds consumed consuming' =       Simplify $ certifying (stmAuxCerts aux) $ do         res <- m         attributing (stmAuxAttrs aux) $ case res of@@ -154,8 +153,8 @@           IndexResult extra_cs idd' inds' ->             certifying extra_cs $ letBindNames (patNames pat) $ BasicOp $ Index idd' inds'   where-    consuming = (`UT.isConsumed` used)-    consumed = consuming $ patElemName pe+    consuming' = (`UT.isConsumed` used)+    consumed = consuming' $ patElemName pe     seType (Var v) = ST.lookupType v vtable     seType (Constant v) = Just $ Prim $ primValueType v simplifyIndex _ _ _ _ = Skip@@ -231,7 +230,7 @@       pure body {bodyStms = stms'}     onStms = traverse onStm     onStm (Let pat@(Pat [PatElem _ dec]) aux (BasicOp (UpdateAcc _ acc _ _)))-      | Acc c _ _ _ <- typeOf dec,+      | Acc c _ _ <- typeOf dec,         c `elem` get_rid_of = do           modify (insert c)           pure $ Let pat aux $ BasicOp $ SubExp $ Var acc
src/Futhark/Optimise/Simplify/Rules/BasicOp.hs view
@@ -195,7 +195,7 @@               Reshape v $                 reshapeAll (arrayShape v_t) (arrayShape dest_t)           letBind pat $ BasicOp $ Replicate mempty v_reshaped-        _ -> letBind pat $ BasicOp $ ArrayLit [se] $ rowType dest_t+        _ -> letBind pat $ BasicOp $ Replicate (arrayShape dest_t) se ruleBasicOp vtable pat aux (Update safety1 dest1 is1 (Var v1))   | Just (Update safety2 dest2 is2 se2, cs2) <- ST.lookupBasicOp v1 vtable,     Just (Replicate (Shape []) (Var v3), cs3) <- ST.lookupBasicOp dest2 vtable,@@ -252,27 +252,6 @@       Simplify $         let n = constant (fromIntegral (length ses) + 1 :: Int64)          in letBind pat $ BasicOp $ Replicate (Shape [n]) se-ruleBasicOp vtable pat aux (Index idd slice)-  | Just inds <- sliceIndices slice,-    Just (BasicOp (Reshape idd2 newshape), idd_cs) <- ST.lookupExp idd vtable,-    shapeRank (newShape newshape) == length inds = Simplify $-      case reshapeKind newshape of-        ReshapeCoerce ->-          certifying idd_cs . auxing aux . letBind pat . BasicOp $-            Index idd2 slice-        ReshapeArbitrary -> do-          -- Linearise indices and map to old index space.-          oldshape <- arrayDims <$> lookupType idd2-          let new_inds =-                reshapeIndex-                  (map pe64 oldshape)-                  (map pe64 $ shapeDims $ newShape newshape)-                  (map pe64 inds)-          new_inds' <--            mapM (toSubExp "new_index") new_inds-          certifying idd_cs . auxing aux . letBind pat . BasicOp $-            Index idd2 (Slice $ map DimFix new_inds')- -- Copying an iota is pointless; just make it an iota instead. ruleBasicOp vtable pat aux (Replicate (Shape []) (Var v))   | Just (Iota n x s it, v_cs) <- ST.lookupBasicOp v vtable =@@ -352,7 +331,7 @@ -- always a no-op. ruleBasicOp vtable pat aux (UpdateAcc _ acc _ vs)   | Pat [pe] <- pat,-    Acc token _ _ _ <- patElemType pe,+    Acc token _ _ <- patElemType pe,     Just (_, _, Just (_, ne)) <- ST.entryAccInput =<< ST.lookup token vtable,     vs == ne =       Simplify . auxing aux $ letBind pat $ BasicOp $ SubExp $ Var acc
src/Futhark/Optimise/Simplify/Rules/Index.hs view
@@ -15,7 +15,7 @@ import Futhark.Analysis.PrimExp.Convert import Futhark.Analysis.SymbolTable qualified as ST import Futhark.Construct-import Futhark.IR+import Futhark.IR hiding (consuming) import Futhark.Optimise.Simplify.Rules.Simple import Futhark.Util @@ -56,15 +56,10 @@   Maybe (m IndexResult) simplifyIndexing vtable seType idd (Slice inds) consuming consumed =   case defOf idd of-    -- FIXME: This is a special case to avoid simplifying away a slice of a-    -- rearrange. This is because register tiling cannot otherwise properly-    -- detect what is going on.     Just (Rearrange src perm, cs)       | rearrangeReach perm <= length (takeWhile isIndex inds) ->           let inds' = rearrangeShape (rearrangeInverse perm) inds            in Just $ pure $ IndexResult cs src $ Slice inds'-      | any isIndex inds ->-          Nothing       where         isIndex DimFix {} = True         isIndex _ = False@@ -197,20 +192,6 @@         not consuming,         ST.available src vtable ->           Just $ pure $ IndexResult cs src $ Slice inds-    Just (Reshape src newshape, cs)-      | ReshapeCoerce <- reshapeKind newshape,-        Just olddims <- arrayDims <$> seType (Var src),-        changed_dims <- zipWith (/=) (shapeDims (newShape newshape)) olddims,-        not $ or $ drop (length inds) changed_dims ->-          Just $ pure $ IndexResult cs src $ Slice inds-      | Just olddims <- arrayDims <$> seType (Var src),-        length newshape == length inds,-        length olddims == length (shapeDims (newShape newshape)) ->-          Just $ pure $ IndexResult cs src $ Slice inds-    Just (Reshape v2 newshape, cs)-      | Shape [_] <- newShape newshape,-        Just [_] <- arrayDims <$> seType (Var v2) ->-          Just $ pure $ IndexResult cs v2 $ Slice inds     Just (Concat d (x :| xs) _, cs)       | -- HACK: simplifying the indexing of an N-array concatenation         -- is going to produce an N-deep if expression, which is bad@@ -250,14 +231,15 @@           SubExpResult mempty <$> mkBranch xs_and_starts     Just (ArrayLit ses _, cs)       | DimFix (Constant (IntValue (Int64Value i))) : inds' <- inds,-        Just se <- maybeNth i ses ->+        Just se <- maybeNth i ses,+        forwardable se ->           case inds' of             [] -> Just $ pure $ SubExpResult cs se             _ | Var v2 <- se -> Just $ pure $ IndexResult cs v2 $ Slice inds'             _ -> Nothing     Just (Update Unsafe _ (Slice update_inds) se, cs)       | inds == update_inds,-        ST.subExpAvailable se vtable ->+        forwardable se ->           Just $ pure $ SubExpResult cs se     -- Indexing single-element arrays.  We know the index must be 0.     _@@ -272,6 +254,15 @@     defOf v = do       (BasicOp op, def_cs) <- ST.lookupExp v vtable       pure (op, def_cs)++    -- Whether the result may be replaced by 'se' (or a slice of it),+    -- which makes the result alias 'se'. This is only valid if 'se'+    -- has not been consumed already, is not consumed later, and the+    -- result itself is not consumed.+    forwardable (Constant _) = True+    forwardable (Var v) =+      not consuming && not (consumed v) && ST.available v vtable+     worthInlining e       | primExpSizeAtLeast 20 e = False -- totally ad-hoc.       | otherwise = worthInlining' e@@ -281,7 +272,11 @@     worthInlining' (CmpOpExp _ x y) = worthInlining' x && worthInlining' y     worthInlining' (ConvOpExp _ x) = worthInlining' x     worthInlining' (UnOpExp _ x) = worthInlining' x-    worthInlining' FunExp {} = False+    -- A conditional is a cheap select, unlike the transcendental functions+    -- that a 'FunExp' otherwise denotes.+    worthInlining' (FunExp f args _)+      | isJust $ isCondFun f = all worthInlining' args+      | otherwise = False     worthInlining' _ = True      isConcat v
src/Futhark/Optimise/Simplify/Rules/Loop.hs view
@@ -57,7 +57,7 @@               -- body may still use their names in (now-dead) expressions.               -- Hence, we add them inside the loop, fully aware that dead-code               -- removal will eventually get rid of them.  Some care is-              -- necessary to handle unique bindings.+              -- necessary to handle consuming parameters.               body'' <- insertStmsM $ do                 mapM_ (uncurry letBindNames) $ dummyStms discard_val                 pure body'@@ -74,7 +74,7 @@      dummyStms = map dummyStm     dummyStm ((p, e), _)-      | unique (paramDeclType p),+      | consuming (paramDeclType p),         Var v <- e =           ([paramName p], BasicOp $ Replicate mempty $ Var v)       | otherwise = ([paramName p], BasicOp $ SubExp e)
src/Futhark/Optimise/Simplify/Rules/Simple.hs view
@@ -131,7 +131,7 @@   | isCt0 e1 = resIsSubExp e1   | isCt1 e2 = resIsSubExp e1   | isCt0 e2 = Nothing-simplifyBinOp _ _ (BinOp SDivUp {} e1 e2)+simplifyBinOp _ _ (BinOp SCeilDiv {} e1 e2)   | isCt0 e1 = resIsSubExp e1   | isCt1 e2 = resIsSubExp e1   | isCt0 e2 = Nothing
src/Futhark/Optimise/TileLoops.hs view
@@ -379,7 +379,7 @@   let (mergeparams, mergeinits) = unzip merge        -- Expand the loop merge parameters to be arrays.-      tileDim t = arrayOf t (tilingTileShape tiling) $ uniqueness t+      tileDim t = arrayOf t (tilingTileShape tiling) $ diet t        merge_scope = M.insert i (IndexName it) $ scopeOfFParams mergeparams @@ -448,14 +448,24 @@  doPrelude :: Tiling -> PrivStms -> Stms GPU -> [VName] -> Builder GPU [VName] doPrelude tiling privstms prestms prestms_live =-  -- Create a SegMap that takes care of the prelude for every thread.-  tilingSegMap tiling "prelude" ResultPrivate $ \in_bounds slice -> do-    ts <- mapM lookupType prestms_live-    fmap varsRes . protectOutOfBounds "pre" in_bounds ts $ do-      addPrivStms slice privstms-      addStms prestms-      pure $ varsRes prestms_live+  -- Create a SegMap that takes care of the prelude for every thread,+  -- including those that are out of bounds. See Note [Clamped thread+  -- indices].+  tilingSegMap tiling "prelude" ResultPrivate $ \_in_bounds slice -> do+    addPrivStms slice privstms+    addStms prestms+    pure $ varsRes prestms_live +-- Note [Clamped thread indices]+--+-- The thread indices bound by 'tilingSegMap' are clamped to be in+-- bounds, with the actual in-bounds status passed separately. This lets+-- every thread compute the prelude, which is needed because the prelude+-- is also used when threads collectively read tiles: in 2D tiling, a+-- thread that is out of bounds in one dimension must still read tile+-- elements of inputs that depend only on the other dimension (and+-- clamping does not affect those).+ liveSet :: (FreeIn a) => Stms GPU -> a -> Names liveSet stms after =   namesFromList (concatMap (patNames . stmPat) stms)@@ -583,7 +593,9 @@       ResultManifest ->       (PrimExp VName -> [DimIndex SubExp] -> Builder GPU Result) ->       Builder GPU [VName],-    -- The boolean PrimExp indicates whether they are in-bounds.+    -- The thread indices are clamped to be in bounds, and the boolean+    -- PrimExp indicates whether the thread is actually in bounds. See+    -- Note [Clamped thread indices].      tilingReadTile ::       TileKind ->@@ -617,7 +629,7 @@   -- This is more complicated than you might expect, because we need   -- to be able to produce a blank accumulator, which eBlank cannot   -- do.  By the linear type rules of accumulators, the body returns-  -- an accumulator of type 'acc_t', then a unique variable of type+  -- an accumulator of type 'acc_t', then a distinct variable of type   -- 'acc_t' must also be free in the body.  This means we can find it   -- based just on the type.   m_body <- insertStmsM $ mkBody mempty <$> m@@ -697,7 +709,7 @@         (,)           <$> newParam             (baseName (paramName p) <> "_merge")-            (paramType p `arrayOfShape` tile_shape `toDecl` Unique)+            (paramType p `arrayOfShape` tile_shape `toDecl` Consume)           <*> pure (Var mergeinit)        tile_id <- newVName "tile_id"@@ -835,6 +847,9 @@       tile_id = processTileId tile_args       accs = processAcc tile_args +  -- Might be truncated in case of a partial tile.+  actual_tile_size <- findTileSize tiles+   segMap1D "acc" lvl ResultPrivate (unCount tblock_size) $ \ltid -> do     reconstructGtids1D tblock_size gtid gid ltid     addPrivStms [DimFix $ Var ltid] privstms@@ -847,7 +862,7 @@     let sliceTile (InputTiled _ arr) =           pure arr         sliceTile (InputUntiled arr) =-          sliceUntiled arr tile_id tile_size tile_size+          sliceUntiled arr tile_id tile_size actual_tile_size      tiles' <- mapM sliceTile tiles @@ -856,7 +871,7 @@       letTupExp "acc"         =<< eIf           (toExp $ le64 gtid .<. pe64 kdim)-          (eBody [pure $ Op $ OtherOp $ Screma tile_size tiles' form'])+          (eBody [pure $ Op $ OtherOp $ Screma actual_tile_size tiles' form'])           (resultBodyM thread_accs)   where     lvl = SegThreadInBlock SegNoVirt@@ -920,7 +935,7 @@       -- updates its accumulator.       let tile_args =             ProcessTileArgs privstms red_comm red_lam map_lam tiles accs num_whole_tiles-      varsRes <$> processTile1D gid gtid kdim residual_input grid tile_args+      varsRes <$> processTile1D gid gtid kdim tile_size grid tile_args  tiling1d :: [(VName, SubExp)] -> DoTiling VName SubExp tiling1d dims_on_top gtid kdim w = do@@ -935,7 +950,7 @@     -- How many blocks we need to exhaust the innermost dimension.     ldim <-       letSubExp "ldim" . BasicOp $-        BinOp (SDivUp Int64 Unsafe) kdim tblock_size+        BinOp (SCeilDiv Int64 Unsafe) kdim tblock_size      num_tblocks <-       letSubExp "computed_num_tblocks"@@ -950,9 +965,10 @@   pure     Tiling       { tilingSegMap = \desc manifest f -> segMap1D desc tiling_lvl manifest tile_size $ \ltid -> do-          letBindNames [gtid]-            =<< toExp (le64 gid * pe64 tile_size + le64 ltid)-          f (untyped $ le64 gtid .<. pe64 kdim) [DimFix $ Var ltid],+          -- See Note [Clamped thread indices].+          let pos = le64 gid * pe64 tile_size + le64 ltid+          letBindNames [gtid] =<< toExp (sMin64 pos (pe64 kdim - 1))+          f (untyped $ pos .<. pe64 kdim) [DimFix $ Var ltid],         tilingReadTile =           readTile1D tile_size gid gtid grid,         tilingProcessTile =@@ -1198,11 +1214,11 @@   num_tblocks_x <-     letSubExp "num_tblocks_x" $       BasicOp $-        BinOp (SDivUp Int64 Unsafe) kdim_x tile_size+        BinOp (SCeilDiv Int64 Unsafe) kdim_x tile_size   num_tblocks_y <-     letSubExp "num_tblocks_y" $       BasicOp $-        BinOp (SDivUp Int64 Unsafe) kdim_y tile_size+        BinOp (SCeilDiv Int64 Unsafe) kdim_y tile_size    num_tblocks <-     letSubExp "num_tblocks_top"@@ -1223,11 +1239,13 @@     Tiling       { tilingSegMap = \desc manifest f ->           segMap2D desc tiling_lvl manifest (tile_size, tile_size) $ \(ltid_x, ltid_y) -> do-            reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y)+            -- See Note [Clamped thread indices].+            let pos_x = le64 gid_x * pe64 tile_size + le64 ltid_x+                pos_y = le64 gid_y * pe64 tile_size + le64 ltid_y+            letBindNames [gtid_x] =<< toExp (sMin64 pos_x (pe64 kdim_x - 1))+            letBindNames [gtid_y] =<< toExp (sMin64 pos_y (pe64 kdim_y - 1))             f-              ( untyped $-                  le64 gtid_x .<. pe64 kdim_x .&&. le64 gtid_y .<. pe64 kdim_y-              )+              (untyped $ pos_x .<. pe64 kdim_x .&&. pos_y .<. pe64 kdim_y)               [DimFix $ Var ltid_x, DimFix $ Var ltid_y],         tilingReadTile = readTile2D (kdim_x, kdim_y) (gtid_x, gtid_y) (gid_x, gid_y) tile_size,         tilingProcessTile = processTile2D (gid_x, gid_y) (gtid_x, gtid_y) (kdim_x, kdim_y) tile_size,
src/Futhark/Optimise/TileLoops/Shared.hs view
@@ -61,7 +61,7 @@   let loop_form = ForLoop i Int64 i_bound    merge_ts <- mapM lookupType merge-  loop_inits <- mapM (\merge_t -> newParam "merge" $ toDecl merge_t Unique) merge_ts+  loop_inits <- mapM (\merge_t -> newParam "merge" $ toDecl merge_t Consume) merge_ts    loop_body <-     insertStmsM $@@ -112,14 +112,14 @@     Builder GPU Result   ) ->   Builder GPU [VName]-segMap2D desc lvl manifest (dim_y, dim_x) f = do-  ltid_xx <- newVName "ltid_x"-  ltid_yy <- newVName "ltid_y"+segMap2D desc lvl manifest (dim_x, dim_y) f = do+  ltid_x <- newVName "ltid_x"+  ltid_y <- newVName "ltid_y"   ltid_flat <- newVName "ltid_flat"-  let segspace = SegSpace ltid_flat [(ltid_yy, dim_y), (ltid_xx, dim_x)]+  let segspace = SegSpace ltid_flat [(ltid_x, dim_x), (ltid_y, dim_y)]    ((ts, res), stms) <- localScope (scopeOfSegSpace segspace) . runBuilder $ do-    res <- f (ltid_yy, ltid_xx)+    res <- f (ltid_x, ltid_y)     ts <- mapM subExpResType res     pure (ts, res) @@ -132,20 +132,20 @@   Name -> -- desc   SegLevel -> -- lvl   ResultManifest -> -- manifest-  (SubExp, SubExp, SubExp) -> -- (dim_z, dim_y, dim_x)+  (SubExp, SubExp, SubExp) -> -- (dim_x, dim_y, dim_z)   ( (VName, VName, VName) -> -- f     Builder GPU Result   ) ->   Builder GPU [VName]-segMap3D desc lvl manifest (dim_z, dim_y, dim_x) f = do+segMap3D desc lvl manifest (dim_x, dim_y, dim_z) f = do   ltid_flat <- newVName "ltid_flat"-  ltid_z <- newVName "ltid_z"-  ltid_y <- newVName "ltid_y"   ltid_x <- newVName "ltid_x"-  let segspace = SegSpace ltid_flat [(ltid_z, dim_z), (ltid_y, dim_y), (ltid_x, dim_x)]+  ltid_y <- newVName "ltid_y"+  ltid_z <- newVName "ltid_z"+  let segspace = SegSpace ltid_flat [(ltid_x, dim_x), (ltid_y, dim_y), (ltid_z, dim_z)]    ((ts, res), stms) <- localScope (scopeOfSegSpace segspace) . runBuilder $ do-    res <- f (ltid_z, ltid_y, ltid_x)+    res <- f (ltid_x, ltid_y, ltid_z)     ts <- mapM subExpResType res     pure (ts, res) @@ -158,19 +158,19 @@   Name ->   VName ->   [SubExp] -> -- dims of sequential loop on top-  (SubExp, SubExp) -> -- (dim_y, dim_x)+  (SubExp, SubExp) -> -- (dim_x, dim_y)   ([VName] -> (VName, VName) -> Builder GPU (SubExp, SubExp)) -> -- f   Builder GPU VName segScatter2D desc updt_arr seq_dims (dim_x, dim_y) f =   letExp desc <=< withAcc [updt_arr] 1 $ \ ~[acc] -> do     ltid_flat <- newVName "ltid_flat"-    ltid_y <- newVName "ltid_y"     ltid_x <- newVName "ltid_x"+    ltid_y <- newVName "ltid_y"      seq_is <- replicateM (length seq_dims) (newVName "ltid_seq")     let seq_space = zip seq_is seq_dims -    let segspace = SegSpace ltid_flat $ seq_space ++ [(ltid_y, dim_y), (ltid_x, dim_x)]+    let segspace = SegSpace ltid_flat $ seq_space ++ [(ltid_x, dim_x), (ltid_y, dim_y)]         lvl =           SegThreadInBlock             (SegNoVirtFull (SegSeqDims [0 .. length seq_dims - 1]))@@ -178,7 +178,7 @@     body <- buildBody_ $ do       (res_v, res_i) <-         localScope (scopeOfSegSpace segspace) $-          f seq_is (ltid_y, ltid_x)+          f seq_is (ltid_x, ltid_y)       acc' <- letExp "acc" $ BasicOp $ UpdateAcc Safe acc [res_i] [res_v]       pure [Returns ResultMaySimplify mempty $ Var acc']
src/Futhark/Pass/AddGlobalParams.hs view
@@ -167,7 +167,7 @@   M.fromList     . concatMap       ( map-          (\pe -> (patElemName pe, toDecl (patElemType pe) Nonunique))+          (\pe -> (patElemName pe, toDecl (patElemType pe) Observe))           . patElems           . stmPat       )
src/Futhark/Pass/ExpandAllocations.hs view
@@ -678,7 +678,7 @@   (ps_ctx, ps') <- mapAccumLM onType [] ps   pure $ ps' <> ps_ctx   where-    onType acc (Param attr v (MemArray pt shape u (ArrayIn mem lmad))) = do+    onType acc (Param attr v (MemArray pt shape o (ArrayIn mem lmad))) = do       space <- lookupMemSpace mem       mem' <- newVName $ baseName mem <> "_ext"       let num_exts = length (LMAD.existentialized lmad)@@ -688,7 +688,7 @@       let lmad' = lmadFrom (LMAD.shape lmad) $ map (le64 . paramName) lmad_exts       pure         ( acc ++ Param mempty mem' (MemMem space) : lmad_exts,-          Param attr v $ MemArray pt shape u $ ArrayIn mem' lmad'+          Param attr v $ MemArray pt shape o $ ArrayIn mem' lmad'         )     onType acc t = pure (acc, t) @@ -704,7 +704,7 @@     onType       acc       ( PatElem pe_v (MemArray _ pe_shape pe_u (ArrayIn pe_mem pe_lmad)),-        MemArray pt shape u meminfo+        MemArray pt shape o meminfo         ) = do         (space, lmad) <- case meminfo of           ReturnsInBlock mem lmad -> do@@ -726,7 +726,7 @@               ++ (PatElem pe_mem' $ MemMem space, MemMem space)               : map (,MemPrim int64) lmad_exts,             ( PatElem pe_v $ MemArray pt pe_shape pe_u $ ArrayIn pe_mem' pe_lmad',-              MemArray pt shape u . ReturnsNewBlock space start . fmap ext $+              MemArray pt shape o . ReturnsNewBlock space start . fmap ext $                 LMAD.mkExistential (shapeDims shape) (1 + start)             )           )@@ -737,10 +737,10 @@   Pat $ zipWith onPE pes rets   where     onPE-      (PatElem name (MemArray pt shape u (ArrayIn mem _)))+      (PatElem name (MemArray pt shape o (ArrayIn mem _)))       (MemArray _ _ _ info)         | Just lmad <- getLMAD info =-            PatElem name . MemArray pt shape u . ArrayIn mem $+            PatElem name . MemArray pt shape o . ArrayIn mem $               fmap (fmap unExt) lmad     onPE pe _ =       offsetMemoryInMemBound offsets <$> pe@@ -750,22 +750,22 @@     getLMAD (Just (ReturnsInBlock _ lmad)) = Just lmad     getLMAD _ = Nothing -offsetMemoryInParam :: RebaseMap -> Param (MemBound u) -> Param (MemBound u)+offsetMemoryInParam :: RebaseMap -> Param (MemBound o) -> Param (MemBound o) offsetMemoryInParam offsets = fmap $ offsetMemoryInMemBound offsets -offsetMemoryInMemBound :: RebaseMap -> MemBound u -> MemBound u-offsetMemoryInMemBound offsets (MemArray pt shape u (ArrayIn mem lmad))-  | Just (o, p) <- lookupNewBase mem (LMAD.shape lmad) offsets =-      MemArray pt shape u $ ArrayIn mem $ LMAD.expand o p lmad+offsetMemoryInMemBound :: RebaseMap -> MemBound o -> MemBound o+offsetMemoryInMemBound offsets (MemArray pt shape o (ArrayIn mem lmad))+  | Just (base, p) <- lookupNewBase mem (LMAD.shape lmad) offsets =+      MemArray pt shape o $ ArrayIn mem $ LMAD.expand base p lmad offsetMemoryInMemBound _ info = info  offsetMemoryInBodyReturns :: RebaseMap -> BodyReturns -> BodyReturns-offsetMemoryInBodyReturns offsets (MemArray pt shape u (ReturnsInBlock mem lmad))+offsetMemoryInBodyReturns offsets (MemArray pt shape o (ReturnsInBlock mem lmad))   | Just lmad' <- isStaticLMAD lmad,-    Just (o, p) <- lookupNewBase mem (LMAD.shape lmad') offsets =-      MemArray pt shape u $+    Just (base, p) <- lookupNewBase mem (LMAD.shape lmad') offsets =+      MemArray pt shape o $         ReturnsInBlock mem $-          LMAD.expand (Free <$> o) (fmap Free p) lmad+          LMAD.expand (Free <$> base) (fmap Free p) lmad offsetMemoryInBodyReturns _ br = br  offsetMemoryInLambda :: RebaseMap -> Lambda GPUMem -> OffsetM (Lambda GPUMem)@@ -853,10 +853,10 @@   pure $ Let pat'' dec e'   where     pick-      (PatElem name (MemArray pt s u _ret))+      (PatElem name (MemArray pt s o _ret))       (MemArray _ _ _ (Just (ReturnsInBlock m extlmad)))         | Just lmad <- instantiateLMAD extlmad =-            PatElem name (MemArray pt s u (ArrayIn m lmad))+            PatElem name (MemArray pt s o (ArrayIn m lmad))     pick p _ = p      instantiateLMAD :: ExtLMAD -> Maybe LMAD@@ -925,10 +925,10 @@           mapOnVName = Right         } -unMem :: MemInfo d u ret -> TypeBase (ShapeBase d) u+unMem :: MemInfo d o ret -> TypeBase (ShapeBase d) o unMem (MemPrim pt) = Prim pt-unMem (MemArray pt shape u _) = Array pt shape u-unMem (MemAcc acc ispace ts u) = Acc acc ispace ts u+unMem (MemArray pt shape o _) = Array pt shape o+unMem (MemAcc acc ispace ts) = Acc acc ispace ts unMem MemMem {} = Prim Unit  unAllocScope :: Scope GPUMem -> Scope GPU.GPU
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -10,6 +10,7 @@     explicitAllocationsInStmsGeneric,     ExpHint (..),     defaultExpHints,+    scalarSpaceExpHints,     askDefaultSpace,     Allocable,     AllocM,@@ -67,7 +68,7 @@     FParamInfo fromrep ~ DeclType,     LParamInfo fromrep ~ Type,     BranchType fromrep ~ ExtType,-    RetType fromrep ~ DeclExtType,+    RetType fromrep ~ ExtType,     BodyDec fromrep ~ (),     BodyDec torep ~ (),     ExpDec torep ~ (),@@ -83,6 +84,10 @@     -- | The set of names that are known to be constants at     -- kernel compile time.     envConsts :: S.Set VName,+    -- | The memory space for function parameters. Currently we assume these are+    -- all in the same space. The result must still be in the allocSpace. This+    -- could be made more flexible.+    funSpace :: Name -> Space,     allocInOp :: Op fromrep -> AllocM fromrep torep (Op torep),     envExpHints :: Exp torep -> AllocM fromrep torep [ExpHint]   }@@ -126,19 +131,25 @@ askDefaultSpace :: AllocM fromrep torep Space askDefaultSpace = asks allocSpace +-- | The space in which this function accepts parameters and returns results.+askFunSpace :: Name -> AllocM fromrep torep Space+askFunSpace fname = asks funSpace <*> pure fname+ runAllocM ::   (MonadFreshNames m) =>   Space ->+  (Name -> Space) ->   (Op fromrep -> AllocM fromrep torep (Op torep)) ->   (Exp torep -> AllocM fromrep torep [ExpHint]) ->   AllocM fromrep torep a ->   m a-runAllocM space handleOp hints (AllocM m) =+runAllocM space fun handleOp hints (AllocM m) =   fmap fst $ modifyNameSource $ runState $ runReaderT (runBuilderT m mempty) env   where     env =       AllocEnv         { allocSpace = space,+          funSpace = fun,           envConsts = mempty,           allocInOp = handleOp,           envExpHints = hints@@ -210,10 +221,11 @@   (Allocable fromrep torep inner) =>   [Ident] ->   StmAux a ->-  Exp torep ->+  Exp fromrep ->   AllocM fromrep torep (Stm torep)-allocsForStm idents aux e = do+allocsForStm idents aux e0 = do   def_space <- askDefaultSpace+  e <- allocInExp e0   hints <- expHints e   (rts, e') <- expReturns' e   pes <- allocsForPat def_space idents rts hints@@ -259,19 +271,19 @@         pure $ PatElem (identName ident) summary       MemMem space ->         pure $ PatElem (identName ident) $ MemMem space-      MemArray bt _ u (Just (ReturnsInBlock mem extlmad)) -> do+      MemArray bt _ o (Just (ReturnsInBlock mem extlmad)) -> do         let ixfn = instantiateExtLMAD idents extlmad-        pure . PatElem (identName ident) . MemArray bt ident_shape u $ ArrayIn mem ixfn+        pure . PatElem (identName ident) . MemArray bt ident_shape o $ ArrayIn mem ixfn       MemArray _ extshape _ Nothing         | Just _ <- knownShape extshape -> do             summary <- summaryForBindage def_space (identType ident) hint             pure $ PatElem (identName ident) summary-      MemArray bt _ u (Just (ReturnsNewBlock _ i extixfn)) -> do+      MemArray bt _ o (Just (ReturnsNewBlock _ i extixfn)) -> do         let ixfn = instantiateExtLMAD idents extixfn-        pure . PatElem (identName ident) . MemArray bt ident_shape u $+        pure . PatElem (identName ident) . MemArray bt ident_shape o $           ArrayIn (getIdent idents i) ixfn-      MemAcc acc ispace ts u ->-        pure $ PatElem (identName ident) $ MemAcc acc ispace ts u+      MemAcc acc ispace ts ->+        pure $ PatElem (identName ident) $ MemAcc acc ispace ts       _ -> error "Impossible case reached in allocsForPat!"   where     knownShape = mapM known . shapeDims@@ -300,22 +312,22 @@   Space ->   Type ->   ExpHint ->-  m (MemBound NoUniqueness)+  m (MemBound NoMode) summaryForBindage _ (Prim bt) _ =   pure $ MemPrim bt summaryForBindage _ (Mem space) _ =   pure $ MemMem space-summaryForBindage _ (Acc acc ispace ts u) _ =-  pure $ MemAcc acc ispace ts u-summaryForBindage def_space t@(Array pt shape u) NoHint = do+summaryForBindage _ (Acc acc ispace ts) _ =+  pure $ MemAcc acc ispace ts+summaryForBindage def_space t@(Array pt shape o) NoHint = do   m <- allocForArray' t def_space-  pure $ MemArray pt shape u $ ArrayIn m $ LMAD.iota 0 $ map pe64 $ arrayDims t+  pure $ MemArray pt shape o $ ArrayIn m $ LMAD.iota 0 $ map pe64 $ arrayDims t summaryForBindage _ t@(Array pt _ _) (Hint lmad space) = do   bytes <-     letSubExp "bytes" <=< toExp . untyped $       primByteSize pt * (1 + LMAD.range lmad)   m <- letExp "mem" $ Op $ Alloc bytes space-  pure $ MemArray pt (arrayShape t) NoUniqueness $ ArrayIn m lmad+  pure $ MemArray pt (arrayShape t) NoMode $ ArrayIn m lmad  allocInFParams ::   (Allocable fromrep torep inner) =>@@ -339,18 +351,18 @@     (FParam torep) allocInFParam param pspace =   case paramDeclType param of-    Array pt shape u -> do+    Array pt shape o -> do       let memname = baseName (paramName param) <> "_mem"           lmad = LMAD.iota 0 $ map pe64 $ shapeDims shape       mem <- lift $ newVName memname       tell ([Param (paramAttrs param) mem $ MemMem pspace], [])-      pure param {paramDec = MemArray pt shape u $ ArrayIn mem lmad}+      pure param {paramDec = MemArray pt shape o $ ArrayIn mem lmad}     Prim pt ->       pure param {paramDec = MemPrim pt}     Mem space ->       pure param {paramDec = MemMem space}-    Acc acc ispace ts u ->-      pure param {paramDec = MemAcc acc ispace ts u}+    Acc acc ispace ts ->+      pure param {paramDec = MemAcc acc ispace ts}  ensureRowMajorArray ::   (Allocable fromrep torep inner) =>@@ -431,7 +443,7 @@           SubExp -> WriterT ([SubExp], [SubExp]) (AllocM fromrep torep) SubExp         )     allocInLoopParam (mergeparam, Var v)-      | param_t@(Array pt shape u) <- paramDeclType mergeparam = do+      | param_t@(Array pt shape o) <- paramDeclType mergeparam = do           (v_mem, v_lmad) <- lift $ lookupArraySummary v           v_mem_space <- lift $ lookupMemSpace v_mem @@ -452,7 +464,7 @@                   tell ([p], [])                    pure-                    ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn (paramName p) v_lmad},+                    ( mergeparam {paramDec = MemArray pt shape o $ ArrayIn (paramName p) v_lmad},                       Var v,                       scalarRes param_t v_mem_space v_lmad                     )@@ -478,7 +490,7 @@               mem_param <- newParam "mem_param" $ MemMem v_mem_space'               tell ([mem_param], ctx_params)               pure-                ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn (paramName mem_param) param_lmad},+                ( mergeparam {paramDec = MemArray pt shape o $ ArrayIn (paramName mem_param) param_lmad},                   Var v',                   ensureArrayIn v_mem_space'                 )@@ -496,10 +508,10 @@   VName ->   m (VName, VName) arrayWithLMAD space lmad v_t v = do-  let Array pt shape u = v_t+  let Array pt shape o = v_t   mem <- allocForArray' v_t space   v_copy <- newVName $ baseName v <> "_scalcopy"-  let pe = PatElem v_copy $ MemArray pt shape u $ ArrayIn mem lmad+  let pe = PatElem v_copy $ MemArray pt shape o $ ArrayIn mem lmad   letBind (Pat [pe]) $ BasicOp $ Replicate mempty $ Var v   pure (mem, v_copy) @@ -538,11 +550,11 @@ allocPermArray space perm s v = do   t <- lookupType v   case t of-    Array pt shape u -> do+    Array pt shape o -> do       mem <- allocForArray t space       v' <- newVName $ s <> "_desired_form"       let info =-            MemArray pt shape u . ArrayIn mem $+            MemArray pt shape o . ArrayIn mem $               LMAD.permute (LMAD.iota 0 $ map pe64 $ arrayDims t) perm           pat = Pat [PatElem v' info]       addStm $ Let pat (defAux ()) $ BasicOp $ Manifest v perm@@ -577,13 +589,13 @@  funcallArgs ::   (Allocable fromrep torep inner) =>+  Space ->   [(SubExp, Diet)] ->   AllocM fromrep torep [(SubExp, Diet)]-funcallArgs args = do+funcallArgs space args = do   (valargs, (ctx_args, mem_and_size_args)) <- runWriterT $     forM args $ \(arg, d) -> do       t <- lift $ subExpType arg-      space <- lift askDefaultSpace       arg' <- linearFuncallArg t space arg       pure (arg', d)   pure $ map (,Observe) (ctx_args <> mem_and_size_args) <> valargs@@ -611,18 +623,26 @@   (Op fromrep -> AllocM fromrep torep (Op torep)) ->   (Exp torep -> AllocM fromrep torep [ExpHint]) ->   Pass fromrep torep-explicitAllocationsGeneric space handleOp hints =-  Pass "explicit allocations" "Transform program to explicit memory representation" $-    intraproceduralTransformationWithConsts onStms allocInFun+explicitAllocationsGeneric def_space handleOp hints =+  Pass "explicit allocations" "Transform program to explicit memory representation" $ \prog ->+    let spaceForfun :: Name -> Space+        spaceForfun =+          let f fd+                | "cpu_function" `inAttrs` funDefAttrs fd = Just (funDefName fd, DefaultSpace)+                | otherwise = Nothing+              table = M.fromList $ mapMaybe f $ progFuns prog+           in \fname -> fromMaybe def_space $ M.lookup fname table+     in intraproceduralTransformationWithConsts onStms (allocInFun spaceForfun) prog   where     onStms stms =-      runAllocM space handleOp hints $ collectStms_ $ allocInStms stms $ pure ()+      runAllocM def_space (const def_space) handleOp hints $ collectStms_ $ allocInStms stms $ pure () -    allocInFun consts (FunDef entry attrs fname rettype params fbody) =-      runAllocM space handleOp hints . inScopeOf consts $+    allocInFun spaceForFun consts (FunDef entry attrs fname rettype params fbody) = do+      let space = spaceForFun fname+      runAllocM space spaceForFun handleOp hints . inScopeOf consts $         allocInFParams (map (,space) params) $ \params' -> do           (fbody', mem_rets) <--            allocInFunBody (map (const $ Just space) rettype) fbody+            allocInFunBody (map (const $ Just def_space) rettype) fbody           let num_extra_params = length params' - length params               num_extra_rets = length mem_rets               -- The mem_pals is an over-approximation, like in the case for Apply.@@ -631,7 +651,7 @@               rettype' =                 map (,mem_als) mem_rets                   ++ zip-                    (memoryInDeclExtType space (length mem_rets) (map fst rettype))+                    (memoryInRetType def_space (length mem_rets) (map fst rettype))                     (map (shiftRetAls num_extra_params num_extra_rets . snd) rettype)           pure $ FunDef entry attrs fname rettype' params' fbody' @@ -647,23 +667,24 @@   m (Stms torep) explicitAllocationsInStmsGeneric space handleOp hints stms = do   scope <- askScope-  runAllocM space handleOp hints $+  -- XXX: it is not good that we do not have access to function tables here.+  runAllocM space (const space) handleOp hints $     localScope scope $       collectStms_ $         allocInStms stms $           pure () -memoryInDeclExtType :: Space -> Int -> [DeclExtType] -> [FunReturns]-memoryInDeclExtType space k dets = evalState (mapM addMem dets) 0+memoryInRetType :: Space -> Int -> [ExtType] -> [FunReturns]+memoryInRetType space k dets = evalState (mapM addMem dets) 0   where     addMem (Prim t) = pure $ MemPrim t-    addMem Mem {} = error "memoryInDeclExtType: too much memory"-    addMem (Array pt shape u) = do+    addMem Mem {} = error "memoryInRetType: too much memory"+    addMem (Array pt shape o) = do       i <- get <* modify (+ 1)       let shape' = fmap shift shape-      pure . MemArray pt shape' u . ReturnsNewBlock space i $+      pure . MemArray pt shape' o . ReturnsNewBlock space i $         LMAD.iota 0 (map convert $ shapeDims shape')-    addMem (Acc acc ispace ts u) = pure $ MemAcc acc ispace ts u+    addMem (Acc acc ispace ts) = pure $ MemAcc acc ispace ts      convert (Ext i) = le64 $ Ext i     convert (Free v) = Free <$> pe64 v@@ -674,7 +695,7 @@ bodyReturnMemCtx ::   (Allocable fromrep torep inner) =>   SubExpRes ->-  AllocM fromrep torep [(SubExpRes, MemInfo ExtSize u MemReturn)]+  AllocM fromrep torep [(SubExpRes, MemInfo ExtSize o MemReturn)] bodyReturnMemCtx (SubExpRes _ Constant {}) =   pure [] bodyReturnMemCtx (SubExpRes _ (Var v)) = do@@ -738,7 +759,7 @@   Stm fromrep ->   AllocM fromrep torep () allocInStm (Let (Pat pes) aux e) =-  addStm =<< allocsForStm (map patElemIdent pes) aux =<< allocInExp e+  addStm =<< allocsForStm (map patElemIdent pes) aux e  allocInLambda ::   (Allocable fromrep torep inner) =>@@ -753,20 +774,32 @@   | NeedsNormalisation Space   deriving (Eq, Show) -combMemReqs :: MemReq -> MemReq -> MemReq-combMemReqs x@NeedsNormalisation {} _ = x-combMemReqs _ y@NeedsNormalisation {} = y-combMemReqs x@(MemReq x_space) y@MemReq {} =-  if x == y then x else NeedsNormalisation x_space+-- | Unify the memory requirements of two branches of a 'Match'.  The first+-- argument is the default space, used when the branches disagree and we+-- cannot normalise to either of them.+combMemReqs :: Space -> MemReq -> MemReq -> MemReq+combMemReqs _ x@NeedsNormalisation {} _ = x+combMemReqs _ _ y@NeedsNormalisation {} = y+combMemReqs def_space (MemReq x_space) (MemReq y_space)+  | x_space == y_space = MemReq x_space+  -- A 'ScalarSpace' states the size of the array as part of the space, so+  -- normalising to the space of one branch would give the other branch an+  -- array of the wrong size.  Normalise to the default space instead.+  | isScalarSpace x_space || isScalarSpace y_space = NeedsNormalisation def_space+  | otherwise = NeedsNormalisation x_space -type MemReqType = MemInfo (Ext SubExp) NoUniqueness MemReq+isScalarSpace :: Space -> Bool+isScalarSpace ScalarSpace {} = True+isScalarSpace _ = False -combMemReqTypes :: MemReqType -> MemReqType -> MemReqType-combMemReqTypes (MemArray pt shape u x) (MemArray _ _ _ y) =-  MemArray pt shape u $ combMemReqs x y-combMemReqTypes x _ = x+type MemReqType = MemInfo (Ext SubExp) NoMode MemReq -contextRets :: MemReqType -> [MemInfo d u r]+combMemReqTypes :: Space -> MemReqType -> MemReqType -> MemReqType+combMemReqTypes def_space (MemArray pt shape o x) (MemArray _ _ _ y) =+  MemArray pt shape o $ combMemReqs def_space x y+combMemReqTypes _ x _ = x++contextRets :: MemReqType -> [MemInfo d o r] contextRets (MemArray _ shape _ (MemReq space)) =   -- Memory + offset + stride*rank.   [MemMem space, MemPrim int64]@@ -794,12 +827,12 @@     restriction t se = do       v_info <- subExpMemInfo se       case (t, v_info) of-        (Array pt shape u, MemArray _ _ _ (ArrayIn mem _)) -> do+        (Array pt shape o, MemArray _ _ _ (ArrayIn mem _)) -> do           space <- lookupMemSpace mem-          pure $ MemArray pt shape u $ MemReq space+          pure $ MemArray pt shape o $ MemReq space         (_, MemMem space) -> pure $ MemMem space         (_, MemPrim pt) -> pure $ MemPrim pt-        (_, MemAcc acc ispace ts u) -> pure $ MemAcc acc ispace ts u+        (_, MemAcc acc ispace ts) -> pure $ MemAcc acc ispace ts         _ -> error $ "allocInMatchBody: mismatch: " ++ show (t, v_info)  mkBranchRet :: [MemReqType] -> [BranchTypeMem]@@ -822,13 +855,13 @@     arrayInfo (MemReq space) =       space -    inspect ctx_offset (MemArray pt shape u req) =+    inspect ctx_offset (MemArray pt shape o req) =       let shape' = fmap (adjustExt num_new_ctx) shape           space = arrayInfo req-       in MemArray pt shape' u . ReturnsNewBlock space ctx_offset $+       in MemArray pt shape' o . ReturnsNewBlock space ctx_offset $             convert               <$> LMAD.mkExistential (shapeDims shape') (ctx_offset + 1)-    inspect _ (MemAcc acc ispace ts u) = MemAcc acc ispace ts u+    inspect _ (MemAcc acc ispace ts) = MemAcc acc ispace ts     inspect _ (MemPrim pt) = MemPrim pt     inspect _ (MemMem space) = MemMem space @@ -930,27 +963,29 @@           pure $ subExpsRes valctx <> zipWith SubExpRes (map resCerts bodyres) valres'       pure $ Loop merge' form body' allocInExp (Apply fname args rettype loc) = do-  args' <- funcallArgs args-  space <- askDefaultSpace+  arg_space <- askFunSpace fname+  res_space <- askDefaultSpace+  args' <- funcallArgs arg_space args   args_ts <- mapM (subExpType . fst) args'   -- We assume that every array is going to be in its own memory. Further, we   -- assume that every result memory block can alias any argument memory block.   -- This is an overapproximation that can be loosened in the future.   let mem_als = RetAls (map fst $ filter (isMem . snd) $ zip [0 ..] args_ts) mempty-      mems = replicate num_arrays (MemMem space, mem_als)+      mems = replicate num_arrays (MemMem res_space, mem_als)       num_extra_args = length args' - length args       rettype' =         mems           ++ zip-            (memoryInDeclExtType space num_arrays (map fst rettype))+            (memoryInRetType res_space num_arrays (map fst rettype))             (map (shiftRetAls num_extra_args num_arrays . snd) rettype)   pure $ Apply fname args' rettype' loc   where-    num_arrays = length $ filter ((> 0) . arrayRank . declExtTypeOf . fst) rettype+    num_arrays = length $ filter ((> 0) . arrayRank . extTypeOf . fst) rettype allocInExp (Match ses cases defbody (MatchDec rets ifsort)) = do   (defbody', def_reqs) <- allocInMatchBody rets defbody   (cases', cases_reqs) <- mapAndUnzipM onCase cases-  let reqs = zipWith (foldl combMemReqTypes) def_reqs (transpose cases_reqs)+  def_space <- askDefaultSpace+  let reqs = zipWith (foldl (combMemReqTypes def_space)) def_reqs (transpose cases_reqs)   defbody'' <- addCtxToMatchBody reqs defbody'   cases'' <- mapM (traverse $ addCtxToMatchBody reqs) cases'   let (cases''', defbody''', rets') =@@ -965,7 +1000,7 @@       params <- forM (lambdaParams lam) $ \(Param attrs pv t) ->         case t of           Prim Unit -> pure $ Param attrs pv $ MemPrim Unit-          Acc acc ispace ts u -> pure $ Param attrs pv $ MemAcc acc ispace ts u+          Acc acc ispace ts -> pure $ Param attrs pv $ MemAcc acc ispace ts           _ -> error $ "Unexpected WithAcc lambda param: " ++ prettyString (Param attrs pv t)       allocInLambda params (lambdaBody lam) @@ -987,29 +1022,29 @@           (lambdaBody lam)       pure (lam', nes) -    mkP attrs p pt shape u mem lmad is =-      Param attrs p . MemArray pt shape u . ArrayIn mem . LMAD.slice lmad $+    mkP attrs p pt shape o mem lmad is =+      Param attrs p . MemArray pt shape o . ArrayIn mem . LMAD.slice lmad $         fmap pe64 $           Slice $             is ++ map sliceDim (shapeDims shape)      onXParam _ (Param attrs p (Prim t)) _ =       pure $ Param attrs p (MemPrim t)-    onXParam is (Param attrs p (Array pt shape u)) arr = do+    onXParam is (Param attrs p (Array pt shape o)) arr = do       (mem, lmad) <- lookupArraySummary arr-      pure $ mkP attrs p pt shape u mem lmad is+      pure $ mkP attrs p pt shape o mem lmad is     onXParam _ p _ =       error $ "Cannot handle MkAcc param: " ++ prettyString p      onYParam _ (Param attrs p (Prim t)) _ =       pure $ Param attrs p $ MemPrim t-    onYParam is (Param attrs p (Array pt shape u)) arr = do+    onYParam is (Param attrs p (Array pt shape o)) arr = do       arr_t <- lookupType arr       space <- askDefaultSpace       mem <- allocForArray arr_t space       let base_dims = map pe64 $ arrayDims arr_t           lmad = LMAD.iota 0 base_dims-      pure $ mkP attrs p pt shape u mem lmad is+      pure $ mkP attrs p pt shape o mem lmad is     onYParam _ p _ =       error $ "Cannot handle MkAcc param: " ++ prettyString p allocInExp e = mapExpM alloc e@@ -1150,6 +1185,38 @@ defaultExpHints :: (ASTRep rep, HasScope rep m) => Exp rep -> m [ExpHint] defaultExpHints e = map (const NoHint) <$> expExtType e +-- | Arrays of at most this many bytes are put in 'ScalarSpace'. The point is to+-- reach values that the C compiler can keep in registers or at least on the+-- stack, so this is deliberately small.+maxScalarSpaceBytes :: Int64+maxScalarSpaceBytes = 1024++-- | Put small arrays of statically known size in 'ScalarSpace', which the CPU+-- backends turn into ordinary C arrays of scalars rather than heap allocations.+-- This matters most for arrays carried by a loop, where the alternative is an+-- allocation (and a reference count update) per iteration. Only for+-- representations where the default space is the one the host can address+-- directly; a GPU array must stay in device memory.+scalarSpaceExpHints ::+  (Allocable fromrep torep inner) =>+  Exp torep ->+  AllocM fromrep torep [ExpHint]+scalarSpaceExpHints e = map hint <$> expExtType e+  where+    hint t+      | Just (Array pt shape _) <- hasStaticShape t,+        Just ns <- mapM knownDim $ shapeDims shape,+        let bytes = product ns * primByteSize pt,+        -- An empty array, or one of 'Unit' elements, cannot be stored.+        bytes > 0,+        bytes <= maxScalarSpaceBytes =+          Hint (LMAD.iota 0 $ map pe64 $ shapeDims shape) $+            ScalarSpace (shapeDims shape) pt+      | otherwise = NoHint++    knownDim (Constant (IntValue v)) = Just $ valueIntegral v+    knownDim _ = Nothing+ -- I have no Idea if this is correct allocInLParams ::   (Allocable fromrep torep inner) =>@@ -1161,7 +1228,7 @@   where     alloc x =       case paramType x of-        Array pt shape u -> do+        Array pt shape o -> do           let t = paramType x `arrayOfRow` num_threads           mem <- allocForArray t =<< askDefaultSpace           let base_dims = map pe64 $ arrayDims t@@ -1169,8 +1236,8 @@               lmad_x =                 LMAD.slice lmad_base $                   fullSliceNum base_dims [DimFix idxs]-          pure $ x {paramDec = MemArray pt shape u $ ArrayIn mem lmad_x}+          pure $ x {paramDec = MemArray pt shape o $ ArrayIn mem lmad_x}         Prim bt -> pure $ x {paramDec = MemPrim bt}         Mem space -> pure $ x {paramDec = MemMem space}         -- This next case will never happen.-        Acc acc ispace ts u -> pure $ x {paramDec = MemAcc acc ispace ts u}+        Acc acc ispace ts -> pure $ x {paramDec = MemAcc acc ispace ts}
src/Futhark/Pass/ExplicitAllocations/MC.hs view
@@ -35,4 +35,4 @@  -- | The pass from 'MC' to 'MCMem'. explicitAllocations :: Pass MC MCMem-explicitAllocations = explicitAllocationsGeneric DefaultSpace handleMCOp defaultExpHints+explicitAllocations = explicitAllocationsGeneric DefaultSpace handleMCOp scalarSpaceExpHints
src/Futhark/Pass/ExplicitAllocations/SegOp.hs view
@@ -34,7 +34,7 @@   where     alloc x y =       case paramType x of-        Array pt shape u -> do+        Array pt shape o -> do           let name = maybe "num_threads" baseName (subExpVar num_threads)           twice_num_threads <-             letSubExp ("twice_" <> name) . BasicOp $@@ -52,8 +52,8 @@                 LMAD.slice lmad_base $                   fullSliceNum base_dims [DimFix other_id]           pure-            ( x {paramDec = MemArray pt shape u $ ArrayIn mem lmad_x},-              y {paramDec = MemArray pt shape u $ ArrayIn mem lmad_y}+            ( x {paramDec = MemArray pt shape o $ ArrayIn mem lmad_x},+              y {paramDec = MemArray pt shape o $ ArrayIn mem lmad_y}             )         Prim bt ->           pure@@ -66,10 +66,10 @@               y {paramDec = MemMem space}             )         -- This next case will never happen.-        Acc acc ispace ts u ->+        Acc acc ispace ts ->           pure-            ( x {paramDec = MemAcc acc ispace ts u},-              y {paramDec = MemAcc acc ispace ts u}+            ( x {paramDec = MemAcc acc ispace ts},+              y {paramDec = MemAcc acc ispace ts}             )  allocInBinOpLambda ::
src/Futhark/Pass/ExplicitAllocations/Seq.hs view
@@ -14,4 +14,4 @@   explicitAllocationsGeneric     DefaultSpace     (const $ pure $ Inner NoOp)-    defaultExpHints+    scalarSpaceExpHints
src/Futhark/Pass/Flatten.hs view
@@ -96,15 +96,21 @@       SequentialiseIrregularAll   | otherwise = irreg -flattenOpsFor :: FunHasParallelism -> FunSizeParams -> DistIrregularity -> SegLevel -> FlattenOps-flattenOpsFor funHasParallelism funSizeParams irreg lvl =+flattenOpsFor ::+  Attrs ->+  FunHasParallelism ->+  FunSizeParams ->+  DistIrregularity ->+  SegLevel ->   FlattenOps+flattenOpsFor attrs funHasParallelism funSizeParams irreg lvl =+  FlattenOps     { flattenSegLevel = lvl,       flattenIrregularity = irreg,       flattenFunHasParallelism = funHasParallelism,       flattenDistStmWith = transformDistStm funSizeParams,       flattenScalarStmAt = transformScalarStm,-      flattenTopLevelStm = transformStm funHasParallelism funSizeParams+      flattenTopLevelStm = transformTopLevelStm attrs funHasParallelism funSizeParams     }  transformScalarStms ::@@ -141,6 +147,7 @@ -- segments, the mapped arrays are plain regular top-level values -- ('DistInputFree'), and the results are necessarily regular. transformTopLevelScrema ::+  Attrs ->   FunHasParallelism ->   FunSizeParams ->   Pat Type ->@@ -149,9 +156,9 @@   [VName] ->   ScremaForm SOACS ->   FlattenM ()-transformTopLevelScrema funHasParallelism funSizeParams pat aux w arrs form = do+transformTopLevelScrema attrs funHasParallelism funSizeParams pat aux w arrs form = do   let irreg = irregularityFor DistributeIrregular aux-      ops = flattenOpsFor funHasParallelism funSizeParams irreg defaultSegLevel+      ops = flattenOpsFor attrs funHasParallelism funSizeParams irreg defaultSegLevel   arr_ts <- mapM lookupType arrs   -- 'flattenScrema' may bind the names of the pattern it is given (some paths   -- bind them directly, others only insert reps), so we pass it a fresh pattern@@ -202,22 +209,22 @@ -- return type. -- -- A lifted function corresponds to 'map f', which always produces fresh arrays.--- We therefore mark all array components of the return type as 'Unique', such--- that the results are known to not alias anything (in particular not the--- arguments). Maintaining this invariant may require inserting copies in the--- function body; see 'freshenResult'.+-- No result therefore aliases anything - neither an argument nor another+-- result - which is recorded by giving each an empty 'RetAls'; see 'noRetAls'.+-- Maintaining this invariant may require inserting copies in the function body;+-- see 'freshenResult'. liftRetType :: SubExp -> [RetType SOACS] -> [RetType GPU] liftRetType w = concat . snd . L.mapAccumL liftType 0   where     liftType i rettype =       let lifted = case rettype of-            Prim pt -> pure $ arrayOf (Prim pt) (Shape [Free w]) Unique+            Prim pt -> pure $ arrayOf (Prim pt) (Shape [Free w]) NoMode             Array pt _ _ ->               let num_data = Prim int64-                  segs = arrayOf (Prim int64) (Shape [Free w]) Unique-                  flags = arrayOf (Prim Bool) (Shape [Ext i]) Unique-                  offsets = arrayOf (Prim int64) (Shape [Free w]) Unique-                  elems = arrayOf (Prim pt) (Shape [Ext i]) Unique+                  segs = arrayOf (Prim int64) (Shape [Free w]) NoMode+                  flags = arrayOf (Prim Bool) (Shape [Ext i]) NoMode+                  offsets = arrayOf (Prim int64) (Shape [Free w]) NoMode+                  elems = arrayOf (Prim pt) (Shape [Ext i]) NoMode                in [num_data, segs, flags, offsets, elems]             Acc {} -> error "liftRetType: Acc"             Mem {} -> error "liftRetType: Mem"@@ -228,18 +235,18 @@   where     liftType i rettype =       let lifted = case rettype of-            Prim pt -> pure $ arrayOf (Prim pt) (Shape [Free w]) Unique+            Prim pt -> pure $ arrayOf (Prim pt) (Shape [Free w]) NoMode             Array pt shape _ ->               if needsIrregularRetType inps rettype                 then                   let num_data = Prim int64-                      segs = arrayOf (Prim int64) (Shape [Free w]) Unique-                      flags = arrayOf (Prim Bool) (Shape [Ext i]) Unique-                      offsets = arrayOf (Prim int64) (Shape [Free w]) Unique-                      elems = arrayOf (Prim pt) (Shape [Ext i]) Unique+                      segs = arrayOf (Prim int64) (Shape [Free w]) NoMode+                      flags = arrayOf (Prim Bool) (Shape [Ext i]) NoMode+                      offsets = arrayOf (Prim int64) (Shape [Free w]) NoMode+                      elems = arrayOf (Prim pt) (Shape [Ext i]) NoMode                    in [num_data, segs, flags, offsets, elems]                 else-                  pure $ arrayOf (Prim pt) (Shape [Free w] <> shape) Unique+                  pure $ arrayOf (Prim pt) (Shape [Free w] <> shape) NoMode             Acc {} -> error "liftRetType: Acc"             Mem {} -> error "liftRetType: Mem"        in (i + length lifted, lifted)@@ -282,14 +289,10 @@             -- We do not lift 'size_args' because they correspond to size             -- parameters, which are invariant in the uniform case.             pure $ (w, Observe) : map snd size_args <> value_args'-      args_ts <- mapM (subExpType . fst) args'-      let dietToUnique Consume = Unique-          dietToUnique Observe = Nonunique-          param_ts = zipWith toDecl args_ts $ map (dietToUnique . snd) args'-          rettype' =+      let rettype' =             if nonuniform-              then addRetAls param_ts $ liftRetType w $ map fst rettype-              else addRetAls param_ts $ liftRegularRetType inps w $ map fst rettype+              then noRetAls $ liftRetType w $ map fst rettype+              else noRetAls $ liftRegularRetType inps w $ map fst rettype       result <- letTupExp (name' <> "_res") $ Apply name' args' rettype' s       let reps =             if nonuniform@@ -311,38 +314,38 @@ transformDistStm :: FunSizeParams -> FlattenOps -> Segments -> DistEnv -> DistStm -> FlattenM DistEnv transformDistStm _ outer_ops segments env (DistStm inps res (ScalarStm stms)) =   transformScalarStms (flattenSegLevel outer_ops) segments env inps res stms-transformDistStm funSizeParams outer_ops segments env (DistStm inps res (ParallelStm stm)) = do-  case stm of-    Let pat aux (BasicOp e) -> do+transformDistStm funSizeParams outer_ops segments env (DistStm inps res (ParallelStm (Let pat aux e))) = do+  case e of+    BasicOp op -> do       let ~[res'] = res           ~[pe] = patElems pat-      flattenBasicOp ops segments env (inps, res', pe, aux, e)-    Let pat aux (Op (Screma w arrs form)) ->+      flattenBasicOp ops segments env (inps, res', pe, aux, op)+    Op (Screma w arrs form) ->       flattenScrema ops segments env inps res (pat, aux) (w, arrs, form)-    Let _ aux (Match scrutinees cases defaultCase rt) ->+    Match scrutinees cases defaultCase rt ->       flattenMatch ops segments env inps res aux scrutinees cases defaultCase rt-    Let pat aux (Apply name args rettype s) ->+    Apply name args rettype s ->       flattenApply funSizeParams lvl segments env inps res (pat, aux) (name, args, rettype, s)-    Let pat aux (Loop merge (ForLoop i it n) body) ->+    Loop merge (ForLoop i it n) body ->       flattenLoop ops segments env inps res (pat, aux) (merge, ForLoop i it n, body)-    Let pat aux (Loop merge (WhileLoop cond) body) -> do+    Loop merge (WhileLoop cond) body -> do       flattenLoop ops segments env inps res (pat, aux) (merge, WhileLoop cond, body)-    Let pat aux (WithAcc inputs lam) ->+    WithAcc inputs lam ->       flattenWithAcc ops segments env inps res pat aux inputs lam-    (Let pat aux (Op (Hist w hist_inputs hist_ops bucket_fun))) ->+    Op (Hist w hist_inputs hist_ops bucket_fun) ->       flattenHist ops segments env inps res (pat, aux) (w, hist_inputs, hist_ops, bucket_fun)-    Let _ aux (Op (FlatMap w arrs lam)) ->+    Op (FlatMap w arrs lam) ->       flattenFlatMapNested ops segments env inps res aux w arrs lam-    Let _ _ (Op (Stream {})) -> error "transformDistStm: Stream should have been removed"-    Let _ _ (Op (JVP {})) -> error "Unhandled JVP"-    Let _ _ (Op (VJP {})) -> error "Unhandled VJP"-    Let _ _ (Op (WithVJP {})) -> error "Unhandled WithVJP"+    Op (Stream {}) -> error "transformDistStm: Stream should have been removed"+    Op (JVP {}) -> error "Unhandled JVP"+    Op (VJP {}) -> error "Unhandled VJP"+    Op (WithVJP {}) -> error "Unhandled WithVJP"   where     lvl = flattenSegLevel outer_ops     ops =       outer_ops         { flattenIrregularity =-            irregularityFor (flattenIrregularity outer_ops) (stmAux stm)+            irregularityFor (flattenIrregularity outer_ops) aux         }  reshapeLiftedApplyResult :: Segments -> RetType SOACS -> ResRep -> FlattenM ResRep@@ -360,18 +363,18 @@ reshapeLiftedApplyResult _ _ rep =   pure rep -liftBody :: FunHasParallelism -> FunSizeParams -> SegLevel -> SubExp -> DistInputs -> DistEnv -> DistStms -> Result -> FlattenM Result-liftBody funHasParallelism funSizeParams lvl w inputs env dstms result = do+liftBody :: Attrs -> FunHasParallelism -> FunSizeParams -> SegLevel -> SubExp -> DistInputs -> DistEnv -> DistStms -> Result -> FlattenM Result+liftBody attrs funHasParallelism funSizeParams lvl w inputs env dstms result = do   let segments = [w]-      ops = flattenOpsFor funHasParallelism funSizeParams DistributeIrregular lvl+      ops = flattenOpsFor attrs funHasParallelism funSizeParams DistributeIrregular lvl   env' <- foldM (flattenDistStm ops segments) env dstms   result' <- mapM (liftResult lvl segments inputs env') result   pure $ concat result' -liftUniformFunBody :: FunHasParallelism -> FunSizeParams -> SegLevel -> SubExp -> DistInputs -> DistEnv -> DistStms -> [RetType SOACS] -> Result -> FlattenM Result-liftUniformFunBody funHasParallelism funSizeParams lvl w inputs env dstms rettype result = do+liftUniformFunBody :: Attrs -> FunHasParallelism -> FunSizeParams -> SegLevel -> SubExp -> DistInputs -> DistEnv -> DistStms -> [RetType SOACS] -> Result -> FlattenM Result+liftUniformFunBody attrs funHasParallelism funSizeParams lvl w inputs env dstms rettype result = do   let segments = [w]-      ops = flattenOpsFor funHasParallelism funSizeParams DistributeIrregular lvl+      ops = flattenOpsFor attrs funHasParallelism funSizeParams DistributeIrregular lvl   env' <- foldM (flattenDistStm ops segments) env dstms   concat <$> zipWithM (liftRegResult lvl segments w inputs env') rettype result @@ -436,26 +439,25 @@           size_params = filter (isSizeParam . snd) indexed_params        in (funDefName fd, S.fromList $ map fst size_params) -addRetAls :: [DeclType] -> [RetType GPU] -> [(RetType GPU, RetAls)]-addRetAls params rettype = zip rettype $ map possibleAliases rettype-  where-    aliasable (Array _ _ Nonunique) = True-    aliasable _ = False-    aliasable_params =-      map snd $ filter (aliasable . fst) $ zip params [0 ..]-    aliasable_rets =-      map snd $ filter (aliasable . declExtTypeOf . fst) $ zip rettype [0 ..]-    possibleAliases t-      | aliasable t = RetAls aliasable_params aliasable_rets-      | otherwise = mempty+-- | Every result of a lifted function is fresh (see 'liftRetType'), so+-- none of them alias a parameter or each other.+noRetAls :: [RetType GPU] -> [(RetType GPU, RetAls)]+noRetAls = map (,mempty) +-- | Impose attributes on the statements of a function body. This is used to+-- impose attributes on top level statements in lifted functions.+imposeAttrsBody :: Attrs -> Body SOACS -> Body SOACS+imposeAttrsBody attrs body =+  body {bodyStms = fmap (imposeAttrs attrs) (bodyStms body)}+ liftFunDef ::+  Attrs ->   FunHasParallelism ->   FunSizeParams ->   Scope SOACS ->   FunDef SOACS ->   PassM (FunDef GPU, S.Set DemandFn)-liftFunDef funHasParallelism funSizeParams const_scope fd = do+liftFunDef attrs funHasParallelism funSizeParams const_scope fd = do   let FunDef         { funDefBody = body,           funDefParams = fparams,@@ -469,17 +471,18 @@         (p, i) <- zip fparams [0 ..]         pure (paramName p, DistInput (ResTag i) (paramType p))   let rettype' =-        addRetAls (map paramDeclType fparams'') $+        noRetAls $           liftRetType w (map fst rettype)   let (inputs', dstms) =-        distributeBody DistributeIrregular funHasParallelism const_scope [Var (paramName wp)] inputs body+        distributeBody DistributeIrregular funHasParallelism const_scope [Var (paramName wp)] inputs $+          imposeAttrsBody attrs body       env = DistEnv $ M.fromList $ zip (map ResTag [0 ..]) reps   -- Lift the body of the function and get the results, inserting copies as-  -- necessary to ensure the results are fresh and unique (see 'freshenResult').+  -- necessary to ensure the results are fresh (see 'freshenResult').   (body', needs) <-     runFlattenM (castScope const_scope <> scopeOfFParams fparams'') $       buildBody_ . freshenResult fparams'' $-        liftBody funHasParallelism funSizeParams defaultSegLevel w inputs' env dstms $+        liftBody attrs funHasParallelism funSizeParams defaultSegLevel w inputs' env dstms $           bodyResult body   let name = liftFunName $ funDefName fd   pure@@ -487,7 +490,10 @@         { funDefName = name,           funDefBody = body',           funDefParams = fparams'',-          funDefRetType = rettype'+          funDefRetType = rettype',+          -- We have to remove #[cpu_function] if present because this function+          -- really contains parallel code now.+          funDefAttrs = funDefAttrs fd `withoutAttrs` oneAttr "cpu_function"         },       needs     )@@ -499,12 +505,13 @@ -- when it returns an array whose dimension size was created in the function -- body. In other words, the array has an existential size. liftUniformFunDef ::+  Attrs ->   FunHasParallelism ->   FunSizeParams ->   Scope SOACS ->   FunDef SOACS ->   PassM (FunDef GPU, S.Set DemandFn)-liftUniformFunDef funHasParallelism funSizeParams const_scope fd = do+liftUniformFunDef attrs funHasParallelism funSizeParams const_scope fd = do   let FunDef         { funDefBody = body,           funDefParams = fparams,@@ -525,13 +532,14 @@         (p, i) <- zip fparams_explicit [0 ..]         pure (paramName p, DistInput (ResTag i) (paramType p))   let (inputs', dstms) =-        distributeBody DistributeIrregular funHasParallelism (const_scope <> scopeOfFParams fparam_sizes) [Var (paramName wp)] inputs body+        distributeBody DistributeIrregular funHasParallelism (const_scope <> scopeOfFParams fparam_sizes) [Var (paramName wp)] inputs $+          imposeAttrsBody attrs body       env = DistEnv $ M.fromList $ zip (map ResTag [0 ..]) value_reps       rettype' =-        addRetAls (map paramDeclType fparams'') $+        noRetAls $           liftRegularRetType inputs' w (map fst rettype)   -- Lift the body of the function and get the results, inserting copies as-  -- necessary to ensure the results are fresh and unique (see 'freshenResult').+  -- necessary to ensure the results are fresh (see 'freshenResult').   (body', needs) <-     runFlattenM (castScope const_scope <> scopeOfFParams fparams'') $       buildBody_ . freshenResult fparams'' $@@ -540,7 +548,7 @@         -- invariant to the map-nest, but at this point there is no opportunity to         -- hoist them out of the nest. -        liftUniformFunBody funHasParallelism funSizeParams defaultSegLevel w inputs' env dstms (map fst rettype) $+        liftUniformFunBody attrs funHasParallelism funSizeParams defaultSegLevel w inputs' env dstms (map fst rettype) $           bodyResult body   let name = liftUniformFunName $ funDefName fd   pure@@ -548,25 +556,28 @@         { funDefName = name,           funDefBody = body',           funDefParams = fparams'',-          funDefRetType = rettype'+          funDefRetType = rettype',+          -- We have to remove #[cpu_function] if present because this function+          -- really contains parallel code now.+          funDefAttrs = funDefAttrs fd `withoutAttrs` oneAttr "cpu_function"         },       needs     ) -transformLambda :: FunHasParallelism -> FunSizeParams -> Lambda SOACS -> FlattenM (Lambda GPU)-transformLambda funHasParallelism funSizeParams (Lambda params ret body) = do-  body' <- localScope (scopeOfLParams params) $ transformBody funHasParallelism funSizeParams body+transformLambda :: Attrs -> FunHasParallelism -> FunSizeParams -> Lambda SOACS -> FlattenM (Lambda GPU)+transformLambda attrs funHasParallelism funSizeParams (Lambda params ret body) = do+  body' <- localScope (scopeOfLParams params) $ transformBody attrs funHasParallelism funSizeParams body   pure $ Lambda params ret body' -transformStm :: FunHasParallelism -> FunSizeParams -> Stm SOACS -> FlattenM ()-transformStm funHasParallelism funSizeParams (Let pat aux (Op soac))+transformStm :: Attrs -> FunHasParallelism -> FunSizeParams -> Stm SOACS -> FlattenM ()+transformStm attrs funHasParallelism funSizeParams (Let pat aux (Op soac))   | "sequential_outer" `inAttrs` stmAuxAttrs aux = do       scope <- askScope       stms <- runBuilderT_ (FOT.transformSOAC pat soac) (castScope scope)-      transformStms funHasParallelism funSizeParams $ fmap (certify (stmAuxCerts aux)) stms-transformStm _ _ stm+      transformStms attrs funHasParallelism funSizeParams $ fmap (certify (stmAuxCerts aux)) stms+transformStm _ _ _ stm   | "sequential" `inAttrs` stmAuxAttrs (stmAux stm) = addStm $ soacsStmToGPU stm-transformStm _ _ (Let pat aux (Op (Hist w arrs ops bucket_fun))) =+transformStm _ _ _ (Let pat aux (Op (Hist w arrs ops bucket_fun))) =   certifying (stmAuxCerts aux) $ do     res <-       genUniformSegHist@@ -579,51 +590,63 @@         (const $ pure ())     forM_ (zip (patNames pat) res) $ \(v, v') ->       letBindNames [v] $ BasicOp $ SubExp $ Var v'-transformStm funHasParallelism funSizeParams (Let pat aux (Op (Screma w arrs form)))+transformStm attrs funHasParallelism funSizeParams (Let pat aux (Op (Screma w arrs form)))   | shouldDissectForm form =       error "transformStm: complex Screma survived preprocessing"   | otherwise =-      transformTopLevelScrema funHasParallelism funSizeParams pat aux w arrs form-transformStm funHasParallelism funSizeParams (Let pat aux (Op (FlatMap w arrs lam))) =+      transformTopLevelScrema attrs funHasParallelism funSizeParams pat aux w arrs form+transformStm attrs funHasParallelism funSizeParams (Let pat aux (Op (FlatMap w arrs lam))) =   certifying (stmAuxCerts aux) $ flattenFlatMap ops pat w arrs lam   where     irreg = irregularityFor DistributeIrregular aux-    ops = flattenOpsFor funHasParallelism funSizeParams irreg defaultSegLevel-transformStm funHasParallelism funSizeParams (Let pat aux (Loop params form body)) =+    ops = flattenOpsFor attrs funHasParallelism funSizeParams irreg defaultSegLevel+transformStm attrs funHasParallelism funSizeParams (Let pat aux (Loop params form body)) =   localScope (scopeOfLoopForm form <> scopeOfFParams (map fst params)) $-    addStm . Let pat aux . Loop params form =<< transformBody funHasParallelism funSizeParams body-transformStm funHasParallelism funSizeParams (Let pat aux (Match ses cases def_body ret)) =+    addStm . Let pat aux . Loop params form =<< transformBody attrs funHasParallelism funSizeParams body+transformStm attrs funHasParallelism funSizeParams (Let pat aux (Match ses cases def_body ret)) =   addStm . Let pat aux-    =<< (Match ses <$> mapM onCase cases <*> transformBody funHasParallelism funSizeParams def_body <*> pure ret)+    =<< (Match ses <$> mapM onCase cases <*> transformBody attrs funHasParallelism funSizeParams def_body <*> pure ret)   where-    onCase = traverse (transformBody funHasParallelism funSizeParams)-transformStm funHasParallelism funSizeParams (Let pat aux (WithAcc inputs withacc_lam)) = do+    onCase = traverse (transformBody attrs funHasParallelism funSizeParams)+transformStm attrs funHasParallelism funSizeParams (Let pat aux (WithAcc inputs withacc_lam)) = do   addStm . Let pat aux . WithAcc (map onInput inputs)-    =<< transformLambda funHasParallelism funSizeParams withacc_lam+    =<< transformLambda attrs funHasParallelism funSizeParams withacc_lam   where     onInput (shape, arrs, Nothing) =       (shape, arrs, Nothing)     onInput (shape, arrs, Just (lam, nes)) =       (shape, arrs, Just (soacsLambdaToGPU lam, nes))-transformStm _ _ stm = addStm $ soacsStmToGPU stm+transformStm _ _ _ stm = addStm $ soacsStmToGPU stm -transformStms :: FunHasParallelism -> FunSizeParams -> Stms SOACS -> FlattenM ()-transformStms funHasParallelism funSizeParams stms =+-- | Transform a statement that is not enclosed in any map-nest, whether it+-- occurs in a function body or was synthesised by flattening. This is where the+-- attributes imposed on the pass (see 'flattenSOACs') are put on the statement.+-- Nested statements receive them through the usual attribute propagation.+transformTopLevelStm :: Attrs -> FunHasParallelism -> FunSizeParams -> Stm SOACS -> FlattenM ()+transformTopLevelStm attrs funHasParallelism funSizeParams =+  transformStm attrs funHasParallelism funSizeParams . imposeAttrs attrs++transformStms :: Attrs -> FunHasParallelism -> FunSizeParams -> Stms SOACS -> FlattenM ()+transformStms attrs funHasParallelism funSizeParams stms =   localScope (castScope $ scopeOf stms) $-    fold <$> traverse (transformStm funHasParallelism funSizeParams) stms+    fold <$> traverse (transformTopLevelStm attrs funHasParallelism funSizeParams) stms -transformBody :: FunHasParallelism -> FunSizeParams -> Body SOACS -> FlattenM (Body GPU)-transformBody funHasParallelism funSizeParams (Body () stms res) = buildBody_ $ do-  transformStms funHasParallelism funSizeParams stms+transformBody :: Attrs -> FunHasParallelism -> FunSizeParams -> Body SOACS -> FlattenM (Body GPU)+transformBody attrs funHasParallelism funSizeParams (Body () stms res) = buildBody_ $ do+  transformStms attrs funHasParallelism funSizeParams stms   pure res  transformFunDef ::+  Attrs ->   FunHasParallelism ->   FunSizeParams ->   Scope SOACS ->   FunDef SOACS ->   PassM (FunDef GPU, S.Set DemandFn)-transformFunDef funHasParallelism funSizeParams consts_scope fd = do+transformFunDef _ _ _ consts_scope fd+  | "cpu_function" `inAttrs` funDefAttrs fd =+      (,mempty) <$> FOT.transformFunDef (castScope consts_scope) fd+transformFunDef attrs funHasParallelism funSizeParams consts_scope fd = do   let FunDef         { funDefBody = body,           funDefParams = fparams,@@ -631,7 +654,7 @@         } = fd   (body', needs) <-     runFlattenM (scopeOfFParams fparams <> castScope consts_scope) $-      transformBody funHasParallelism funSizeParams body+      transformBody attrs funHasParallelism funSizeParams body   pure     ( fd         { funDefBody = body',@@ -643,13 +666,14 @@  liftUntilFixedPoint ::   Prog SOACS ->+  Attrs ->   FunHasParallelism ->   FunSizeParams ->   Scope SOACS ->   S.Set DemandFn ->   S.Set DemandFn ->   PassM [FunDef GPU]-liftUntilFixedPoint prog funHasParallelism funSizeParams consts_scope made needed = do+liftUntilFixedPoint prog attrs funHasParallelism funSizeParams consts_scope made needed = do   let made' = made <> needed   (lifted_funs, new_needed) <-     fmap (second ((`S.difference` made') . mconcat)) $@@ -659,19 +683,19 @@     then pure lifted_funs     else       (lifted_funs ++)-        <$> liftUntilFixedPoint prog funHasParallelism funSizeParams consts_scope made' new_needed+        <$> liftUntilFixedPoint prog attrs funHasParallelism funSizeParams consts_scope made' new_needed   where     mkDemanded (DemandLifted fname mode) =       case find ((== fname) . funDefName) $ progFuns prog of         Just fundef ->           case mode of-            UniformLift -> liftUniformFunDef funHasParallelism funSizeParams consts_scope fundef-            NonUniformLift -> liftFunDef funHasParallelism funSizeParams consts_scope fundef+            UniformLift -> liftUniformFunDef attrs funHasParallelism funSizeParams consts_scope fundef+            NonUniformLift -> liftFunDef attrs funHasParallelism funSizeParams consts_scope fundef         Nothing -> error $ "mkDemanded: " <> show fname     mkDemanded (DemandBuiltin b) = pure (builtinFunDef b, mempty) -transformProg :: Prog SOACS -> PassM (Prog GPU)-transformProg prog = do+transformProg :: Attrs -> Prog SOACS -> PassM (Prog GPU)+transformProg attrs prog = do   progAfterPreProcessing <- preprocessProg prog   let consts = progConsts progAfterPreProcessing       consts_scope = scopeOf consts@@ -683,15 +707,16 @@       funSizeParams fname =         M.findWithDefault mempty fname size_param_map   (consts', consts_needs) <--    runFlattenM mempty $ collectStms_ $ transformStms funHasParallelism funSizeParams consts+    runFlattenM mempty $ collectStms_ $ transformStms attrs funHasParallelism funSizeParams consts   (funs', funs_needs) <-     second mconcat-      <$> mapAndUnzipM (transformFunDef funHasParallelism funSizeParams consts_scope) funs+      <$> mapAndUnzipM (transformFunDef attrs funHasParallelism funSizeParams consts_scope) funs    -- Now do fixpoint iteration until all needed functions have been provided.   lifted_funs <-     liftUntilFixedPoint       prog+      attrs       funHasParallelism       funSizeParams       consts_scope@@ -705,11 +730,17 @@       }  -- | Transform a SOACS program to a GPU program, using flattening.-flattenSOACs :: Pass SOACS GPU-flattenSOACs =+--+-- Parameterised by the names of flattening attributes to impose on top-level+-- SOACs that do not carry flattening attributes of their own.+flattenSOACs :: [Name] -> Pass SOACS GPU+flattenSOACs attr_names =   Pass     { passName = "flatten",       passDescription = "Perform full flattening",-      passFunction = transformProg+      passFunction = transformProg attrs     }+  where+    attrs =+      foldMap (oneAttr . AttrComp "flattening" . pure . AttrName) attr_names {-# NOINLINE flattenSOACs #-}
src/Futhark/Pass/Flatten/BasicOp.hs view
@@ -72,7 +72,7 @@   m <- arraySize 0 <$> lookupType ns_full_F   data_t <- lookupType (irregularD (head reparr))   let pt = elemType data_t-  let result_type = Array pt (Shape [m]) NoUniqueness+  let result_type = Array pt (Shape [m]) NoMode   elems_blank <- letExp "blank_res" =<< eBlank result_type    -- Scatter data into result array@@ -176,7 +176,7 @@   m <- arraySize 0 <$> lookupType ns_full_F   data_t <- lookupType (irregularD (head rep_arr))   let pt = elemType data_t-  let result_type = Array pt (Shape [m]) NoUniqueness+  let result_type = Array pt (Shape [m]) NoMode   elems_blank <- letExp "blank_res" =<< eBlank result_type    -- Scatter data into result array@@ -315,7 +315,7 @@   Segments ->   DistEnv ->   DistInputs ->-  TypeBase Shape u ->+  TypeBase Shape o ->   [Int] ->   IrregularRep ->   FlattenM IrregularRep@@ -363,13 +363,13 @@             Array               (elemType row_type)               (segmentsShape segments <> Shape [intConst Int64 0] <> arrayShape row_type)-              NoUniqueness+              NoMode       v <- letExp "arraylit_empty_reg" =<< eBlank resultType       pure $ insertRegulars [distResTag res] [v] env   | otherwise = do       ns <- dataArr lvl segments env inps $ intConst Int64 0       (flags, offsets, _elems) <- doRepIota lvl ns-      let resultType = Array (elemType row_type) (Shape [intConst Int64 0]) NoUniqueness+      let resultType = Array (elemType row_type) (Shape [intConst Int64 0]) NoMode       elems <- letExp "arraylit_empty_elems" =<< eBlank resultType       insertIrregularM ns flags offsets (distResTag res) elems Dense env transformArrayLit (TrCtx lvl segments env inps res _aux) vs row_type@@ -426,7 +426,7 @@        m <- arraySize 0 <$> lookupType full_II1       let pt = elemType row_type-      let resultType = Array pt (Shape [m]) NoUniqueness+      let resultType = Array pt (Shape [m]) NoMode       elems_blank <- letExp "blank_res" =<< eBlank resultType        elems <-
src/Futhark/Pass/Flatten/Builtins.hs view
@@ -98,7 +98,7 @@       usable_groups <-         letSubExp "segmap_usable_groups"           =<< eBinOp-            (SDivUp Int64 Unsafe)+            (SCeilDiv Int64 Unsafe)             (eSubExp w)             (eSubExp =<< asIntS Int64 tblock_size)       let grid = KernelGrid (Count usable_groups) (Count tblock_size)@@ -826,7 +826,7 @@ segIotaBuiltin :: FunDef GPU segIotaBuiltin = buildingBuiltin $ do   np <- newParam "n" $ Prim int64-  nsp <- newParam "ns" $ Array int64 (Shape [Var (paramName np)]) Nonunique+  nsp <- newParam "ns" $ Array int64 (Shape [Var (paramName np)]) Observe   body <-     localScope (scopeOfFParams [np, nsp]) . buildBody_ $ do       (flags, offsets, res) <- genSegIota topSegLevel (paramName nsp)@@ -841,9 +841,9 @@           map             (,mempty)             [ Prim int64,-              Array Bool (Shape [Ext 0]) Unique,-              Array int64 (Shape [Free $ Var $ paramName np]) Unique,-              Array int64 (Shape [Ext 0]) Unique+              Array Bool (Shape [Ext 0]) NoMode,+              Array int64 (Shape [Free $ Var $ paramName np]) NoMode,+              Array int64 (Shape [Ext 0]) NoMode             ],         funDefParams = [np, nsp],         funDefBody = body@@ -852,7 +852,7 @@ repIotaBuiltin :: FunDef GPU repIotaBuiltin = buildingBuiltin $ do   np <- newParam "n" $ Prim int64-  nsp <- newParam "ns" $ Array int64 (Shape [Var (paramName np)]) Nonunique+  nsp <- newParam "ns" $ Array int64 (Shape [Var (paramName np)]) Observe   body <-     localScope (scopeOfFParams [np, nsp]) . buildBody_ $ do       (flags, offsets, res) <- genRepIota topSegLevel (paramName nsp)@@ -867,9 +867,9 @@           map             (,mempty)             [ Prim int64,-              Array Bool (Shape [Ext 0]) Unique,-              Array int64 (Shape [Free $ Var $ paramName np]) Unique,-              Array int64 (Shape [Ext 0]) Unique+              Array Bool (Shape [Ext 0]) NoMode,+              Array int64 (Shape [Free $ Var $ paramName np]) NoMode,+              Array int64 (Shape [Ext 0]) NoMode             ],         funDefParams = [np, nsp],         funDefBody = body@@ -878,7 +878,7 @@ prefixSumBuiltin :: FunDef GPU prefixSumBuiltin = buildingBuiltin $ do   np <- newParam "n" $ Prim int64-  nsp <- newParam "ns" $ Array int64 (Shape [Var (paramName np)]) Nonunique+  nsp <- newParam "ns" $ Array int64 (Shape [Var (paramName np)]) Observe   body <-     localScope (scopeOfFParams [np, nsp]) . buildBody_ $       varsRes . pure <$> genPrefixSum topSegLevel "res" (paramName nsp)@@ -888,7 +888,7 @@         funDefAttrs = mempty,         funDefName = prefixSumName,         funDefRetType =-          [(Array int64 (Shape [Free $ Var $ paramName np]) Unique, mempty)],+          [(Array int64 (Shape [Free $ Var $ paramName np]) NoMode, mempty)],         funDefParams = [np, nsp],         funDefBody = body       }@@ -897,7 +897,7 @@ partitionBuiltin = buildingBuiltin $ do   np <- newParam "n" $ Prim int64   kp <- newParam "k" $ Prim int64-  csp <- newParam "cs" $ Array int64 (Shape [Var (paramName np)]) Nonunique+  csp <- newParam "cs" $ Array int64 (Shape [Var (paramName np)]) Observe   body <-     localScope (scopeOfFParams [np, kp, csp]) . buildBody_ $ do       (counts, offsets, res) <- genPartition topSegLevel (paramName np) (paramName kp) (paramName csp)@@ -910,9 +910,9 @@         funDefRetType =           map             (,mempty)-            [ Array int64 (Shape [Free $ Var $ paramName kp]) Unique,-              Array int64 (Shape [Free $ Var $ paramName kp]) Unique,-              Array int64 (Shape [Free $ Var $ paramName np]) Unique+            [ Array int64 (Shape [Free $ Var $ paramName kp]) NoMode,+              Array int64 (Shape [Free $ Var $ paramName kp]) NoMode,+              Array int64 (Shape [Free $ Var $ paramName np]) NoMode             ],         funDefParams = [np, kp, csp],         funDefBody = body@@ -997,7 +997,7 @@         Apply           (funDefName prefixSumBuiltin)           [(n, Observe), (Var ns, Observe)]-          [(toDecl (staticShapes1 ns_t) Unique, mempty)]+          [(staticShapes1 ns_t, mempty)]           Safe  doPartition ::
src/Futhark/Pass/Flatten/Distribute.hs view
@@ -229,10 +229,10 @@     findCert v = fromMaybe (DistInputFree v (Prim Unit)) $ lookup v avail_inputs  splitIrregDims :: Names -> Type -> (Rank, Type)-splitIrregDims bound_outside (Array pt shape u) =+splitIrregDims bound_outside (Array pt shape o) =   let (reg, irreg) =         first reverse $ span regDim $ reverse $ shapeDims shape-   in (Rank $ length irreg, Array pt (Shape reg) u)+   in (Rank $ length irreg, Array pt (Shape reg) o)   where     regDim (Var v) = v `nameIn` bound_outside     regDim Constant {} = True@@ -342,9 +342,12 @@     isParallelBasicOp Reshape {} = True     isParallelBasicOp (FlatIndex _ flat_slice) = not $ null $ flatSliceDims flat_slice     isParallelBasicOp (Index _ slice) = not $ null $ sliceDims slice+    -- The work done by an 'ArrayLit' is its number of rows times the size of a+    -- row. Since the size is syntactic, we consider a literal of scalars to be+    -- always cheap enough for a single thread to construct.+    isParallelBasicOp (ArrayLit _ row_t) = arrayRank row_t > 0     -- Now the sequential ones - we handle them explicitly so we will notice if     -- we ever add a new one.-    isParallelBasicOp ArrayLit {} = False     isParallelBasicOp ArrayVal {} = False     isParallelBasicOp Scratch {} = False     isParallelBasicOp SubExp {} = False
src/Futhark/Pass/Flatten/General.hs view
@@ -285,7 +285,7 @@   DistEnv ->   [SubExp] ->   DistInputs ->-  TypeBase Shape u ->+  TypeBase Shape o ->   FlattenM [SubExp] readTypeDims segments env is inputs =   mapM (readInput segments env is inputs) . arrayDims@@ -634,23 +634,23 @@       p <-         newParam           (desc <> "_lifted")-          (arrayOf (Prim pt) (Shape [w]) Nonunique)+          (arrayOf (Prim pt) (Shape [w]) Observe)       pure ([p], Regular $ paramName p)-    Array pt _ u -> do+    Array pt _ o -> do       num_data <-         newParam (desc <> "_num_data") $ Prim int64       segments <--        newParam (desc <> "_segments") $-          arrayOf (Prim int64) (Shape [w]) Nonunique+        newParam (desc <> "_S") $+          arrayOf (Prim int64) (Shape [w]) Observe       flags <-         newParam (desc <> "_F") $-          arrayOf (Prim Bool) (Shape [Var (paramName num_data)]) Nonunique+          arrayOf (Prim Bool) (Shape [Var (paramName num_data)]) Observe       offsets <-         newParam (desc <> "_O") $-          arrayOf (Prim int64) (Shape [w]) Nonunique+          arrayOf (Prim int64) (Shape [w]) Observe       elems <--        newParam (desc <> "_data") $-          arrayOf (Prim pt) (Shape [Var (paramName num_data)]) u+        newParam (desc <> "_D") $+          arrayOf (Prim pt) (Shape [Var (paramName num_data)]) o       pure         ( [num_data, segments, flags, offsets, elems],           Irregular $@@ -676,12 +676,12 @@       p <-         newParam           (desc <> "_lifted")-          (arrayOf (Prim pt) (Shape [w]) Nonunique)+          (arrayOf (Prim pt) (Shape [w]) Observe)       pure (p, Regular $ paramName p)-    Array pt shape u -> do+    Array pt shape o -> do       p <-         newParam (desc <> "_lifted") $-          arrayOf (Prim pt) (Shape [w] <> shape) u+          arrayOf (Prim pt) (Shape [w] <> shape) o       pure (p, Regular $ paramName p)     Acc {} ->       error "liftParam: Acc"@@ -760,7 +760,7 @@ -- -- See the 'liftResult' function for the opposite process i.e. -- turning 'ResRep's into results.-resultToResReps :: [TypeBase s u] -> [VName] -> [ResRep]+resultToResReps :: [TypeBase s o] -> [VName] -> [ResRep] resultToResReps types results =   snd $     L.mapAccumL
src/Futhark/Pass/Flatten/Incremental.hs view
@@ -48,6 +48,7 @@     mapAlternatives,     scanRedAlternatives,     propagateVersioningAttrs,+    imposeAttrs,      -- * Transforming code     factorScremaForParallelism,@@ -70,7 +71,6 @@ import Control.Monad.State import Data.Foldable import Data.Maybe (isJust)-import Data.Set qualified as S import Futhark.IR.GPU import Futhark.IR.SOACS import Futhark.Pass.Flatten.Distribute@@ -234,13 +234,13 @@         (varsRes $ Intrablock.intraResultNames intra)   pure (intra_ok, intra_body) --- | Construct the multi-versioned alternatives for a map, given the--- fully-flattened body, the outer-parallel-only body, and an optional--- intrablock result. This is the shared versioning policy used both for--- top-level maps and for maps nested inside a map-nest; the only differences--- between the two are which bodies are supplied and how their results are--- consumed, both of which are handled by the caller. The @ws@ are the widths--- whose product bounds the outer parallelism (used for the threshold+-- | Construct the multi-versioned alternatives for a map, given actions that+-- construct the fully-flattened body and the outer-parallel-only body, and an+-- optional intrablock result. This is the shared versioning policy used both+-- for top-level maps and for maps nested inside a map-nest; the only+-- differences between the two are which bodies are supplied and how their+-- results are consumed, both of which are handled by the caller. The @ws@ are+-- the widths whose product bounds the outer parallelism (used for the threshold -- comparison). Returns the names bound to the final results. mapAlternatives ::   -- | Description for the result bindings.@@ -252,47 +252,54 @@   -- | Is the body worth sequentialising (offering an outer-only version)?   Bool ->   [SubExp] ->-  Body GPU ->-  Body GPU ->+  -- | Construct the fully flattened body.+  FlattenM (Body GPU) ->+  -- | Construct the outer-parallelism-only body.+  FlattenM (Body GPU) ->   Maybe Intrablock.IntrablockResult ->   FlattenM [VName]-mapAlternatives desc result_ts attrs parallel_fun_inside worth_seq ws full_body outer_body intra' =+mapAlternatives desc result_ts attrs parallel_fun_inside worth_seq ws mkFullBody mkOuterBody intra' =   case intra' of     _       | parallel_fun_inside ->-          kernelAlternatives desc result_ts full_body []-      | "sequential_inner" `inAttrs` attrs ->+          full []+      | "sequential_inner" `inAttrs` attrs -> do+          outer_body <- mkOuterBody           kernelAlternatives desc result_ts outer_body []     Nothing       | not only_intra,         worth_seq,-        mayExploitOuter attrs -> do-          (outer_suff, _) <- outerSuff-          kernelAlternatives desc result_ts full_body [(outer_suff, outer_body)]+        mayExploitOuter attrs ->+          full . pure =<< outerAlternative       | otherwise ->-          kernelAlternatives desc result_ts full_body []+          full []     Just intra_res       | only_intra -> do           (_, intra_body) <- intraBlockAlternative intra_res           kernelAlternatives desc result_ts intra_body []       | worth_seq,         mayExploitOuter attrs -> do-          (outer_suff, _) <- outerSuff-          intra_alt <- intraBlockAlternative intra_res-          kernelAlternatives desc result_ts full_body [(outer_suff, outer_body), intra_alt]-      | otherwise -> do+          outer_alt <- outerAlternative           intra_alt <- intraBlockAlternative intra_res-          kernelAlternatives desc result_ts full_body [intra_alt]+          full [outer_alt, intra_alt]+      | otherwise ->+          full . pure =<< intraBlockAlternative intra_res   where     only_intra = onlyExploitIntra attrs -    outerSuff = sufficientParallelism suffOuterPar ws mempty Nothing+    full alts = do+      full_body <- mkFullBody+      kernelAlternatives desc result_ts full_body alts --- | Construct the multi-versioned alternatives for a scan or reduce, given the--- fully-flattened body and the outer-parallel-only body. Unlike--- 'mapAlternatives' there is no intrablock version, and the outer-only version--- is always offered (subject to attributes). Shared between top-level and--- nested uniform scans/reduces.+    outerAlternative = do+      outer_body <- mkOuterBody+      (outer_suff, _) <- sufficientParallelism suffOuterPar ws mempty Nothing+      pure (outer_suff, outer_body)++-- | Construct the multi-versioned alternatives for a scan or reduce, given+-- actions that construct the fully-flattened body and the outer-parallel-only+-- body. Unlike 'mapAlternatives' there is no intrablock version, and the+-- outer-only version is always offered (subject to attributes). scanRedAlternatives ::   Name ->   [Type] ->@@ -302,10 +309,12 @@   -- | Does the seg level permit versioning at all (false in-block)?   Bool ->   [SubExp] ->-  Body GPU ->-  Body GPU ->+  -- | Construct the fully flattened body.+  FlattenM (Body GPU) ->+  -- | Construct the outer-parallelism-only body.+  FlattenM (Body GPU) ->   FlattenM [VName]-scanRedAlternatives desc result_ts attrs parallel_fun_inside allow_versioning ws full_body outer_body+scanRedAlternatives desc result_ts attrs parallel_fun_inside allow_versioning ws mkFullBody mkOuterBody   | parallel_fun_inside =       fullAlternative   | "sequential_inner" `inAttrs` attrs =@@ -315,11 +324,17 @@   | otherwise =       fullAlternative   where-    fullAlternative = kernelAlternatives desc result_ts full_body []+    fullAlternative = do+      full_body <- mkFullBody+      kernelAlternatives desc result_ts full_body [] -    outerAlternative = kernelAlternatives desc result_ts outer_body []+    outerAlternative = do+      outer_body <- mkOuterBody+      kernelAlternatives desc result_ts outer_body []      fullWithOuterAlternative = do+      outer_body <- mkOuterBody+      full_body <- mkFullBody       (outer_suff, _) <- sufficientParallelism suffOuterPar ws mempty Nothing       kernelAlternatives desc result_ts full_body [(outer_suff, outer_body)] @@ -454,13 +469,13 @@   (MonadBuilder m) =>   FunHasParallelism ->   Scope SOACS ->-  Certs ->+  StmAux () ->   Pat Type ->   SubExp ->   [VName] ->   ScremaForm SOACS ->   m (Maybe (Body SOACS))-factorScremaForParallelism funHasParallelism scope certs pat w arrs form+factorScremaForParallelism funHasParallelism scope aux pat w arrs form   | Just (reds, map_lam) <- isRedomapSOAC form,     lambdaHasMeaningfulParallelism funHasParallelism map_lam = do       map_lam' <- preprocessLambda scope map_lam@@ -501,24 +516,45 @@       pure Nothing   where     mkFactoredBody stms = do-      stms' <- fmap (certify certs) <$> preprocessStms scope stms+      stms' <-+        fmap (propagateAttrs (stmAuxAttrs aux) . certify (stmAuxCerts aux))+          <$> preprocessStms scope stms       pure $ mkBody stms' $ varsRes $ patNames pat +-- | Add the flattening attributes of the enclosing context to a statement. A+-- statement that carries flattening attributes of its own is left alone, as+-- those are more specific.+propagateAttrs :: Attrs -> Stm SOACS -> Stm SOACS+propagateAttrs attrs stm+  | attrs' == mempty = stm+  | flatteningAttrs (stmAuxAttrs (stmAux stm)) == mempty =+      stm {stmAux = (stmAux stm) {stmAuxAttrs = attrs' <> stmAuxAttrs (stmAux stm)}}+  | otherwise = stm+  where+    -- 'flatteningAttrs' strips the enclosing 'flattening', which has to be put+    -- back for the attributes to be recognised on the statement.+    attrs' =+      mconcat . mapAttrs (oneAttr . AttrComp "flattening" . pure) $+        flatteningAttrs attrs++-- | Impose outside flattening attributes on a statement. Only SOACs are+-- affected, and only those that carry no flattening attributes of their own, as+-- those are more specific.+imposeAttrs :: Attrs -> Stm SOACS -> Stm SOACS+imposeAttrs attrs stm+  | Op {} <- stmExp stm = propagateAttrs attrs stm+  | otherwise = stm+ -- | Propagate incremental flattening attributes to the statements of -- a map lambda body. Statements that carry their own incremental -- flattening attributes are left alone. propagateVersioningAttrs :: Attrs -> Lambda SOACS -> Lambda SOACS propagateVersioningAttrs attrs lam-  | attrs' == mempty = lam+  | flatteningAttrs attrs == mempty = lam   | otherwise =-      lam {lambdaBody = (lambdaBody lam) {bodyStms = fmap onStm (bodyStms (lambdaBody lam))}}-  where-    attrs' = versioningAttrs attrs-    onStm stm-      | versioningAttrs (stmAuxAttrs (stmAux stm)) == mempty =-          stm {stmAux = (stmAux stm) {stmAuxAttrs = attrs' <> stmAuxAttrs (stmAux stm)}}-      | otherwise = stm-    versioningAttrs (Attrs s) = Attrs $ S.filter isVersioningAttr s-    isVersioningAttr (AttrComp "incremental_flattening" _) = True-    isVersioningAttr (AttrComp "flattening" _) = True-    isVersioningAttr _ = False+      lam+        { lambdaBody =+            (lambdaBody lam)+              { bodyStms = fmap (propagateAttrs attrs) (bodyStms (lambdaBody lam))+              }+        }
src/Futhark/Pass/Flatten/Loop.hs view
@@ -56,10 +56,10 @@       param <-         newParam           (baseName (paramName fparam) <> "_lifted")-          (arrayOf (Prim pt) (segmentsShape segments) Nonunique)+          (arrayOf (Prim pt) (segmentsShape segments) Observe)       initV <- liftSubExpRegular lvl segments inps env (segmentsShape segments) initSE       pure ([param], Regular $ paramName param, [Var initV])-    Array pt _ u+    Array pt _ o       | needsIrregular inps loopParamNames t -> do           (params, rep) <- liftParam num_segments fparam           (_, initRep) <- liftSubExp lvl segments inps env initSE@@ -75,7 +75,7 @@           p <-             newParam               (baseName (paramName fparam) <> "_lifted")-              (arrayOf (Prim pt) pShape u)+              (arrayOf (Prim pt) pShape o)           initV <- liftSubExpRegular lvl segments inps env pShape initSE           -- If the parameter is consumed, we must not consume the           -- representation array (it may be used by other versions in@@ -83,7 +83,7 @@           -- removes it again when consuming the representation directly is           -- safe.           initV' <--            if u == Unique+            if o == Consume               then letExp (baseName (paramName fparam) <> "_inter_copy") =<< eCopy (eVar initV)               else pure initV           pure ([p], Regular $ paramName p, [Var initV'])@@ -550,7 +550,7 @@                         let initial_shape = Shape [w] <> arrayShape t                         let final_shape = segmentsShape segments <> arrayShape t                         let pt = elemType t-                        space <- letExp "blank" =<< eBlank (Array pt initial_shape NoUniqueness)+                        space <- letExp "blank" =<< eBlank (Array pt initial_shape NoMode)                          out <-                           foldM@@ -568,7 +568,7 @@                       (Irregular ir0, Irregular ir1) -> do                         segsSpace <-                           letExp "blank_segs"-                            =<< eBlank (Array int64 (Shape [w]) NoUniqueness)+                            =<< eBlank (Array int64 (Shape [w]) NoMode)                          segs <-                           foldM@@ -581,7 +581,7 @@                         let pt = elemType t                         elemsSpace <-                           letExp "blank_elems"-                            =<< eBlank (Array pt (Shape [num_data]) NoUniqueness)+                            =<< eBlank (Array pt (Shape [num_data]) NoMode)                          elems <-                           foldM
src/Futhark/Pass/Flatten/Match.hs view
@@ -64,7 +64,7 @@           xs <- mapM asRegular branchesRep           pure $ Regular $ last xs         else do-          let resultType = Array (elemType resType) (Shape [w] <> arrayShape resType) NoUniqueness+          let resultType = Array (elemType resType) (Shape [w] <> arrayShape resType) NoMode           xs <- mapM asRegular branchesRep           -- Create the blank space for the result           resultSpace <- letExp "blank_res" =<< eBlank resultType@@ -78,13 +78,13 @@   -- Irregular case   | DistType _ _ (Array pt _ _) <- distResType dist_res = do       branchesIrregRep <- mapM asIrregular branchesRep-      let segsType = Array (IntType Int64) (Shape [w]) NoUniqueness+      let segsType = Array (IntType Int64) (Shape [w]) NoMode       -- Create a blank space for the 'segs'       segsSpace <- letExp "blank_segs" =<< eBlank segsType       -- Write back the segs of each branch to the blank space       segs <- foldM (scatterRegular lvl) segsSpace $ zip iss (irregularS <$> branchesIrregRep)       (_, offsets, num_data) <- exScanAndSum lvl segs-      let resultType = Array pt (Shape [num_data]) NoUniqueness+      let resultType = Array pt (Shape [num_data]) NoMode       -- Create the blank space for the result       resultSpace <- letExp "blank_res" =<< eBlank resultType       -- Write back the values of each branch to the blank space@@ -241,7 +241,7 @@       let (v, inp) = v_inp        in if isAcc (distInputType inp)             then case distInputType inp of-              Acc cert' _ _ _ | cert == cert' -> Just v+              Acc cert' _ _ | cert == cert' -> Just v               _ -> Nothing             else Nothing @@ -255,7 +255,7 @@             then               acc_reps             else-              let (Acc cert _ _ _) = t+              let (Acc cert _ _) = t                   accVars = findAccCerts cert                in foldl (\m v -> M.insert v rep m) acc_reps accVars     replaceAccReps acc_reps reps = foldl replaceAccRep acc_reps $ zip res reps
src/Futhark/Pass/Flatten/SOAC.hs view
@@ -564,18 +564,18 @@         [ t `arrayOfShape` segmentsShape segments         | DistResult _ (DistType _ _ t) _ <- res         ]-  outer_body <- renamedBody outer_only-  full_body <- case segments of-    -- Top-level (no enclosing segments): flatten the factored body's statements-    -- as ordinary top-level statements. Unlike distributing them over segments,-    -- this copes with array-valued operators and nested SOACs whose temporaries-    -- would otherwise escape the segmented machinery's scope.-    [] ->-      renameBody <=< buildBody_ $ do-        mapM_ (flattenTopLevelStm ops) $ bodyStms factored_body-        pure $ bodyResult factored_body-    _ ->-      renamedBody $ regularRepVars <$> distributeAndFlattenBody ops segments "versionScanRed_full_body" env inps res factored_body+  let fullFlatten = case segments of+        -- Top-level (no enclosing segments): flatten the factored body's+        -- statements as ordinary top-level statements. Unlike distributing them+        -- over segments, this copes with array-valued operators and nested+        -- SOACs whose temporaries would otherwise escape the segmented+        -- machinery's scope.+        [] ->+          renameBody <=< buildBody_ $ do+            mapM_ (flattenTopLevelStm ops) $ bodyStms factored_body+            pure $ bodyResult factored_body+        _ ->+          renamedBody $ regularRepVars <$> distributeAndFlattenBody ops segments "versionScanRed_full_body" env inps res factored_body    match_res <-     certifying (distCerts inps aux env) $@@ -586,8 +586,8 @@         (isParallelFunInside (flattenFunHasParallelism ops) factored_body)         (allowVersioning (flattenSegLevel ops))         (segments <> pure w)-        full_body-        outer_body+        fullFlatten+        (renamedBody outer_only)   pure $ insertRegulars (map distResTag res) match_res env  insertSegOpMapResults ::@@ -1101,9 +1101,9 @@ -- per-enclosing-segment values. transformMap ::   FlattenOps ->-  -- | Incremental-flattening attributes of the enclosing statement, propagated-  -- onto the (preprocessed) body in the top-level case; see-  -- 'transformTopLevelMap'.+  -- | Incremental-flattening attributes of the map itself. These are+  -- propagated onto the (preprocessed) body, and so eventually reach maps at+  -- any depth of the nest.   Attrs ->   Segments ->   DistEnv ->@@ -1115,8 +1115,8 @@   FlattenM [ResRep] transformMap ops attrs [] _env _inps pat w arrs map_lam = do   -- Top-level map (no enclosing segments). Preprocess the body and then-  -- propagate the enclosing attributes onto it, so they influence how the body-  -- is versioned (e.g. only_inner reaching a Screma produced by interchanging a+  -- propagate the attributes onto it, so they influence how the body is+  -- versioned (e.g. only_inner reaching a Screma produced by interchanging a   -- 'sequential_outer' loop). Order matters: preprocessing may rewrite a body   -- statement, so propagating first would lose the attributes on the rewritten   -- form. XXX: this is arguably a bug in preprocessing.@@ -1125,10 +1125,12 @@     fmap (propagateVersioningAttrs attrs) . renameLambda       =<< preprocessLambda scope map_lam   transformTopLevelMap ops pat w arrs lam-transformMap ops _attrs segments env inps pat w arrs map_lam = do+transformMap ops attrs segments env inps pat w arrs map_lam = do+  -- Nested map. As in the top-level case, propagate the attributes onto the+  -- preprocessed body; this is what carries them to maps deeper in the nest.   gpu_scope <- askScope   let pp_scope = castScope $ scopeOfDistInputs inps <> gpu_scope-  lam <- preprocessLambda pp_scope map_lam+  lam <- propagateVersioningAttrs attrs <$> preprocessLambda pp_scope map_lam   transformInnerMap ops segments env inps pat w arrs lam  -- | Fully flatten a map that has no enclosing segments (a top-level map). This@@ -1239,10 +1241,7 @@       outerOnly =         runMapLambdaBody segments env inps w arrs map_lam pat ress -  full_body <- renamedBody fullFlatten-  outer_body <- renamedBody outerOnly--  let result_ts =+      result_ts =         [ t `arrayOfShape` segmentsShape segments         | DistResult _ (DistType _ _ t) _ <- ress         ]@@ -1258,8 +1257,8 @@         False         (worthSequentialising map_lam)         (segments <> pure w)-        full_body-        outer_body+        (renamedBody fullFlatten)+        (renamedBody outerOnly)         intra'    pure $ insertRegulars (map distResTag ress) match_res env@@ -1282,7 +1281,7 @@   let outer_only = transformUniformRedomap (flattenSegLevel ops) segments env inps w arrs reds map_lam   gpu_scope <- askScope   let pp_scope = castScope $ scopeOfDistInputs inps <> gpu_scope-  factored <- factorScremaForParallelism funHasParallelism pp_scope (stmAuxCerts aux) pat w arrs form+  factored <- factorScremaForParallelism funHasParallelism pp_scope aux pat w arrs form   case factored of     Just body ->       versionScanRed ops "uniform_redomap_alt" segments env inps res aux w body outer_only@@ -1365,7 +1364,7 @@         transformUniformMaposcanomap lvl segments env inps w arrs scans post_lam map_lam   gpu_scope <- askScope   let pp_scope = castScope $ scopeOfDistInputs inps <> gpu_scope-  factored <- factorScremaForParallelism funHasParallelism pp_scope (stmAuxCerts aux) pat w arrs form+  factored <- factorScremaForParallelism funHasParallelism pp_scope aux pat w arrs form   case factored of     Just body ->       versionScanRed ops "uniform_maposcanomap_alt" segments env inps res aux w body outer_only@@ -1449,7 +1448,7 @@ flattenOtherScrema ops segments env inps res pat aux w arrs form = do   gpu_scope <- askScope   let pp_scope = castScope $ scopeOfDistInputs inps <> gpu_scope-  factored <- factorScremaForParallelism funHasParallelism pp_scope (stmAuxCerts aux) pat w arrs form+  factored <- factorScremaForParallelism funHasParallelism pp_scope aux pat w arrs form   case factored of     Just body -> do       reps <- distributeAndFlattenBody ops segments "factorScremaForParallelism_body" env inps res body
src/Futhark/Pass/Flatten/WithAcc.hs view
@@ -272,17 +272,17 @@      trType ::       (VName -> Maybe Shape, VName -> Safety -> [SubExp] -> Maybe (Builder SOACS [SubExp])) ->-      TypeBase shape u ->-      TypeBase shape u-    trType sf (Acc acc _ ts u)+      TypeBase shape o ->+      TypeBase shape o+    trType sf (Acc acc _ ts)       | Just shape <- fst sf acc =-          Acc acc shape ts u+          Acc acc shape ts     trType _ t = t      trParam ::       (VName -> Maybe Shape, VName -> Safety -> [SubExp] -> Maybe (Builder SOACS [SubExp])) ->-      Param (TypeBase Shape u) ->-      Param (TypeBase Shape u)+      Param (TypeBase Shape o) ->+      Param (TypeBase Shape o)     trParam sf = fmap $ trType sf      trBody sf (Body dec stms res) =@@ -303,7 +303,7 @@       WithAcc acc_inputs <$> trLam sf lam     trExp sf (Pat [PatElem _ acc_t]) (BasicOp (UpdateAcc safety acc is ses)) = do       case acc_t of-        Acc cert _ _ _+        Acc cert _ _           | Just mk <- snd sf cert safety is -> do               is' <- mk               pure $ BasicOp $ UpdateAcc safety acc is' ses
src/Futhark/Passes.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fomit-interface-pragmas #-}+ -- | Optimisation pipelines. module Futhark.Passes   ( standardPipeline,@@ -84,7 +86,7 @@ gpuPipeline :: Pipeline SOACS GPU gpuPipeline =   standardPipeline-    >>> onePass flattenSOACs+    >>> onePass (flattenSOACs mempty)     >>> passes       [ simplifyGPU,         -- For getting rid of builtins added by flattening.
src/Futhark/Pipeline.hs view
@@ -37,6 +37,13 @@ import Futhark.Compiler.Config (Verbosity (..)) import Futhark.Error import Futhark.IR (PrettyRep, Prog)+import Futhark.IR.GPU (GPU)+import Futhark.IR.GPUMem (GPUMem)+import Futhark.IR.MC (MC)+import Futhark.IR.MCMem (MCMem)+import Futhark.IR.SOACS (SOACS)+import Futhark.IR.Seq (Seq)+import Futhark.IR.SeqMem (SeqMem) import Futhark.IR.TypeCheck import Futhark.MonadFreshNames import Futhark.Pass@@ -187,6 +194,16 @@     errorOnError (Left (prog, err)) _ _ =       validationError pass prog $ show err     errorOnError _ c x = c x++-- Specialising here means that the type checker is specialised once for each+-- representation, rather than in every module that builds a pipeline.+{-# SPECIALIZE onePass :: Pass fromrep SOACS -> Pipeline fromrep SOACS #-}+{-# SPECIALIZE onePass :: Pass fromrep GPU -> Pipeline fromrep GPU #-}+{-# SPECIALIZE onePass :: Pass fromrep MC -> Pipeline fromrep MC #-}+{-# SPECIALIZE onePass :: Pass fromrep Seq -> Pipeline fromrep Seq #-}+{-# SPECIALIZE onePass :: Pass fromrep SeqMem -> Pipeline fromrep SeqMem #-}+{-# SPECIALIZE onePass :: Pass fromrep GPUMem -> Pipeline fromrep GPUMem #-}+{-# SPECIALIZE onePass :: Pass fromrep MCMem -> Pipeline fromrep MCMem #-}  -- | Conditionally run pipeline if predicate is true. condPipeline ::
src/Futhark/Profile/Html.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Futhark.Profile.Html (securedHashPath, generateHeatmapHtml, generateCCOverviewHtml, generateHtmlIndex) where+module Futhark.Profile.Html (securedHashPath, generateHeatmapHtml, generateCCOverviewHtml, generateHtmlIndex, generateSourceIndex) where  import Control.Monad (join) import Control.Monad.State.Strict (State, evalState, get, modify)@@ -14,7 +14,7 @@ import Data.String (IsString (fromString)) import Data.Text qualified as T import Data.Word (Word8)-import Futhark.Profile.Details (CostCentreDetails (CostCentreDetails, summary), CostCentreName (CostCentreName, getCostCentreName), CostCentres, SourceRangeDetails (SourceRangeDetails, containingCostCentres), SourceRanges, sourceRangeDetailsFraction)+import Futhark.Profile.Details (CostCentreDetails (CostCentreDetails, summary), CostCentreName (CostCentreName, getCostCentreName), SourceRangeDetails (SourceRangeDetails, containingCostCentres), SourceRanges, sourceRangeDetailsFraction) import Futhark.Profile.Details qualified as D import Futhark.Profile.EventSummary qualified as ES import Futhark.Profile.SourceRange qualified as SR@@ -39,20 +39,47 @@     remainingText :: !T.Text   } +-- | A dataset report with browser-readable logs and timeline.  The source+-- index may instead explain why source analysis was unavailable. generateHtmlIndex ::   -- | Path of the bench dir   FilePath ->-  M.Map FilePath SourceRanges ->-  CostCentres ->+  Maybe T.Text ->+  Maybe T.Text ->+  H.Html ->   H.Html-generateHtmlIndex benchDir _pathToSourceRanges _costCentres = do+generateHtmlIndex benchDir logText timelineText sourceIndex =   H.docTypeHtml $ do-    headHtmlWithCss (benchDir </> "style.css") pageTitle-    H.h2 $ H.string pageTitle-    introductionIndex (T.pack benchDir)-    sourceFileIndex benchDir (M.keysSet _pathToSourceRanges)-  where-    pageTitle = "Source File Index"+    headHtmlWithCss (benchDir </> "style.css") "Profiling Report"+    H.body $ H.main $ do+      H.h1 "Profiling Report"+      H.nav $ H.ul $ do+        H.li $ H.a ! A.href "#log" $ "Log"+        H.li $ H.a ! A.href "#timeline" $ "Timeline"+        H.li $ H.a ! A.href "#sources" $ "Source information"+      H.section ! A.id "log" $ do+        H.h2 "Log"+        H.p "The running log produced during execution."+        maybe+          (H.p "No log recorded.")+          ((H.pre ! A.id "log-text") . H.code . H.text)+          logText+      H.section ! A.id "timeline" $ do+        H.h2 "Timeline"+        H.p "Recorded events in order, with durations in microseconds."+        maybe+          (H.p "No profiling information recorded.")+          ((H.pre ! A.id "timeline-text") . H.code . H.text)+          timelineText+      H.section ! A.id "sources" $ do+        H.h2 "Source information"+        sourceIndex++-- | Navigation to the successfully generated source and cost centre pages.+generateSourceIndex :: FilePath -> M.Map FilePath SourceRanges -> H.Html+generateSourceIndex benchDir pathToSourceRanges = do+  introductionIndex (T.pack benchDir)+  sourceFileIndex benchDir (M.keysSet pathToSourceRanges)  introductionIndex :: T.Text -> H.Html introductionIndex benchDir = do
− src/Futhark/Script.hs 
@@ -1,831 +0,0 @@--- | FutharkScript is a (tiny) subset of Futhark used to write small--- expressions that are evaluated by server executables.  The @futhark--- literate@ command is the main user.-module Futhark.Script-  ( -- * Server-    ScriptServer (scriptServer),-    withScriptServer,-    withScriptServer',--    -- * Expressions, values, and types-    Func (..),-    Exp (..),-    parseExp,-    parseExpFromText,-    varsInExp,-    ScriptValueType (..),-    ScriptValue (..),-    scriptValueType,-    serverVarsInValue,-    ValOrVar (..),-    ExpValue,-    valToExpValue,-    storeExpValue,-    isScriptTuple,-    project,--    -- * Evaluation-    EvalBuiltin,-    scriptBuiltin,-    evalExp,-    getExpValue,-    getHaskellValue,-    evalExpToGround,-    valueToExp,-    freeValue,-  )-where--import Control.Monad-import Control.Monad.Except (MonadError (..))-import Control.Monad.IO.Class (MonadIO, liftIO)-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 (find, intersperse)-import Data.Map qualified as M-import Data.Set qualified as S-import Data.Text qualified as T-import Data.Traversable-import Data.Vector.Storable qualified as SVec-import Data.Void-import Data.Word (Word8)-import Futhark.Data.Parser qualified as V-import Futhark.Server hiding (Record)-import Futhark.Server.Values (getValue, putValue)-import Futhark.Test.Values qualified as V-import Futhark.Util (nubOrd)-import Futhark.Util.Pretty hiding (line, sep, space, (</>))-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 [Field])--typeMap :: (MonadIO m) => Server -> m TypeMap-typeMap server = do-  liftIO $ either (pure mempty) onTypes =<< cmdTypes server-  where-    onTypes types = M.fromList . zip types <$> mapM onType types-    onType t =-      either (const Nothing) Just <$> cmdFields server t--isRecord :: TypeName -> TypeMap -> Maybe [Field]-isRecord t m = join $ M.lookup t m--isTuple :: TypeName -> TypeMap -> Maybe [TypeName]-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.-data ScriptServer = ScriptServer-  { scriptServer :: Server,-    scriptCounter :: IORef Int,-    scriptTypes :: TypeMap,-    scriptVars :: IORef [VarName]-  }---- | Run an action with a 'ScriptServer' produced by an existing--- 'Server', without shutting it down at the end.-withScriptServer' :: (MonadIO m) => Server -> (ScriptServer -> m a) -> m a-withScriptServer' server f = do-  counter <- liftIO $ newIORef 0-  vars <- liftIO $ newIORef []-  types <- typeMap server-  f $ ScriptServer server counter types vars---- | Start a server, execute an action, then shut down the server.--- Similar to 'withServer'.-withScriptServer :: ServerCfg -> (ScriptServer -> IO a) -> IO a-withScriptServer cfg f =-  withServer cfg $ flip withScriptServer' f---- | A function called in a 'Call' expression can be either a Futhark--- function or a builtin function.-data Func = FuncFut EntryName | FuncBuiltin T.Text-  deriving (Show)---- | A FutharkScript expression.  This is a simple AST that might not--- correspond exactly to what the user wrote (e.g. no parentheses or--- source locations).  This is fine for small expressions, which is--- all this is meant for.-data Exp-  = Call Func [Exp]-  | Const V.Value-  | 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-    -- handled in 'Call').-    ServerVar TypeName VarName-  deriving (Show)--instance Pretty Func where-  pretty (FuncFut f) = pretty f-  pretty (FuncBuiltin f) = "$" <> pretty f--instance Pretty Exp where-  pretty = pprPrec (0 :: Int)-    where-      pprPrec _ (ServerVar _ v) = "$" <> pretty v-      pprPrec _ (Const v) = stack $ map pretty $ T.lines $ V.valueText v-      pprPrec i (Let pat e1 e2) =-        parensIf (i > 0) $ "let" <+> pat' <+> equals <+> pretty e1 <+> "in" <+> pretty e2-        where-          pat' = case pat of-            [x] -> pretty x-            _ -> parens $ align $ commasep $ map pretty pat-      pprPrec _ (Call v []) = pretty v-      pprPrec i (Call v args) =-        parensIf (i > 0) $ pretty v <+> hsep (map (align . pprPrec 1) args)-      pprPrec _ (Tuple vs) =-        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-          field (k, v) = align (pretty k <> equals <> pretty v)--type Parser = Parsec Void T.Text--lexeme :: Parser () -> Parser a -> Parser a-lexeme sep p = p <* sep--inParens :: Parser () -> Parser a -> Parser a-inParens sep = between (lexeme sep "(") (lexeme sep ")")--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-    ]-    <?> "expression"-  where-    pField = (,) <$> lVarName <*> (pEquals *> parseExp sep)-    pEquals = lexeme sep "="-    pComma = lexeme sep ","-    mkTuple [v] = v-    mkTuple vs = Tuple vs--    pLet =-      lexeme sep "let"-        $> Let-        <*> pPat-        <* lexeme sep "="-        <*> parseExp sep-        <*> choice-          [ lexeme sep "in" *> parseExp sep,-            pLet-          ]--    pProject e =-      choice-        [ lexeme sep "." *> (pFieldName >>= pProject . Project e),-          pure e-        ]--    pAtom =-      choice-        [ try $ inParens sep (mkTuple <$> (parseExp sep `sepEndBy` pComma)),-          inParens sep $ parseExp sep,-          inBraces sep (Record <$> (pField `sepEndBy` pComma)),-          StringLit . T.pack <$> lexeme sep ("\"" *> manyTill charLiteral "\""),-          Const <$> V.parseValue sep,-          Call <$> pFunc <*> pure []-        ]-        >>= pProject--    pPat =-      choice-        [ inParens sep $ lVarName `sepEndBy` pComma,-          pure <$> lVarName-        ]--    pFunc =-      choice-        [ FuncBuiltin <$> ("$" *> lVarName),-          FuncFut <$> lVarName-        ]--    pIndex =-      Index-        <$> (Call . FuncFut <$> rawVarName <*> pure [])-        <*> inBrackets sep (parseExp sep `sepEndBy` pComma)--    reserved = ["let", "in"]--    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---- | Parse a FutharkScript expression with normal whitespace handling.-parseExpFromText :: FilePath -> T.Text -> Either T.Text Exp-parseExpFromText f s =-  either (Left . T.pack . errorBundlePretty) Right $ parse (parseExp space <* eof) f s--readVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> m V.Value-readVar server v =-  either throwError pure =<< liftIO (getValue server v)--writeVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> V.Value -> m ()-writeVar server v val =-  cmdMaybe $ liftIO (putValue server v val)---- | A ScriptValue is either a base value or a partially applied--- function.  We don't have real first-class functions in--- FutharkScript, but we sort of have closures.-data ScriptValue v-  = SValue TypeName v-  | -- | Ins, then out.  Yes, this is the opposite of more or less-    -- everywhere else.-    SFun EntryName [TypeName] TypeName [ScriptValue v]-  deriving (Show)--instance Functor ScriptValue where-  fmap = fmapDefault--instance Foldable ScriptValue where-  foldMap = foldMapDefault--instance Traversable ScriptValue where-  traverse f (SValue t v) = SValue t <$> f v-  traverse f (SFun fname ins outs vs) =-    SFun fname ins outs <$> traverse (traverse f) vs---- | The type of a 'ScriptValue' - either a value type or a function type.-data ScriptValueType-  = STValue TypeName-  | -- | Ins, then out.-    STFun [TypeName] TypeName-  deriving (Eq, Show)--instance Pretty ScriptValueType where-  pretty (STValue t) = pretty t-  pretty (STFun ins out) =-    hsep $ intersperse "->" (map pretty ins ++ [pretty out])---- | A Haskell-level value or a variable on the server.-data ValOrVar = VVal V.Value | VVar VarName-  deriving (Show)---- | The intermediate values produced by an expression - in--- particular, these may not be on the server.-type ExpValue = V.Compound (ScriptValue ValOrVar)---- | Turn a purely manifested value into an 'ExpValue'.-valToExpValue :: V.CompoundValue -> ExpValue-valToExpValue = fmap $ \v ->-  SValue (V.valueTypeTextNoDims (V.valueType v)) $ VVal v---- | The type of a 'ScriptValue'.-scriptValueType :: ScriptValue v -> ScriptValueType-scriptValueType (SValue t _) = STValue t-scriptValueType (SFun _ ins out _) = STFun ins out---- | The set of server-side variables in the value.-serverVarsInValue :: ExpValue -> S.Set VarName-serverVarsInValue = S.fromList . concatMap isVar-  where-    isVar (SValue _ (VVar x)) = [x]-    isVar (SValue _ (VVal _)) = []-    isVar (SFun _ _ _ closure) = concatMap isVar closure---- | Convert a value into a corresponding expression.-valueToExp :: ExpValue -> Exp-valueToExp (V.ValueAtom (SValue t (VVar v))) =-  ServerVar t v-valueToExp (V.ValueAtom (SValue _ (VVal v))) =-  Const v-valueToExp (V.ValueAtom (SFun fname _ _ closure)) =-  Call (FuncFut fname) $ map (valueToExp . V.ValueAtom) closure-valueToExp (V.ValueRecord fs) =-  Record $ M.toList $ M.map valueToExp fs-valueToExp (V.ValueTuple fs) =-  Tuple $ map valueToExp fs---- Decompose a type name into a rank and an element type.-parseTypeName :: TypeName -> Maybe (Int, V.PrimType)-parseTypeName s-  | Just pt <- lookup s m =-      Just (0, pt)-  | "[]" `T.isPrefixOf` s = do-      (d, pt) <- parseTypeName (T.drop 2 s)-      pure (d + 1, pt)-  | otherwise = Nothing-  where-    prims = [minBound .. maxBound]-    primtexts = map (V.valueTypeText . V.ValueType []) prims-    m = zip primtexts prims--coerceValue :: TypeName -> V.Value -> Maybe V.Value-coerceValue t v = do-  (_, pt) <- parseTypeName t-  case v of-    V.I8Value shape vs ->-      coerceInts pt shape $ map toInteger $ SVec.toList vs-    V.I16Value shape vs ->-      coerceInts pt shape $ map toInteger $ SVec.toList vs-    V.I32Value shape vs ->-      coerceInts pt shape $ map toInteger $ SVec.toList vs-    V.I64Value shape vs ->-      coerceInts pt shape $ map toInteger $ SVec.toList vs-    _ ->-      Nothing-  where-    coerceInts V.I8 shape =-      Just . V.I8Value shape . SVec.fromList . map fromInteger-    coerceInts V.I16 shape =-      Just . V.I16Value shape . SVec.fromList . map fromInteger-    coerceInts V.I32 shape =-      Just . V.I32Value shape . SVec.fromList . map fromInteger-    coerceInts V.I64 shape =-      Just . V.I64Value shape . SVec.fromList . map fromInteger-    coerceInts V.F32 shape =-      Just . V.F32Value shape . SVec.fromList . map fromInteger-    coerceInts V.F64 shape =-      Just . V.F64Value shape . SVec.fromList . map fromInteger-    coerceInts _ _ =-      const Nothing---- | Store the provided value to the specified file. Fails if `ExpValue` is not--- either a primitive or a single variable stored on the server. TODO: make this--- handle arbitrary values.-storeExpValue ::-  (MonadIO m, MonadError T.Text m) =>-  ScriptServer ->-  FilePath ->-  ExpValue ->-  m ()-storeExpValue server path (V.ValueAtom (SValue _ v)) = do-  case v of-    VVal vv' ->-      liftIO $ LBS.writeFile path $ Bin.encode vv'-    VVar vv' ->-      cmdMaybe $ cmdStore (scriptServer server) path [vv']-storeExpValue _ _ v =-  throwError $-    "Cannot store value of type " <> prettyText (fmap scriptValueType v)---- | How to evaluate a builtin function.-type EvalBuiltin m = ScriptServer -> T.Text -> [ExpValue] -> m ExpValue--loadData ::-  (MonadIO m, MonadError T.Text m) =>-  FilePath ->-  m ExpValue-loadData datafile = do-  contents <- liftIO $ LBS.readFile datafile-  let maybe_vs = V.readValues contents-  case maybe_vs of-    Nothing ->-      throwError $ "Failed to read data file " <> T.pack datafile-    Just [v] ->-      pure $ valToExpValue $ V.ValueAtom v-    Just vs ->-      pure $ valToExpValue $ V.ValueTuple $ map V.ValueAtom vs--wrongArguments ::-  (MonadError T.Text m) => T.Text -> [ExpValue] -> m a-wrongArguments fname vs =-  throwError $-    "$"-      <> fname-      <> " does not accept arguments of types: "-      <> T.intercalate ", " (map (prettyText . fmap scriptValueType) vs)--pathArg ::-  (MonadIO m, MonadError T.Text m) =>-  FilePath ->-  ScriptServer ->-  T.Text ->-  [ExpValue] ->-  m FilePath-pathArg dir server cmd vs@[v] = do-  v' <- getHaskellValue server v-  case v' of-    Just path ->-      pure $ dir </> map (chr . fromIntegral) (path :: [Word8])-    _ ->-      wrongArguments cmd vs-pathArg _ _ cmd vs =-  wrongArguments cmd vs--newVar :: (MonadIO m) => ScriptServer -> T.Text -> m T.Text-newVar server base = liftIO $ do-  x <- readIORef counter-  modifyIORef counter (+ 1)-  let v = base <> prettyText x-  modifyIORef vars (v :)-  pure v-  where-    vars = scriptVars server-    counter = scriptCounter server---- | Handles the following builtin functions: @loaddata@, @loadbytes@.--- Fails for everything else. The 'FilePath' indicates the directory--- that files should be read relative to.-scriptBuiltin :: (MonadIO m, MonadError T.Text m) => FilePath -> EvalBuiltin m-scriptBuiltin dir server "loaddata" vs =-  loadData =<< pathArg dir server "loaddata" vs-scriptBuiltin dir server "loadbytes" vs =-  fmap (V.ValueAtom . SValue "[]u8" . VVal . V.putValue1) . liftIO . BS.readFile-    =<< pathArg dir server "loadbytes" vs-scriptBuiltin dir server "restore" vs-  | [tv, fv] <- vs = do-      tv' <- getHaskellValue server tv-      fv' <- getHaskellValue server fv-      case (tv', fv') of-        (Just tname, Just fname) -> do-          let tname' = T.pack $ map (chr . fromIntegral) (tname :: [Word8])-              fname' = dir </> map (chr . fromIntegral) (fname :: [Word8])-          v <- newVar server "restore"-          cmdMaybe $ cmdRestore (scriptServer server) fname' [(v, tname')]-          pure $ V.ValueAtom $ SValue tname' $ VVar v-        _ ->-          wrongArguments "restore" vs-  | otherwise =-      wrongArguments "restore" vs-scriptBuiltin _ _ f _ =-  throwError $ "Unknown builtin function $" <> prettyText f---- | Symbol table used for local variable lookups during expression evaluation.-type VTable = M.Map VarName ExpValue--cannotApply ::-  (MonadError T.Text m, Pretty a, Pretty b) =>-  T.Text ->-  [a] ->-  [b] ->-  m c-cannotApply fname expected actual =-  throwError $-    "Function \""-      <> fname-      <> "\" expects "-      <> prettyText (length expected)-      <> " argument(s) of types:\n"-      <> T.intercalate "\n" (map prettyTextOneLine expected)-      <> "\nBut applied to "-      <> prettyText (length actual)-      <> " argument(s) of types:\n"-      <> T.intercalate "\n" (map prettyTextOneLine actual)--getField ::-  (MonadIO m, MonadError T.Text m) =>-  ScriptServer ->-  VarName ->-  Field ->-  m VarName-getField server from (Field f _) = do-  to <- newVar server "field"-  cmdMaybe $ cmdProject (scriptServer server) to from f-  pure to---- | Is this a server-side tuple? If so, return the element types.-isScriptTuple :: ScriptServer -> TypeName -> Maybe [TypeName]-isScriptTuple server t =-  isTuple t $ scriptTypes server---- | If a tuple, produce a monadic action that can retrieve its elements.-tupleElements ::-  (MonadIO m, MonadError T.Text m) =>-  ScriptServer -> ExpValue -> Maybe (m [ExpValue])-tupleElements _ (V.ValueTuple vs) = pure $ pure vs-tupleElements server (V.ValueAtom (SValue t (VVar v)))-  | Just ts <- isTuple t $ scriptTypes server =-      Just $ forM (zip tupleFieldNames ts) $ \(k, kt) ->-        V.ValueAtom . SValue kt . VVar <$> getField server v (Field (nameToText k) kt)-tupleElements _ _ = Nothing---- | If a tuple value, convert it to its components.-unTuple ::-  (MonadIO m, MonadError T.Text m) =>-  ScriptServer ->-  ExpValue ->-  m [ExpValue]-unTuple server v-  | Just m <- tupleElements server v = m-unTuple _ v = pure [v]---- | Extract field from record.-project ::-  (MonadIO m, MonadError T.Text m) =>-  ScriptServer ->-  ExpValue ->-  T.Text ->-  m ExpValue-project _ (V.ValueRecord fs) k =-  case M.lookup k fs of-    Nothing -> throwError $ "Unknown field: " <> k-    Just v -> pure v-project server (V.ValueAtom (SValue t (VVar v))) f-  | Just fs <- isRecord t $ scriptTypes server =-      case find ((== f) . fieldName) fs of-        Nothing -> throwError $ "Type " <> t <> " does not have a field " <> 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.-  (MonadError T.Text m, MonadIO m) =>-  EvalBuiltin m ->-  ScriptServer ->-  Exp ->-  m ExpValue-evalExp builtin sserver top_level_e = do-  let ( ScriptServer-          { scriptServer = server,-            scriptTypes = types,-            scriptVars = vars-          }-        ) = sserver-  old_vars <- liftIO $ readIORef vars-  let newVar' = newVar sserver--      mkRecord t vs = do-        v <- newVar' "record"-        cmdMaybe $ cmdNew server v t vs-        pure v--      toVar :: ValOrVar -> m VarName-      toVar (VVar v) = pure v-      toVar (VVal val) = do-        v <- newVar' "const"-        writeVar server v val-        pure v--      scriptValueToValOrVar (SFun f _ _ _) =-        throwError $ "Function " <> f <> " not fully applied."-      scriptValueToValOrVar (SValue _ v) =-        pure v--      scriptValueToVar :: ScriptValue ValOrVar -> m VarName-      scriptValueToVar = toVar <=< scriptValueToValOrVar--      -- Apart from type checking, this function also converts-      -- FutharkScript tuples/records to Futhark-level tuples/records,-      -- as well as maps between different names for the same-      -- tuple/record.-      ---      -- We also implicitly convert the types of constants.-      interValToVar :: m VarName -> TypeName -> ExpValue -> m VarName-      interValToVar _ t (V.ValueAtom v)-        | STValue t == scriptValueType v = scriptValueToVar v-      interValToVar bad t (V.ValueTuple vs)-        | Just ts <- isTuple t types,-          length vs == length ts =-            mkRecord t =<< zipWithM (interValToVar bad) ts vs-      interValToVar bad t (V.ValueRecord vs)-        | Just fs <- isRecord t types,-          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,-          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 =-            scriptValueToVar $ SValue t $ VVal v'-      interValToVar bad _ _ = bad--      letMatch :: [VarName] -> ExpValue -> m VTable-      letMatch vs val = do-        vals <- unTuple sserver val-        if length vs == length vs-          then-            pure $ M.fromList (zip vs vals)-          else-            throwError $-              "Pat: "-                <> prettyTextOneLine vs-                <> "\nDoes not match value of type: "-                <> prettyTextOneLine (fmap scriptValueType val)--      evalExp' :: VTable -> Exp -> m ExpValue-      evalExp' _ (ServerVar t v) =-        pure $ V.ValueAtom $ SValue t $ VVar v-      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)-        | Just e <- M.lookup name vtable = do-            unless (null es) $-              throwError $-                "Locally bound name cannot be invoked as a function: " <> prettyText name-            pure e-        | otherwise = do-            in_types <- fmap (map inputType) $ cmdEither $ cmdInputs server name-            out_type <- fmap outputType $ cmdEither $ cmdOutput server name--            es' <- mapM (evalExp' vtable) es--            let bad = cannotApply name in_types $ map (fmap scriptValueType) es'-                tryApply args = do-                  arg_types <- zipWithM (interValToVar bad) in_types args--                  if length in_types == length arg_types-                    then do-                      out <- newVar' "out"-                      void $ cmdEither $ cmdCall server name out arg_types-                      pure . V.ValueAtom $ SValue out_type $ VVar out-                    else-                      pure . V.ValueAtom . SFun name in_types out_type $-                        zipWith SValue in_types (map VVar arg_types)--            -- Careful to not require saturated application, but do still-            -- check for over-saturation.-            when (length es > length in_types) bad--            -- Allow automatic uncurrying if applicable.-            case es' of-              [V.ValueTuple es'']-                | length es'' == length in_types -> tryApply es''-              _ -> tryApply es'-      evalExp' _ (StringLit s) =-        case V.putValue s of-          Just s' ->-            pure $ V.ValueAtom $ SValue (V.valueTypeTextNoDims (V.valueType s')) $ VVal s'-          Nothing -> error $ "Unable to write value " ++ prettyString s-      evalExp' _ (Const val) =-        pure $ V.ValueAtom $ SValue (V.valueTypeTextNoDims (V.valueType val)) $ VVal val-      evalExp' vtable (Tuple es) =-        V.ValueTuple <$> mapM (evalExp' vtable) es-      evalExp' vtable e@(Record m) = do-        when (length (nubOrd (map fst m)) /= length (map fst m)) $-          throwError $-            "Record " <> prettyText e <> " has duplicate fields."-        V.ValueRecord <$> traverse (evalExp' vtable) (M.fromList m)-      evalExp' vtable (Let pat e1 e2) = do-        v <- evalExp' vtable e1-        pat_vtable <- letMatch pat v-        evalExp' (pat_vtable <> vtable) e2--  let freeNonresultVars v = do-        let keep_vars = serverVarsInValue v <> S.fromList old_vars-        to_free <- liftIO $ filter (`S.notMember` keep_vars) <$> readIORef vars-        cmdMaybe $ cmdFree server to_free-        liftIO $ writeIORef vars $ S.toList keep_vars-        pure v-      freeVarsOnError e = do-        -- We are intentionally ignoring any errors produced by-        -- cmdFree, because we already have another error to-        -- propagate.  Also, not all of the variables that we put in-        -- 'vars' might actually exist server-side, if we failed in a-        -- Call.-        void $ liftIO $ cmdFree server =<< readIORef vars-        throwError e-  (freeNonresultVars =<< evalExp' mempty top_level_e) `catchError` freeVarsOnError--primArrayType :: TypeName -> Bool-primArrayType s = case fmap T.uncons <$> T.uncons s of-  Just ('[', Just (']', s')) -> primArrayType s'-  _ -> s `elem` ["i8", "u8", "i16", "u16", "i32", "u32", "i64", "u64", "f16", "f32", "f64", "bool"]---- | Read actual compound values from the server. Fails for values that have no--- well-defined external representation.-getExpValue ::-  (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m V.CompoundValue-getExpValue _ (V.ValueAtom (SFun fname _ _ _)) =-  throwError $ "Function " <> fname <> " not fully applied."-getExpValue server (V.ValueAtom (SValue t (VVar v)))-  | Just fs <- isRecord t types =-      tupleOrRecord . M.fromList . zip (map (nameFromText . fieldName) fs)-        <$> mapM (onField v) fs-  | not $ primArrayType t =-      throwError $ "Type " <> t <> " has no external representation."-  | otherwise =-      V.ValueAtom <$> readVar (scriptServer server) v-  where-    types = scriptTypes server--    tupleOrRecord m =-      maybe (V.ValueRecord $ M.mapKeys nameToText m) V.ValueTuple $ areTupleFields m--    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-getExpValue server (V.ValueRecord fs) =-  V.ValueRecord <$> traverse (getExpValue server) fs-getExpValue _ (V.ValueAtom (SValue _ (VVal v))) = pure $ V.ValueAtom v---- | Retrieve a Haskell value from an 'ExpValue'. This returns 'Just' if the--- 'ExpValue' is an atom with a non-opaque type.-getHaskellValue :: (V.GetValue t, MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m (Maybe t)-getHaskellValue server v = do-  v' <- getExpValue server v-  case v' of-    V.ValueAtom v'' ->-      pure $ V.getValue v''-    _ -> pure Nothing---- | Like 'evalExp', but requires all values to be non-functional.  If--- the value has a bad type, return that type instead.  Other--- evaluation problems (e.g. type failures) raise errors.-evalExpToGround ::-  (MonadError T.Text m, MonadIO m) =>-  EvalBuiltin m ->-  ScriptServer ->-  Exp ->-  m (Either (V.Compound ScriptValueType) V.CompoundValue)-evalExpToGround builtin server e = do-  v <- evalExp builtin server e-  -- This assumes that the only error that can occur during-  -- getExpValue is trying to read an opaque.-  (Right <$> getExpValue server v)-    `catchError` const (pure $ Left $ fmap scriptValueType v)---- | The set of Futhark variables that are referenced by the--- expression - these will have to be entry points in the Futhark--- program.-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-varsInExp (Record fs) = foldMap (foldMap varsInExp) fs-varsInExp Const {} = mempty-varsInExp StringLit {} = mempty-varsInExp (Let pat e1 e2) = varsInExp e1 <> S.filter (`notElem` pat) (varsInExp e2)---- | Release all the server-side variables in the value.  Yes,--- FutharkScript has manual memory management...-freeValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m ()-freeValue server =-  cmdMaybe . cmdFree (scriptServer server) . S.toList . serverVarsInValue
src/Futhark/Test.hs view
@@ -31,28 +31,59 @@ import Control.Exception (catch) import Control.Exception.Base qualified as E import Control.Monad-import Control.Monad.Except (MonadError (..), runExceptT)+import Control.Monad.Except (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)+import Control.Monad.Free.Church (F) import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Bifunctor (first) import Data.Binary qualified as Bin import Data.ByteString qualified as SBS import Data.ByteString.Lazy qualified as BS import Data.Char+import Data.Either (fromRight) import Data.Map qualified as M import Data.Maybe-import Data.Set qualified as S import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T-import Futhark.Script qualified as Script+import Futhark.Compiler (readProgramFilesExceptKnown)+import Futhark.Error (prettyCompilerError)+import Futhark.Eval (externaliseLast, interpretImports, runInterpreterWith)+import Futhark.FreshNames (VNameSource) import Futhark.Server import Futhark.Server.Values+import Futhark.Test.Compile import Futhark.Test.Property import Futhark.Test.Spec import Futhark.Test.Values qualified as V-import Futhark.Util (ensureCacheDirectory, isEnvVarAtLeast, pmapIO, showText)-import Futhark.Util.Pretty (prettyText, prettyTextOneLine)-import Language.Futhark.Core (nameFromText, nameToText)-import Language.Futhark.Tuple (areTupleFields, tupleFieldNames)+import Futhark.Util (ensureCacheDirectory, nubOrd, pmapIO, showText)+import Futhark.Util.Pretty (docText, prettyText, prettyTextOneLine)+import Language.Futhark+  ( DecBase (..),+    EntryParam (..),+    EntryPoint (..),+    EntryType (..),+    Exp,+    Info (..),+    Name,+    ProgBase (..),+    StructType,+    UncheckedExp,+    ValBindBase (..),+    baseName,+    isTupleRecord,+    nameToText,+    noSizes,+    typeOf,+  )+import Language.Futhark.Core (nameFromText)+import Language.Futhark.Interpreter qualified as I+import Language.Futhark.Interpreter.FFI.Push qualified as FFI+import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI+import Language.Futhark.Interpreter.Values qualified as IV+import Language.Futhark.Parser (SyntaxError (..), parseExp)+import Language.Futhark.Semantic (Env, FileModule (..), Imports)+import Language.Futhark.Tuple (areTupleFields)+import Language.Futhark.TypeChecker (checkExp, prettyTypeError) import System.Directory import System.Exit import System.FilePath@@ -68,12 +99,6 @@ valuesFromByteString srcname =   maybe (Left $ "Cannot parse values from '" ++ srcname ++ "'") Right . V.readValues --- | The @futhark@ executable we are using.  This is merely a wrapper--- around the underlying file path, because we will be using a lot of--- different file paths here, and it is easy to mix them up.-newtype FutharkExe = FutharkExe FilePath-  deriving (Eq, Ord, Show)- -- | Get the actual core Futhark values corresponding to a 'Values' -- specification.  The first 'FilePath' is the path of the @futhark@ -- executable, and the second is the directory which file paths are@@ -88,7 +113,7 @@   where     fileName Values {} = "<values>"     fileName GenValues {} = "<randomly generated>"-    fileName ScriptValues {} = "<FutharkScript expression>"+    fileName ScriptValues {} = "<script expression>"     fileName (InFile f) = f     fileName (ScriptFile f) = f @@ -117,132 +142,179 @@   mconcat <$> mapM (getGenBS futhark dir) gens getValuesBS _ _ (ScriptValues e) =   fail $-    "Cannot get values from FutharkScript expression: "+    "Cannot get values from script expression: "       <> T.unpack (prettyTextOneLine e) getValuesBS _ _ (ScriptFile f) =-  fail $ "Cannot get values from FutharkScript file: " <> f+  fail $ "Cannot get values from script file: " <> f -valueAsVar ::-  (MonadError T.Text m, MonadIO m) =>-  Server ->-  VarName ->-  V.Value ->-  m ()-valueAsVar server v val =-  cmdMaybe $ putValue server v val+-- | Run an interpreter action that produces test input. Calls to entry points+-- are dispatched to the server, files are read relative to the given directory,+-- and traces and breakpoints are ignored.+runScript :: FFI.Server -> FilePath -> F I.ExtOp a -> IO (Either I.InterpreterError a)+runScript server dir = runInterpreterWith (const $ pure ()) (Just server) (Just dir) --- Frees the expression on error.-scriptValueAsVars ::-  (MonadError T.Text m, MonadIO m) =>-  Script.ScriptServer ->-  [(VarName, TypeName)] ->-  Script.ExpValue ->-  m ()-scriptValueAsVars server names_and_types val-  | vals <- V.unCompound val,-    length names_and_types == length vals,-    Just loads <- zipWithM f names_and_types vals =-      sequence_ loads-  where-    f (v, t0) (V.ValueAtom (Script.SValue t1 sval))-      | t0 == t1 =-          Just $ case sval of-            Script.VVar oldname ->-              cmdMaybe $ cmdRename (Script.scriptServer server) oldname v-            Script.VVal sval' ->-              valueAsVar (Script.scriptServer server) v sval'-    f _ _ = Nothing-scriptValueAsVars server names_and_types val-  | V.ValueAtom (Script.SValue t (Script.VVar vv)) <- val,-    Just ts <- Script.isScriptTuple server t,-    ts == map snd names_and_types = do-      forM_ (zip (map fst names_and_types) tupleFieldNames) $ \(v, k) ->-        cmdMaybe $ cmdProject (Script.scriptServer server) v vv (nameToText k)-      cmdMaybe $ cmdFree (Script.scriptServer server) $ S.toList $ Script.serverVarsInValue val-scriptValueAsVars server names_and_types val = do-  cmdMaybe $ cmdFree (Script.scriptServer server) $ S.toList $ Script.serverVarsInValue val-  throwError $-    "Expected value of type: "-      <> showText names_and_types -- prettyTextOneLine (V.mkCompound (map (V.ValueAtom . snd) names_and_types))-      <> "\nBut got value of type:  "-      <> showText val -- prettyTextOneLine (fmap Script.scriptValueType val)-      <> notes+-- | The entry points of the program (the last import).+programEntryPoints :: Imports -> M.Map Name EntryPoint+programEntryPoints imports =+  M.fromList+    [ (baseName $ valBindName vb, ep)+    | ValDec vb <- map unLocal $ progDecs $ fileProg $ snd $ last imports,+      Just (Info ep) <- [valBindEntryPoint vb]+    ]   where-    notes = mconcat $ mapMaybe note names_and_types-    note (_, t)-      | "(" `T.isPrefixOf` t =-          Just $-            "\nNote: expected type "-              <> prettyText t-              <> " is an opaque tuple that cannot be constructed\n"-              <> "in FutharkScript.  Consider using type annotations to give it a proper name."-      | "{" `T.isPrefixOf` t =-          Just $-            "\nNote: expected type "-              <> prettyText t-              <> " is an opaque record that cannot be constructed\n"-              <> "in FutharkScript.  Consider using type annotations to give it a proper name."-      | otherwise =-          Nothing+    unLocal (LocalDec dec _) = unLocal dec+    unLocal dec = dec --- | Make the provided 'Values' available as server-side variables.--- This may involve arbitrary server-side computation.  Error--- detection... dubious.+-- | Read, type check and interpret the program, with its entry points run on+-- the server. Produces what is needed to type check and evaluate script+-- expressions in the context of the program, as well as the parameter types of+-- the given entry point.+scriptContext ::+  FFI.Server ->+  FilePath ->+  Name ->+  ExceptT T.Text IO (VNameSource, Env, I.Ctx, [StructType])+scriptContext server prog entry = do+  (_, imports, src) <-+    withExceptT (docText . prettyCompilerError) $+      readProgramFilesExceptKnown [] mempty [prog]+  (scope, ctx) <-+    withExceptT docText . interpretImports (runScript server $ takeDirectory prog) $+      externaliseLast imports+  ep <-+    maybe (throwError $ "Unknown entry point: " <> nameToText entry) pure $+      M.lookup entry $+        programEntryPoints imports+  pure (src, scope, ctx, map (entryType . entryParamType) $ entryParams ep)++-- | Split the result of a script expression into the inputs of an entry point+-- with these parameters: a tuple with an element for each, unless there is only+-- one.+splitInputs :: [p] -> (a -> Maybe [a]) -> a -> Maybe [a]+splitInputs [_] _ x = Just [x]+splitInputs _ untuple x = untuple x++-- | Type check a script expression, which must provide the inputs of an entry+-- point with these parameter types.+checkScriptExp :: VNameSource -> Env -> [StructType] -> UncheckedExp -> Either T.Text Exp+checkScriptExp src scope param_ts e =+  case checkExp [] src scope e of+    (_, Left terr) ->+      Left $ docText $ prettyTypeError terr+    (_, Right (_ : _, fexp)) ->+      Left $ "Ambiguous type of expression: " <> prettyText (typeOf fexp)+    (_, Right ([], fexp))+      | (map noSizes <$> splitInputs param_ts isTupleRecord t) == Just (map noSizes param_ts) ->+          Right fexp+      | otherwise ->+          Left . T.unlines $+            [ "Expected input of types: " <> T.unwords (map (prettyTextOneLine . noSizes) param_ts),+              "Provided input of type: " <> prettyTextOneLine (noSizes t)+            ]+      where+        t = typeOf fexp++-- | Evaluate a script expression with the interpreter, and make the result+-- available as server-side variables for the inputs of the given entry point.+-- If the entry point has more than one parameter, the value must be a tuple+-- with an element for each. The expression is evaluated in the context of the+-- program, with its entry points run on the server. Returns the variable of+-- each input, taken from the given names: one per input, except that inputs+-- provided with the same server-side value share a variable, named after the+-- first of them.+scriptValuesAsVars ::+  (MonadError T.Text m, MonadIO m) =>+  Server ->+  EntryName ->+  [VarName] ->+  FilePath ->+  UncheckedExp ->+  m [VarName]+scriptValuesAsVars server entry names prog e = do+  ffi_server <- liftIO $ FFI.newServer server+  let entry' = nameFromText entry+      onServer = fmap (first T.pack) . FFI.runServerM ffi_server+  r <- liftIO . runExceptT $ do+    (src, scope, ctx, param_ts) <- scriptContext ffi_server prog entry'+    fexp <- liftEither $ checkScriptExp src scope param_ts e+    v <-+      withExceptT (docText . I.prettyInterpreterError) . ExceptT $+        runScript ffi_server (takeDirectory prog) (I.interpretExp ctx fexp)+    -- The type check ensures that the value can be split.+    ExceptT . onServer . FFI.putArgs entry' . fromMaybe [] $+      splitInputs param_ts IV.fromTuple v+  -- Anything not adopted as an input is garbage, now that the interpreter is+  -- done - and if something failed, that is everything.+  released <- liftIO . onServer . FFI.release $ zip (fromRight [] r) names+  liftEither $ r *> released++-- | Make the provided 'Values' available as server-side variables, for use+-- as the inputs of the given entry point, and return the variable of each+-- input. These are the given names, except that several inputs may share a+-- variable (see 'scriptValuesAsVars').  This may involve arbitrary+-- server-side computation.  Error detection... dubious.  The 'FilePath' is+-- the program, relative to which other file paths are read. valuesAsVars ::   (MonadError T.Text m, MonadIO m) =>   Server ->+  EntryName ->   [(VarName, TypeName)] ->   FutharkExe ->   FilePath ->   Values ->-  m ()-valuesAsVars server names_and_types _ dir (InFile file)-  | takeExtension file == ".gz" = do-      s <- liftIO $ readAndDecompress $ dir </> file-      case s of-        Left e ->-          throwError $ showText file <> ": " <> showText e-        Right s' ->-          cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do-            BS.hPutStr tmpf_h s'-            hClose tmpf_h-            cmdRestore server tmpf names_and_types-  | otherwise =-      cmdMaybe $ cmdRestore server (dir </> file) names_and_types-valuesAsVars server names_and_types futhark dir (GenValues gens) = do-  unless (length gens == length names_and_types) . throwError . T.unlines $-    [ "Expected "-        <> showText (length names_and_types)-        <> " input values of types",-      "  " <> T.unwords (map snd names_and_types),-      "Provided "-        <> showText (length gens)-        <> " input values of types",-      "  " <> T.unwords (map genValueType gens)-    ]-  gen_fs <- mapM (getGenFile futhark dir) gens-  forM_ (zip gen_fs names_and_types) $ \(file, (v, t)) ->-    cmdMaybe $ cmdRestore server (dir </> file) [(v, t)]-valuesAsVars server names_and_types _ _ (Values vs) = do-  let types = map snd names_and_types-      vs_types = map (V.valueTypeTextNoDims . V.valueType) vs-  unless (types == vs_types) . throwError . T.unlines $-    [ "Expected input of types: " <> T.unwords (map prettyTextOneLine types),-      "Provided input of types: " <> T.unwords (map prettyTextOneLine vs_types)-    ]-  cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do-    mapM_ (BS.hPutStr tmpf_h . Bin.encode) vs-    hClose tmpf_h-    cmdRestore server tmpf names_and_types-valuesAsVars server names_and_types _ dir (ScriptValues e) =-  Script.withScriptServer' server $ \server' -> do-    e_v <- Script.evalExp (Script.scriptBuiltin dir) server' e-    scriptValueAsVars server' names_and_types e_v-valuesAsVars server names_and_types futhark dir (ScriptFile f) = do-  e <--    either throwError pure . Script.parseExpFromText f-      =<< liftIO (T.readFile (dir </> f))-  valuesAsVars server names_and_types futhark dir (ScriptValues e)+  m [VarName]+valuesAsVars server entry names_and_types futhark prog values =+  case values of+    InFile file+      | takeExtension file == ".gz" -> do+          s <- liftIO $ readAndDecompress $ dir </> file+          case s of+            Left e -> throwError $ showText file <> ": " <> showText e+            Right s' -> restoreBytes s'+          pure names+      | otherwise -> do+          cmdMaybe $ cmdRestore server (dir </> file) names_and_types+          pure names+    GenValues gens -> do+      unless (length gens == length names_and_types) . throwError . T.unlines $+        [ "Expected "+            <> showText (length names_and_types)+            <> " input values of types",+          "  " <> T.unwords (map snd names_and_types),+          "Provided "+            <> showText (length gens)+            <> " input values of types",+          "  " <> T.unwords (map genValueType gens)+        ]+      gen_fs <- mapM (getGenFile futhark dir) gens+      forM_ (zip gen_fs names_and_types) $ \(file, (v, t)) ->+        cmdMaybe $ cmdRestore server (dir </> file) [(v, t)]+      pure names+    Values vs -> do+      let types = map snd names_and_types+          vs_types = map (V.valueTypeTextNoDims . V.valueType) vs+      unless (types == vs_types) . throwError . T.unlines $+        [ "Expected input of types: " <> T.unwords (map prettyTextOneLine types),+          "Provided input of types: " <> T.unwords (map prettyTextOneLine vs_types)+        ]+      restoreBytes $ mconcat $ map Bin.encode vs+      pure names+    ScriptValues e ->+      scriptValuesAsVars server entry names prog e+    ScriptFile f -> do+      let f' = dir </> f+      e <-+        either (\(SyntaxError _ err) -> throwError err) pure . parseExp f'+          =<< liftIO (T.readFile f')+      scriptValuesAsVars server entry names prog e+  where+    dir = takeDirectory prog+    names = map fst names_and_types+    restoreBytes bytes =+      cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do+        BS.hPutStr tmpf_h bytes+        hClose tmpf_h+        cmdRestore server tmpf names_and_types  -- | There is a risk of race conditions when multiple programs have -- identical 'GenValues'.  In such cases, multiple threads in 'futhark@@ -354,33 +426,6 @@     RunTimeFailure err ->       pure $ RunTimeFailure err --- | The name we use for compiled programs.-binaryName :: FilePath -> FilePath-binaryName = dropExtension---- | @compileProgram extra_options futhark backend program@ compiles--- @program@ with the command @futhark backend extra-options...@, and--- returns stdout and stderr of the compiler.  Throws an IO exception--- containing stderr if compilation fails.-compileProgram ::-  (MonadIO m, MonadError T.Text m) =>-  [String] ->-  FutharkExe ->-  String ->-  FilePath ->-  m (SBS.ByteString, SBS.ByteString)-compileProgram extra_options (FutharkExe futhark) backend program = do-  (futcode, stdout, stderr) <- liftIO $ readProcessWithExitCode futhark (backend : options) ""-  case futcode of-    ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark-    ExitFailure _ -> throwError $ T.decodeUtf8 stderr-    ExitSuccess -> pure ()-  pure (stdout, stderr)-  where-    binOutputf = binaryName program-    options = [program, "-o", binOutputf] ++ extra_options-    progNotFound s = s <> ": command not found"- getValueM :: (MonadIO m, MonadError T.Text m) => Server -> VarName -> m V.Value getValueM server = either throwError pure <=< liftIO . getValue server @@ -446,12 +491,10 @@   let out = "out"       ins = ["in" <> showText i | i <- [0 .. length input_types - 1]]       ins_and_types = zip ins (map inputType input_types)-  valuesAsVars server ins_and_types futhark dir input-  _ <- cmdEither $ cmdCall server entry out ins-  cmdMaybe $ cmdFree server ins+  ins' <- valuesAsVars server entry ins_and_types futhark prog input+  _ <- cmdEither $ cmdCall server entry out ins'+  cmdMaybe $ cmdFree server $ nubOrd ins'   pure out-  where-    dir = takeDirectory prog  -- | Ensure that any reference output files exist, or create them (by -- compiling the program with the reference compiler and running it on@@ -542,11 +585,3 @@             else "\n...and " <> prettyText (length mismatches) <> " other mismatches."     [] ->       pure ()---- | Create a Futhark server configuration suitable for use when--- testing/benchmarking Futhark programs.-futharkServerCfg :: FilePath -> [String] -> ServerCfg-futharkServerCfg prog opts =-  (newServerCfg prog opts)-    { cfgDebug = isEnvVarAtLeast "FUTHARK_COMPILER_DEBUGGING" 1-    }
+ src/Futhark/Test/Compile.hs view
@@ -0,0 +1,62 @@+-- | Compiling Futhark programs and running them as servers, as needed for+-- testing and benchmarking, but also by anything else that runs compiled+-- programs.+module Futhark.Test.Compile+  ( FutharkExe (..),+    binaryName,+    compileProgram,+    futharkServerCfg,+  )+where++import Control.Monad.Except (MonadError (..))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString qualified as SBS+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Futhark.Server+import Futhark.Util (isEnvVarAtLeast)+import System.Exit+import System.FilePath+import System.Process.ByteString (readProcessWithExitCode)++-- | The @futhark@ executable we are using.  This is merely a wrapper+-- around the underlying file path, because we will be using a lot of+-- different file paths here, and it is easy to mix them up.+newtype FutharkExe = FutharkExe FilePath+  deriving (Eq, Ord, Show)++-- | The name we use for compiled programs.+binaryName :: FilePath -> FilePath+binaryName = dropExtension++-- | @compileProgram extra_options futhark backend program@ compiles+-- @program@ with the command @futhark backend extra-options...@, and+-- returns stdout and stderr of the compiler.  Throws an IO exception+-- containing stderr if compilation fails.+compileProgram ::+  (MonadIO m, MonadError T.Text m) =>+  [String] ->+  FutharkExe ->+  String ->+  FilePath ->+  m (SBS.ByteString, SBS.ByteString)+compileProgram extra_options (FutharkExe futhark) backend program = do+  (futcode, stdout, stderr) <- liftIO $ readProcessWithExitCode futhark (backend : options) ""+  case futcode of+    ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark+    ExitFailure _ -> throwError $ T.decodeUtf8 stderr+    ExitSuccess -> pure ()+  pure (stdout, stderr)+  where+    binOutputf = binaryName program+    options = [program, "-o", binOutputf] ++ extra_options+    progNotFound s = s <> ": command not found"++-- | Create a Futhark server configuration suitable for use when+-- testing/benchmarking Futhark programs.+futharkServerCfg :: FilePath -> [String] -> ServerCfg+futharkServerCfg prog opts =+  (newServerCfg prog opts)+    { cfgDebug = isEnvVarAtLeast "FUTHARK_COMPILER_DEBUGGING" 1+    }
src/Futhark/Test/Spec.hs view
@@ -20,6 +20,7 @@     Values (..),     GenValue (..),     genValueType,+    parseEmbeddedExp,   ) where @@ -38,10 +39,13 @@ import Futhark.Analysis.Metrics.Type import Futhark.Data.Parser import Futhark.Data.Parser qualified as V-import Futhark.Script qualified as Script import Futhark.Test.Values qualified as V import Futhark.Util (directoryContents, nubOrd, showText)+import Futhark.Util.Loc qualified as Loc import Futhark.Util.Pretty (prettyTextOneLine)+import Language.Futhark.Parser (SyntaxError (..), parseExpAt)+import Language.Futhark.Pretty ()+import Language.Futhark.Prop (UncheckedExp) import System.Exit import System.FilePath import System.IO@@ -126,8 +130,12 @@   = Values [V.Value]   | InFile FilePath   | GenValues [GenValue]-  | ScriptValues Script.Exp-  | ScriptFile FilePath+  | -- | A Futhark expression, evaluated by the interpreter in the+    -- context of the program, with calls to entry points run on the+    -- compiled program.+    ScriptValues UncheckedExp+  | -- | A file containing such an expression.+    ScriptFile FilePath   deriving (Show)  -- | How to generate a single random value.@@ -340,11 +348,59 @@ parseScriptValues :: Parser () -> Parser Values parseScriptValues sep =   choice-    [ ScriptValues <$> inBraces sep (Script.parseExp sep),+    [ ScriptValues <$> inBraces sep parseScriptExp,       ScriptFile . T.unpack <$> (lexeme sep "@" *> lexeme sep nextWord)     ]   where     nextWord = takeWhileP Nothing $ not . isSpace++-- | Parse a Futhark expression embedded in a comment block, consisting of the+-- text consumed by the given parser. We slice out that text and hand it to the+-- Futhark parser. This is somewhat clumsy because the Futhark parser is not+-- written with parser combinators.+parseEmbeddedExp :: Parser () -> Parser UncheckedExp+parseEmbeddedExp extent = do+  pos <- sourcePos+  s <- getInput+  bef <- getOffset+  extent+  aft <- getOffset+  -- To get the right source positions, we replace comment prefixes with spaces.+  case parseExpAt pos $ blankCommentPrefix $ T.take (aft - bef) s of+    Left (SyntaxError loc msg) -> do+      case loc of+        Loc.Loc start _ -> setOffset $ Loc.posCoff start+        Loc.NoLoc -> pure ()+      fail $ T.unpack $ T.strip msg+    Right e -> pure e++-- | The current position, in the form used by the Futhark parser.+sourcePos :: Parser Loc.Pos+sourcePos = do+  p <- getSourcePos+  Loc.Pos (sourceName p) (unPos (sourceLine p)) (unPos (sourceColumn p)) <$> getOffset++-- | A script expression extends to the matching closing brace. Braces inside+-- string literals are not counted.+parseScriptExp :: Parser UncheckedExp+parseScriptExp = parseEmbeddedExp balanced+  where+    balanced =+      skipMany $+        choice+          [ void $ takeWhile1P Nothing (`notElem` ("{}\"" :: String)),+            void $ char '"' *> manyTill charLiteral (char '"'),+            void $ char '{' *> balanced *> char '}'+          ]++-- | Replace the comment marker on every line but the first with spaces.+blankCommentPrefix :: T.Text -> T.Text+blankCommentPrefix s =+  case T.lines s of+    [] -> s+    l : ls -> T.intercalate "\n" $ l : map onLine ls+  where+    onLine l = maybe l ("  " <>) $ T.stripPrefix "--" l  parseRandomValues :: Parser () -> Parser Values parseRandomValues sep = GenValues <$> inBraces sep (many (parseGenValue sep))
src/Futhark/Test/Values.hs view
@@ -7,10 +7,6 @@   ( module Futhark.Data,     module Futhark.Data.Compare,     module Futhark.Data.Reader,-    Compound (..),-    CompoundValue,-    mkCompound,-    unCompound,      -- * Random value generation     Range,@@ -22,9 +18,6 @@  import Control.Monad.ST import Data.Int-import Data.Map qualified as M-import Data.Text qualified as T-import Data.Traversable import Data.Vector.Storable qualified as SVec import Data.Vector.Storable.Mutable qualified as USVec import Data.Word@@ -32,7 +25,7 @@ import Futhark.Data.Compare import Futhark.Data.Reader import Futhark.Util (convFloat)-import Futhark.Util.Pretty (Pretty (..), braces, commasep, equals, parens)+import Futhark.Util.Pretty (Pretty (..)) import Numeric.Half import System.Random.Stateful (UniformRange (..), mkStdGen, uniformR) @@ -41,49 +34,6 @@  instance Pretty ValueType where   pretty = pretty . valueTypeText---- | The structure of a compound value, parameterised over the actual--- values.  For most cases you probably want 'CompoundValue'.-data Compound v-  = ValueRecord (M.Map T.Text (Compound v))-  | -- | Must not be single value.-    ValueTuple [Compound v]-  | ValueAtom v-  deriving (Eq, Ord, Show)--instance Functor Compound where-  fmap = fmapDefault--instance Foldable Compound where-  foldMap = foldMapDefault--instance Traversable Compound where-  traverse f (ValueAtom v) = ValueAtom <$> f v-  traverse f (ValueTuple vs) = ValueTuple <$> traverse (traverse f) vs-  traverse f (ValueRecord m) = ValueRecord <$> traverse (traverse f) m--instance (Pretty v) => Pretty (Compound v) where-  pretty (ValueAtom v) = pretty v-  pretty (ValueTuple vs) = parens $ commasep $ map pretty vs-  pretty (ValueRecord m) = braces $ commasep $ map field $ M.toList m-    where-      field (k, v) = pretty k <> equals <> pretty v---- | Create a tuple for a non-unit list, and otherwise a 'ValueAtom'-mkCompound :: [Compound v] -> Compound v-mkCompound [v] = v-mkCompound vs = ValueTuple vs---- | If the value is a tuple, extract the components, otherwise return--- a singleton list of the value.-unCompound :: Compound v -> [Compound v]-unCompound (ValueTuple vs) = vs-unCompound v = [v]---- | Like a 'Value', but also grouped in compound ways that are not--- supported by raw values.  You cannot parse or read these in--- standard ways, and they cannot be elements of arrays.-type CompoundValue = Compound Value  randomVector ::   (SVec.Storable v, UniformRange v) =>
src/Futhark/Tools.hs view
@@ -314,7 +314,7 @@   cert_ps <- replicateM (length dest) $ newParam "acc_cert" $ Prim Unit   dest_ts <- mapM lookupType dest   let acc_shape = Shape $ take rank $ arrayDims $ head dest_ts-      mkT cert elem_t = Acc cert acc_shape [elem_t] NoUniqueness+      mkT cert elem_t = Acc cert acc_shape [elem_t]       acc_ts =         zipWith mkT (map paramName cert_ps) $           map (stripArray rank) dest_ts@@ -337,7 +337,7 @@   cert_ps <- replicateM (length dest) $ newParam "acc_cert" $ Prim Unit   dest_ts <- mapM lookupType dest   let acc_shape = Shape $ take rank $ arrayDims $ head dest_ts-      mkT cert elem_t = Acc cert acc_shape [elem_t] NoUniqueness+      mkT cert elem_t = Acc cert acc_shape [elem_t]       acc_ts =         zipWith mkT (map paramName cert_ps) $           map (stripArray rank) dest_ts@@ -406,7 +406,7 @@       elem_ts <- fmap (map (stripArray (shapeRank shape))) $ mapM lookupType $ histDest op       cert_p <- newParam "acc_cert" $ Prim Unit       let cert = paramName cert_p-      pure (input, cert_p, Acc cert shape elem_ts NoUniqueness)+      pure (input, cert_p, Acc cert shape elem_ts)  -- | The most addition-like binary operator for some primitive type. addBinOp :: PrimType -> BinOp@@ -421,7 +421,7 @@     MonadBuilder m,     Buildable (Rep m)   ) =>-  TypeBase Shape NoUniqueness ->+  TypeBase Shape NoMode ->   m (Lambda (Rep m)) addLambda (Prim pt) = binOpLambda (addBinOp pt) pt addLambda t@Array {} = do
src/Futhark/Transform/FirstOrderTransform.hs view
@@ -142,16 +142,16 @@   -- Loop parameters: the current filled size, the current capacity, the   -- per-element shape and offset arrays, one scratch buffer per nonuniform   -- result, and one array per uniform result.-  size_p <- newParam "flatmap_size" $ toDecl (Prim int64) Nonunique-  cap_p <- newParam "flatmap_cap" $ toDecl (Prim int64) Nonunique-  shape_p <- newParam "flatmap_shape" $ toDecl (arrayOfRow (Prim int64) w) Unique-  offset_p <- newParam "flatmap_offset" $ toDecl (arrayOfRow (Prim int64) w) Unique+  size_p <- newParam "flatmap_size" $ toDecl (Prim int64) Observe+  cap_p <- newParam "flatmap_cap" $ toDecl (Prim int64) Observe+  shape_p <- newParam "flatmap_shape" $ toDecl (arrayOfRow (Prim int64) w) Consume+  offset_p <- newParam "flatmap_offset" $ toDecl (arrayOfRow (Prim int64) w) Consume   scratch_ps <-     forM irreg_ts $ \et ->-      newParam "flatmap_res" $ toDecl (arrayOfRow et (Var (paramName cap_p))) Unique+      newParam "flatmap_res" $ toDecl (arrayOfRow et (Var (paramName cap_p))) Consume   reg_ps <-     forM reg_ts $ \rt ->-      newParam "flatmap_reg" $ toDecl (arrayOfRow rt w) Unique+      newParam "flatmap_reg" $ toDecl (arrayOfRow rt w) Consume    -- The capacity initially matches the input size.   shape_init <- letExp "flatmap_shape" $ BasicOp $ Scratch int64 [w]@@ -283,7 +283,7 @@ transformFlatMapFlags flag_pat w m shape offset = do   let flag_t = arrayOfRow (Prim Bool) m   flags_init <- letExp "flatmap_flags" $ BasicOp $ Replicate (Shape [m]) (constant False)-  flags_p <- newParam "flatmap_flags" $ toDecl flag_t Unique+  flags_p <- newParam "flatmap_flags" $ toDecl flag_t Consume   j <- newVName "j"   let flag_form = ForLoop j Int64 w   shape_t <- lookupType shape@@ -323,19 +323,19 @@   -- operator   let Reduce _ red_lam red_nes = singleReduce reds       Scan scan_lam scan_nes = singleScan scans-      (_red_ts, post_ts) =+      (red_ts, post_ts) =         splitAt (length red_nes) $ scremaType w form    post_arrs <- resultArray arrs post_ts -  scanacc_params <- mapM (newParam "scanacc" . flip toDecl Nonunique) $ lambdaReturnType scan_lam-  redout_params <- mapM (newParam "redout" . flip toDecl Nonunique) $ lambdaReturnType red_lam-  out_params <- mapM (newParam "out" . flip toDecl Unique) post_ts+  scanacc_params <- mapM (newParam "scanacc" . flip toDecl Observe) $ lambdaReturnType scan_lam+  redout_params <- mapM (newParam "redout" . flip toDecl Observe) $ lambdaReturnType red_lam+  out_params <- mapM (newParam "out" . flip toDecl Consume) post_ts    arr_ts <- mapM lookupType arrs-  let paramForAcc (Acc c _ _ _) = find (f . paramType) out_params+  let paramForAcc (Acc c _ _) = find (f . paramType) out_params         where-          f (Acc c2 _ _ _) = c == c2+          f (Acc c2 _ _) = c == c2           f _ = False       paramForAcc _ = Nothing @@ -410,13 +410,22 @@           varsRes outarrs         ] -  -- We need to discard the final scan accumulators, as they are not-  -- bound in the original pattern.-  names <--    (++ patNames pat)-      <$> replicateM (length scanacc_params) (newVName "discard")-  letBindNames names $ Loop merge loopform loop_body+  discards <- replicateM (length scanacc_params) (newVName "discard") +  -- Screma requires alias-free results, so reduction results are bound to fresh+  -- names, so that we can copy the array-typed ones.+  let (red_pat_names, post_pat_names) = splitAt (length red_nes) $ patNames pat+  red_names <- mapM newName red_pat_names++  letBindNames (discards ++ red_names ++ post_pat_names) $+    Loop merge loopform loop_body++  forM_ (zip3 red_pat_names red_names red_ts) $ \(to, from, t) ->+    letBindNames [to] . BasicOp $+      case t of+        Array {} -> Replicate mempty $ Var from+        _ -> SubExp $ Var from+ -- | Transform a single 'SOAC' into a do-loop.  The body of the lambda -- is untouched, and may or may not contain further 'SOAC's depending -- on the given rep.@@ -446,12 +455,12 @@    mapout_initial <- resultArray arrs mapout_ts   mapout_params <- forM mapout_ts $ \t ->-    newParam "stream_mapout" $ toDecl t Unique+    newParam "stream_mapout" $ toDecl t Consume   let mapout_merge = zip mapout_params $ map Var mapout_initial -  let paramForAcc (Acc c _ _ _) = find (f . paramType) mapout_params+  let paramForAcc (Acc c _ _) = find (f . paramType) mapout_params         where-          f (Acc c2 _ _ _) = c == c2+          f (Acc c2 _ _) = c == c2           f _ = False       paramForAcc _ = Nothing @@ -465,7 +474,7 @@           _ -> pure se   nes' <- mapM copyIfArray nes -  let onType t = t `toDecl` Unique+  let onType t = t `toDecl` Consume       merge = zip (map (fmap onType) fold_params) nes' ++ mapout_merge       merge_params = map fst merge @@ -602,12 +611,12 @@   bodyBind body  loopMerge :: [Ident] -> [SubExp] -> [(Param DeclType, SubExp)]-loopMerge vars = loopMerge' $ map (,Unique) vars+loopMerge vars = loopMerge' $ map (,Consume) vars -loopMerge' :: [(Ident, Uniqueness)] -> [SubExp] -> [(Param DeclType, SubExp)]+loopMerge' :: [(Ident, Diet)] -> [SubExp] -> [(Param DeclType, SubExp)] loopMerge' vars vals =-  [ (Param mempty pname $ toDecl ptype u, val)-  | ((Ident pname ptype, u), val) <- zip vars vals+  [ (Param mempty pname $ toDecl ptype o, val)+  | ((Ident pname ptype, o), val) <- zip vars vals   ]  -- Note [Translation of Screma]@@ -625,15 +634,15 @@ -- However, category (3) is a little more tricky in the case where one -- of the results is an Acc.  In that case, the result is not an -- array, but another Acc.  Any Acc result of a Map must correspond to--- an Acc that is an input to the map, and the result is initialised+-- an Acc that is an to the map, and the result is initialised -- to be that input.  This requires a 1:1 relationship between Acc -- inputs and Acc outputs, which the type checker should enforce. -- There is no guarantee that the map results appear in any particular -- order (e.g. accumulator results before non-accumulator results), so -- we need to do a little sleuthing to establish the relationship. ----- Inside the loop, the non-Acc parameters to map_lam become for-in--- parameters.  Acc parameters refer to the loop parameters for the+-- Inside the loop, the non-Acc parameters to map_lam for-in+-- parameters.  Acc parameters refer to loop parameters for the -- corresponding Map result instead. -- -- Intuitively, a Screma(w,
src/Futhark/Transform/Rename.hs view
@@ -304,12 +304,12 @@ instance Rename PrimType where   rename = pure -instance (Rename shape) => Rename (TypeBase shape u) where-  rename (Array et size u) = Array <$> rename et <*> rename size <*> pure u+instance (Rename shape) => Rename (TypeBase shape o) where+  rename (Array et size o) = Array <$> rename et <*> rename size <*> pure o   rename (Prim t) = pure $ Prim t   rename (Mem space) = pure $ Mem space-  rename (Acc acc ispace ts u) =-    Acc <$> rename acc <*> rename ispace <*> rename ts <*> pure u+  rename (Acc acc ispace ts) =+    Acc <$> rename acc <*> rename ispace <*> rename ts  instance (Renameable rep, Rename t) => Rename (GLambda rep t) where   rename (Lambda params ret body) =
src/Futhark/Transform/Substitute.hs view
@@ -158,17 +158,16 @@ instance Substitute PrimType where   substituteNames _ t = t -instance (Substitute shape) => Substitute (TypeBase shape u) where+instance (Substitute shape) => Substitute (TypeBase shape o) where   substituteNames _ (Prim et) =     Prim et-  substituteNames substs (Acc acc ispace ts u) =+  substituteNames substs (Acc acc ispace ts) =     Acc       (substituteNames substs acc)       (substituteNames substs ispace)       (substituteNames substs ts)-      u-  substituteNames substs (Array et sz u) =-    Array (substituteNames substs et) (substituteNames substs sz) u+  substituteNames substs (Array et sz o) =+    Array (substituteNames substs et) (substituteNames substs sz) o   substituteNames _ (Mem space) =     Mem space
src/Futhark/Util/IntegralExp.hs view
@@ -35,12 +35,12 @@    -- | Like 'Futhark.Util.IntegralExp.div', but rounds towards   -- positive infinity.-  divUp :: e -> e -> e-  divUp x y =+  ceilDiv :: e -> e -> e+  ceilDiv x y =     (x + y - 1) `Futhark.Util.IntegralExp.div` y    nextMul :: e -> e -> e-  nextMul x y = x `divUp` y * y+  nextMul x y = x `ceilDiv` y * y  -- | This wrapper allows you to use a type that is an instance of the -- true class whenever the simile class is required.
src/Language/Futhark/Core.hs view
@@ -2,8 +2,7 @@ -- that they can be shared between the internal and external -- representation. module Language.Futhark.Core-  ( Uniqueness (..),-    NoUniqueness (..),+  ( NoMode (..),      -- * Location utilities     SrcLoc,@@ -58,38 +57,18 @@ import System.FilePath (takeDirectory) import Prelude hiding (id, (.)) --- | The uniqueness attribute of a type.  This essentially indicates--- whether or not in-place modifications are acceptable.  With respect--- to ordering, 'Unique' is greater than 'Nonunique'.-data Uniqueness-  = -- | May have references outside current function.-    Nonunique-  | -- | No references outside current function.-    Unique-  deriving (Eq, Ord, Show)--instance Semigroup Uniqueness where-  (<>) = min--instance Monoid Uniqueness where-  mempty = Unique--instance Pretty Uniqueness where-  pretty Unique = "*"-  pretty Nonunique = mempty---- | A fancier name for @()@ - encodes no uniqueness information.--- Also has a different prettyprinting instance.-data NoUniqueness = NoUniqueness+-- | A fancier name for @()@ - the mode of a type that has none.  Also+-- has a different prettyprinting instance.+data NoMode = NoMode   deriving (Eq, Ord, Show) -instance Semigroup NoUniqueness where-  NoUniqueness <> NoUniqueness = NoUniqueness+instance Semigroup NoMode where+  NoMode <> NoMode = NoMode -instance Monoid NoUniqueness where-  mempty = NoUniqueness+instance Monoid NoMode where+  mempty = NoMode -instance Pretty NoUniqueness where+instance Pretty NoMode where   pretty _ = mempty  -- | The abstract (not really) type representing names in the Futhark
src/Language/Futhark/FreeVars.hs view
@@ -126,11 +126,11 @@   foldMap (foldMap freeInExp) [me1, me2, me3]  -- | Free variables in pattern (including types of the bound identifiers).-freeInPat :: Pat (TypeBase Size u) -> FV+freeInPat :: Pat (TypeBase Size o) -> FV freeInPat = foldMap freeInType  -- | Free variables in the type (meaning those that are used in size expression).-freeInType :: TypeBase Size u -> FV+freeInType :: TypeBase Size o -> FV freeInType t =   case t of     Array _ s a ->
src/Language/Futhark/Interpreter.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Strict #-}  -- | An interpreter operating on type-checked source Futhark terms.@@ -5,11 +6,12 @@ module Language.Futhark.Interpreter   ( Ctx (..),     Env,-    InterpreterError,+    InterpreterError (..),     prettyInterpreterError,     initialCtx,     interpretExp,     interpretDec,+    interpretApply,     interpretImport,     interpretFunction,     ctxWithImports,@@ -26,6 +28,12 @@     prettyEmptyArray,     prettyValue,     valueText,++    -- * IO+    IOOp,+    determineIO,+    doIOOp,+    ioRelativeTo,   ) where @@ -38,7 +46,6 @@ import Data.Array import Data.Bifunctor import Data.Bitraversable-import Data.ByteString qualified as BS import Data.Functor (($>), (<&>)) import Data.List   ( find,@@ -61,6 +68,9 @@ import Language.Futhark hiding (Shape, matchDims) import Language.Futhark qualified as F import Language.Futhark.Interpreter.AD qualified as AD+import Language.Futhark.Interpreter.FFI.Push qualified as FFI+import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI+import Language.Futhark.Interpreter.IO import Language.Futhark.Interpreter.Values hiding (Value) import Language.Futhark.Interpreter.Values qualified import Language.Futhark.Primitive (floatValue, intValue)@@ -88,11 +98,16 @@   = ExtOpTrace T.Text (Doc ()) a   | ExtOpBreak Loc BreakReason (NE.NonEmpty StackFrame) a   | ExtOpError InterpreterError+  | ExtOpFFI (FFI.ServerM Value) (Value -> a)+  | -- | Perform an IO operation.+    ExtOpIO IOOp (Value -> a)  instance Functor ExtOp where   fmap f (ExtOpTrace w s x) = ExtOpTrace w s $ f x   fmap f (ExtOpBreak w why backtrace x) = ExtOpBreak w why backtrace $ f x   fmap _ (ExtOpError err) = ExtOpError err+  fmap f (ExtOpFFI vr c) = ExtOpFFI vr $ f . c+  fmap f (ExtOpIO v c) = ExtOpIO v $ f . c  type Stack = [StackFrame] @@ -182,7 +197,7 @@   pretty = mconcat . map (brackets . pretty) . shapeDims  -- | A type where the sizes are unevaluated expressions.-type EvalType = TypeBase SizeClosure NoUniqueness+type EvalType = TypeBase SizeClosure NoMode  structToEval :: Env -> StructType -> EvalType structToEval env = first (SizeClosure env)@@ -300,14 +315,6 @@  type Value = Language.Futhark.Interpreter.Values.Value EvalM --- | If the value represents an array of type @[]i8@, then return those bytes.-asByteString :: Value -> Maybe BS.ByteString-asByteString (ValueArray _ vals) = BS.pack <$> mapM asU8 (elems vals)-  where-    asU8 (ValuePrim (UnsignedValue (Int8Value x))) = Just $ fromIntegral x-    asU8 _ = Nothing-asByteString _ = Nothing- asInteger :: Value -> Integer asInteger (ValuePrim (SignedValue v)) = P.valueIntegral v asInteger (ValuePrim (UnsignedValue v)) =@@ -373,7 +380,7 @@   = TypeConBinding       Env       [TypeParam]-      (RetTypeBase Size NoUniqueness)+      (RetTypeBase Size NoMode)   | TypeBinding       EvalType   deriving (Show)@@ -448,8 +455,13 @@  trace :: T.Text -> Value -> EvalM () trace w v = do-  liftF $ ExtOpTrace w (prettyValue v) ()+  -- Printing a value requires having it in full.+  v' <- force v+  liftF $ ExtOpTrace w (prettyValue v') () +doIO :: IOOp -> EvalM Value+doIO io = liftF $ ExtOpIO io id+ typeCheckerEnv :: Env -> T.Env typeCheckerEnv env =   -- FIXME: some shadowing issues are probably not right here.@@ -470,10 +482,21 @@   backtrace <- asks ((StackFrame loc (Ctx env imports) NE.:|) . fst)   liftF $ ExtOpBreak loc BreakPoint backtrace () -fromArray :: Value -> (ValueShape, [Value])-fromArray (ValueArray shape as) = (shape, elems as)-fromArray v = error $ "Expected array value, but found: " <> show v+-- | Fetch in full a value that may reside on a server, such that it can be+-- handled by code that knows only about ordinary values. Only indexing (see+-- 'indexArray') is able to work directly on a server value, so anything else+-- must force it first.+force :: Value -> EvalM Value+force v+  | FFI.hasLazy v = liftF $ ExtOpFFI (FFI.getLazy v) id+  | otherwise = pure v +fromArray :: Value -> EvalM (ValueShape, [Value])+fromArray v =+  force v >>= \case+    ValueArray shape as -> pure (shape, elems as)+    v' -> error $ "Expected array value, but found: " <> show v'+ project :: Name -> Value -> Value project f (ValueRecord fs)   | Just v' <- M.lookup f fs = v'@@ -488,14 +511,14 @@   f' <- apply noLoc mempty f x   apply noLoc mempty f' y -matchPat :: Env -> Pat (TypeBase Size u) -> Value -> EvalM Env+matchPat :: Env -> Pat (TypeBase Size o) -> Value -> EvalM Env matchPat env p v = do   m <- runMaybeT $ patternMatch env p v   case m of     Nothing -> error $ "matchPat: missing case for " <> prettyString (toStruct <$> p) ++ " and " <> show v     Just env' -> pure env' -patternMatch :: Env -> Pat (TypeBase Size u) -> Value -> MaybeT EvalM Env+patternMatch :: Env -> Pat (TypeBase Size o) -> Value -> MaybeT EvalM Env patternMatch env (PatAttr _ p _) val =   patternMatch env p val patternMatch env (Id v (Info t) _) val =@@ -595,19 +618,39 @@ indexShape _ shape =   shape -indexArray :: [Indexing] -> Value -> Maybe Value-indexArray (IndexingFix i : is) (ValueArray _ arr)+iaArrayLength :: Value -> Int64+iaArrayLength v = case valueShape v of+  ShapeDim n _ -> n+  _ -> error "Expected array."++iaRowShape :: Value -> ValueShape+iaRowShape v = case valueShape v of+  ShapeDim _ rowshape -> rowshape+  _ -> error "Expected array."++iaIndexOnce :: Value -> Int64 -> EvalM Value+iaIndexOnce (ValueArray _ arr) i = pure $ arr ! fromIntegral i+iaIndexOnce v@(ValueLazyFFI shp vr os) i+  -- Indexing an array of arrays merely notes the index; nothing is+  -- fetched until we reach an element.+  | ShapeDim _ ShapeDim {} <- valueShape v = pure v'+  | otherwise = liftF $ ExtOpFFI (FFI.index is vr >>= FFI.get (valueShape v')) id+  where+    v' = ValueLazyFFI shp vr $ i : os+    is = map fromIntegral $ reverse $ i : os+iaIndexOnce _ _ = error "Expected array."++indexArray :: [Indexing] -> Value -> MaybeT EvalM Value+indexArray (IndexingFix i : is) v   | i >= 0,-    i < n =-      indexArray is $ arr ! fromIntegral i+    i < iaArrayLength v =+      lift (iaIndexOnce v i) >>= indexArray is   | otherwise =-      Nothing-  where-    n = arrayLength arr-indexArray (IndexingSlice start end stride : is) (ValueArray (ShapeDim _ rowshape) arr) = do-  js <- indexesFor start end stride $ arrayLength arr-  toArray' (indexShape is rowshape) <$> mapM (indexArray is . (arr !)) js-indexArray _ v = Just v+      MaybeT $ pure Nothing+indexArray (IndexingSlice start end stride : is) v = do+  js <- MaybeT $ pure <$> indexesFor start end stride $ iaArrayLength v+  toArray' (indexShape is $ iaRowShape v) <$> mapM (\i -> MaybeT (Just <$> iaIndexOnce v (fromIntegral i)) >>= indexArray is) js+indexArray _ v = pure v  writeArray :: [Indexing] -> Value -> Value -> Maybe Value writeArray slice x y = runIdentity $ updateArray (\_ y' -> pure y') slice x y@@ -663,24 +706,25 @@             <> "] out of bounds for array of shape "             <> prettyText (arrayValueShape arr)             <> "."-  maybe oob pure $ indexArray is arr+  v <- runMaybeT $ indexArray is arr+  maybe oob pure v  -- | Expand type based on information that was not available at -- type-checking time (the structure of abstract types).-expandType :: (Pretty u) => Env -> TypeBase Size u -> TypeBase SizeClosure u+expandType :: (Pretty o) => Env -> TypeBase Size o -> TypeBase SizeClosure o expandType _ (Scalar (Prim pt)) = Scalar $ Prim pt expandType env (Scalar (Record fs)) = Scalar $ Record $ fmap (expandType env) fs-expandType env (Scalar (Arrow u p d t1 (RetType dims t2))) =-  Scalar $ Arrow u p d (expandType env t1) (RetType dims (expandType env t2))-expandType env t@(Array u shape _) =+expandType env (Scalar (Arrow o p d t1 (RetType dims t2))) =+  Scalar $ Arrow o p d (expandType env t1) (RetType dims (expandType env t2))+expandType env t@(Array o shape _) =   let et = stripArray (shapeRank shape) t       et' = expandType env et       shape' = fmap (SizeClosure env) shape-   in second (const u) (arrayOf shape' $ toStruct et')-expandType env (Scalar (TypeVar u tn args)) =+   in second (const o) (arrayOf shape' $ toStruct et')+expandType env (Scalar (TypeVar o tn args)) =   case lookupType tn env of     Just (TypeBinding t') ->-      second (const u) t'+      second (const o) t'     Just (TypeConBinding tn_env ps (RetType ext t')) ->       let (substs, types) = mconcat $ zipWith matchPtoA ps args           onDim (SizeClosure dim_env dim)@@ -692,11 +736,11 @@             | otherwise =                 SizeClosure (env <> dim_env) $                   applySubst (`M.lookup` substs) dim-       in bimap onDim (const u) $ expandType (Env mempty types <> tn_env) t'+       in bimap onDim (const o) $ expandType (Env mempty types <> tn_env) t'     Nothing ->       -- This case only happens for built-in abstract types,       -- e.g. accumulators.-      Scalar (TypeVar u tn $ map expandArg args)+      Scalar (TypeVar o tn $ map expandArg args)   where     matchPtoA (TypeParamDim p _) (TypeArgDim e) =       (M.singleton p $ ExpSubst e, mempty)@@ -710,7 +754,7 @@  -- | Evaluate all possible sizes, except those that contain free -- variables in the set of names.-evalType :: S.Set VName -> EvalType -> EvalM (TypeBase (Either Int64 SizeClosure) NoUniqueness)+evalType :: S.Set VName -> EvalType -> EvalM (TypeBase (Either Int64 SizeClosure) NoMode) evalType outer_bound t = do   let evalDim bound _ (SizeClosure env e)         | canBeEvaluated bound e =@@ -782,7 +826,7 @@ -- Sometimes type instantiation is not quite enough - then we connect -- up the missing sizes here.  In particular used for eta-expanded -- entry points.-linkMissingSizes :: [VName] -> Pat (TypeBase Size u) -> Value -> Env -> Env+linkMissingSizes :: [VName] -> Pat (TypeBase Size o) -> Value -> Env -> Env linkMissingSizes [] _ _ env = env linkMissingSizes missing_sizes p v env =   env <> i64Env (resolveExistentials missing_sizes p_t (valueShape v))@@ -876,7 +920,7 @@     _ -> pure ()   pure v -returned :: Env -> TypeBase Size u -> [VName] -> Value -> EvalM Value+returned :: Env -> TypeBase Size o -> [VName] -> Value -> EvalM Value returned _ _ [] v = pure v returned env ret retext v = do   mapM_ (uncurry putExtSize . second (ValuePrim . SignedValue . Int64Value))@@ -993,7 +1037,7 @@       bound' <- asSigned <$> eval env bound       forLoop (identName iv) bound' (zero bound') init_v     ForIn in_pat in_e -> do-      (_, in_vs) <- fromArray <$> eval env in_e+      (_, in_vs) <- fromArray =<< eval env in_e       foldM (forInLoop in_pat) init_v in_vs     While cond ->       whileLoop cond init_v@@ -1186,7 +1230,9 @@ evalUpdateSteps :: Env -> [UpdateStep Info VName] -> Value -> Value -> EvalM (Maybe Value) evalUpdateSteps env = go   where-    go [] _ newv = pure $ Just newv+    -- The value we update with must be in full, as 'writeArray' will store+    -- it directly in the destination.+    go [] _ newv = Just <$> force newv     go (UpdateStepField f : rest) (ValueRecord fs) newv       | Just old <- M.lookup f fs = do           newf <- go rest old newv@@ -1195,13 +1241,16 @@       error "eval update: invalid field update."     go (UpdateStepSlice is : rest) arr newv = do       is' <- mapM (evalDimIndex env) is-      case indexArray is' arr of+      -- 'writeArray' cannot update an array residing on a server.+      arr' <- force arr+      v <- runMaybeT $ indexArray is' arr'+      case v 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+            Just vsub -> pure $ writeArray is' arr' vsub  evalCase ::   Value ->@@ -1302,7 +1351,102 @@       pure (f_env <> e_env <> res_env <> env_substs, res_mod)     _ -> error "Expected ModuleFun." +-- | Call an external function with the given return type.+extCall :: Name -> ResRetType -> Env -> [Value] -> EvalM Value+extCall n ret env ps = do+  v <- liftF . (`ExtOpFFI` id) . call =<< resShapeOf ext env t+  -- An existential size that the server cannot reveal is one that occurs only+  -- in the payload of an absent constructor. It is observable by binding it in+  -- a size pattern, so this differs from the interpreter, which knows the+  -- actual size. Like the C API, we use 0 for the arrays of an absent+  -- constructor.+  let ext_env =+        i64Env $+          resolveExistentials ext t (valueShape v) <> M.fromList (map (,0) ext)+  completeSums (ext_env <> env) t v+  where+    ext = retDims ret+    t = toStruct $ snd $ unfoldFunType $ retType ret+    call resshp = do+      FFI.gc+      vr <- FFI.call n =<< FFI.putArgs n ps+      shp <- FFI.resultShape resshp vr+      FFI.lazyGet shp vr++-- | Describe a result type for 'FFI.resultShape'. Arrays, records, and sums+-- with existential sizes are merely described, never evaluated; only what is+-- none of these has its shape taken from the type.+resShapeOf :: [VName] -> Env -> StructType -> EvalM FFI.ResShape+resShapeOf ext env t+  | rank > 0 =+      FFI.ResArray <$> resShapeOf ext env (stripArray rank t)+  | Scalar (Record fs) <- t =+      FFI.ResRecord <$> traverse (resShapeOf ext env) fs+  | Scalar (Sum cs) <- t,+    any (`S.member` fvVars (freeInType t)) ext =+      FFI.ResSum <$> traverse (traverse (resShapeOf ext env)) cs+  | otherwise =+      FFI.ResKnown . typeShape <$> evalTypeFully (structToEval env t)+  where+    rank = arrayRank t++-- | The shape of a sum produced by 'FFI.resultShape' describes only the+-- constructor that is present. Add the others, whose shapes are determined by+-- the type in the given environment.+completeSums :: Env -> StructType -> Value -> EvalM Value+completeSums env (Scalar (Record ts)) (ValueRecord vs) =+  ValueRecord <$> sequence (M.intersectionWith (completeSums env) ts vs)+completeSums env t@(Scalar (Sum cs)) (ValueSum _ c vs) = do+  vs' <- maybe (pure vs) (\ts -> zipWithM (completeSums env) ts vs) $ M.lookup c cs+  shape <- sumValueShape env t c vs'+  pure $ ValueSum shape c vs'+completeSums _ _ v = pure v++-- | The parameters of an external binding, represented as functions that+-- bind an argument in the environment.+extParams :: [Pat ParamType] -> ResRetType -> [Env -> Value -> EvalM Env]+extParams ps ret = map fromPat ps <> map fromArrow (fst $ unfoldFunType $ retType ret)+  where+    fromPat p env = matchPat env p+    fromArrow (Named v, t) env val =+      pure $ valEnv (M.singleton v (Just $ T.BoundV [] $ toStruct t, val)) <> env+    fromArrow (Unnamed, _) env _ = pure env++-- | Construct the value of an external binding with the given parameters. The+-- shape of the result may depend on the values of the parameters, so it is+-- computed only once every argument has been supplied and bound in the+-- environment. A binding of arity zero is not a function, and is called+-- immediately.+extFun ::+  Name ->+  Env ->+  [Env -> Value -> EvalM Env] ->+  ResRetType ->+  EvalM Value+extFun n = extFun' []+  where+    extFun' vs env [] ret = extCall n ret env $ reverse vs+    extFun' vs env (bind : binds) ret = pure . ValueFun $ \v -> do+      env' <- bind env v+      extFun' (v : vs) env' binds ret+ evalDec :: Env -> Dec -> EvalM Env+evalDec env (ValDec vb@(ValBind (Just _) vn@(VName n _) _ _ (Info ret) tparams ps _ _ _ _)) | "$external" `elem` valBindAttrs vb = localExts $ do+  let ftype = evalToStruct $ expandType env $ funType ps ret+      bv = Just $ T.BoundV [] ftype+      params = extParams ps ret+  sizes <- extEnv+  if null tparams+    then do+      f <- extFun n env params ret+      pure $ mempty {envTerm = M.singleton vn $ TermValue bv f} <> sizes+    else+      -- TODO: Add missing sizes?+      let pfn ftype' = do+            tparam_env <-+              evalResolved $ resolveTypeParams (map typeParamName tparams) ftype ftype'+            extFun n (tparam_env <> env) params ret+       in pure $ mempty {envTerm = M.singleton vn $ TermPoly bv pfn} <> sizes evalDec env (ValDec (ValBind _ v _ _ (Info ret) tparams ps fbody _ _ _)) = localExts $ do   binding <- evalValBinding env v tparams ps ret fbody   sizes <- extEnv@@ -1403,7 +1547,12 @@ -- Perhaps creating JVPValues could be abstracted into a function -- exposed by the AD module? doJVP2 :: Value -> Value -> Value -> EvalM Value-doJVP2 f v s = do+doJVP2 f v0 s0 = do+  -- Differentiation traverses the values themselves, so anything+  -- residing on a server must be fetched first.+  v <- force v0+  s <- force s0+   depth <- adDepth    -- Turn the seeds into a list of ADValues@@ -1455,7 +1604,12 @@ -- Perhaps creating VJPValues could be abstracted into a function -- exposed by the AD module? doVJP2 :: Value -> Value -> Value -> EvalM Value-doVJP2 f v s = do+doVJP2 f v0 s0 = do+  -- Differentiation traverses the values themselves, so anything+  -- residing on a server must be fetched first.+  v <- force v0+  s <- force s0+   -- Get the depth   depth <- adDepth @@ -1793,12 +1947,14 @@     def ">>" = Just $ bopDef $ sintOp P.AShr ++ uintOp P.LShr     def "<<" = Just $ bopDef $ intOp P.Shl     def ">>>" = Just $ bopDef $ sintOp P.LShr ++ uintOp P.LShr+    -- Equality inspects the values themselves, so anything residing on a+    -- server must be fetched first.     def "==" = Just $       fun2 $-        \xs ys -> pure $ ValuePrim $ BoolValue $ xs == ys+        \xs ys -> ValuePrim . BoolValue <$> ((==) <$> force xs <*> force ys)     def "!=" = Just $       fun2 $-        \xs ys -> pure $ ValuePrim $ BoolValue $ xs /= ys+        \xs ys -> ValuePrim . BoolValue <$> ((/=) <$> force xs <*> force ys)     -- The short-circuiting is handled directly in 'eval'; these cases     -- are only used when partially applying and such.     def "&&" = Just $@@ -1882,8 +2038,9 @@         pure $ ValueFun $ \f -> pure . ValueFun $ \xs ->           case unfoldFunType t' of             ([_, _], ret_t)-              | rowshape <- typeShape $ stripArray 1 ret_t ->-                  toArray' rowshape <$> mapM (apply noLoc mempty f) (snd $ fromArray xs)+              | rowshape <- typeShape $ stripArray 1 ret_t -> do+                  xs' <- snd <$> fromArray xs+                  toArray' rowshape <$> mapM (apply noLoc mempty f) xs'             _ ->               error $                 "Invalid arguments to map intrinsic:\n"@@ -1897,13 +2054,13 @@                   irreg_rowshape <- typeShape <$> evalTypeFully (stripArray 1 irreg_t)                   reg_rowshape <- typeShape <$> evalTypeFully (stripArray 1 reg_t)                   yss <--                    mapM-                      (apply noLoc mempty f)-                      (snd $ fromArray xs)+                    mapM (apply noLoc mempty f) . snd+                      =<< fromArray xs                   -- Each application produces a segment, which is concatenated                   -- with the others, and a value that is merely collected.                   let (segs, regs) = unzip $ map (fromPair . fromTuple) yss-                      seg_sizes = map (genericLength . snd . fromArray) segs :: [Int64]+                  segs' <- mapM (fmap snd . fromArray) segs+                  let seg_sizes = map genericLength segs' :: [Int64]                       offsets = init $ scanl (+) 0 seg_sizes                       flag s = if s == 0 then [] else True : replicate (fromIntegral s - 1) False                       mkI64 = ValuePrim . SignedValue . Int64Value@@ -1912,7 +2069,7 @@                       [ toArray' ShapeLeaf $ map mkI64 seg_sizes,                         toArray' ShapeLeaf $ map (ValuePrim . BoolValue) $ concatMap flag seg_sizes,                         toArray' ShapeLeaf $ map mkI64 offsets,-                        toArray' irreg_rowshape $ concatMap (snd . fromArray) segs,+                        toArray' irreg_rowshape $ concat segs',                         toArray' reg_rowshape regs                       ]             _ ->@@ -1924,24 +2081,24 @@         fromPair _ = error "flatmap: lambda did not return a pair"     def s | "reduce" `T.isPrefixOf` s = Just $       fun3 $ \f ne xs ->-        foldM (apply2 noLoc mempty f) ne $ snd $ fromArray xs+        foldM (apply2 noLoc mempty f) ne . snd =<< fromArray xs     def "scan" = Just $       fun3 $ \f ne xs -> do         let next (out, acc) x = do               x' <- apply2 noLoc mempty f acc x               pure (x' : out, x')+        xs' <- snd <$> fromArray xs         toArray' (valueShape ne) . reverse . fst-          <$> foldM next ([], ne) (snd $ fromArray xs)+          <$> foldM next ([], ne) xs'     def "scatter" = Just $       fun3 $ \arr is vs ->-        case arr of-          ValueArray shape arr' ->-            pure $-              ValueArray shape $-                foldl' update arr' $-                  zip (map asInt $ snd $ fromArray is) (snd $ fromArray vs)-          _ ->-            error $ "scatter expects array, but got: " <> show arr+        force arr >>= \case+          ValueArray shape arr' -> do+            is' <- map asInt . snd <$> fromArray is+            vs' <- snd <$> fromArray vs+            pure $ ValueArray shape $ foldl' update arr' $ zip is' vs'+          arr' ->+            error $ "scatter expects array, but got: " <> show arr'       where         update arr' (i, v) =           if i >= 0 && i < arrayLength arr'@@ -1949,13 +2106,13 @@             else arr'     def "scatter_2d" = Just $       fun3 $ \arr is vs ->-        case arr of-          ValueArray _ _ ->-            pure $-              foldl' update arr $-                zip (map fromTuple $ snd $ fromArray is) (snd $ fromArray vs)-          _ ->-            error $ "scatter_2d expects array, but got: " <> show arr+        force arr >>= \case+          arr'@ValueArray {} -> do+            is' <- map fromTuple . snd <$> fromArray is+            vs' <- snd <$> fromArray vs+            pure $ foldl' update arr' $ zip is' vs'+          arr' ->+            error $ "scatter_2d expects array, but got: " <> show arr'       where         update :: Value -> (Maybe [Value], Value) -> Value         update arr (Just idxs@[_, _], v) =@@ -1964,33 +2121,33 @@           error "scatter_2d expects 2-dimensional indices"     def "scatter_3d" = Just $       fun3 $ \arr is vs ->-        case arr of-          ValueArray _ _ ->-            pure $-              foldl' update arr $-                zip (map fromTuple $ snd $ fromArray is) (snd $ fromArray vs)-          _ ->-            error $ "scatter_3d expects array, but got: " <> show arr+        force arr >>= \case+          arr'@ValueArray {} -> do+            is' <- map fromTuple . snd <$> fromArray is+            vs' <- snd <$> fromArray vs+            pure $ foldl' update arr' $ zip is' vs'+          arr' ->+            error $ "scatter_3d expects array, but got: " <> show arr'       where         update :: Value -> (Maybe [Value], Value) -> Value         update arr (Just idxs@[_, _, _], v) =           fromMaybe arr $ writeArray (map (IndexingFix . asInt64) idxs) arr v         update _ _ =           error "scatter_3d expects 3-dimensional indices"-    def "hist_1d" = Just . fun6 $ \_ arr fun _ is vs ->-      foldM-        (update fun)-        arr-        (zip (map asInt64 $ snd $ fromArray is) (snd $ fromArray vs))+    def "hist_1d" = Just . fun6 $ \_ arr fun _ is vs -> do+      arr' <- force arr+      is' <- map asInt64 . snd <$> fromArray is+      vs' <- snd <$> fromArray vs+      foldM (update fun) arr' $ zip is' vs'       where         op = apply2 mempty mempty         update fun arr (i, v) =           fromMaybe arr <$> updateArray (op fun) [IndexingFix i] arr v-    def "hist_2d" = Just . fun6 $ \_ arr fun _ is vs ->-      foldM-        (update fun)-        arr-        (zip (map fromTuple $ snd $ fromArray is) (snd $ fromArray vs))+    def "hist_2d" = Just . fun6 $ \_ arr fun _ is vs -> do+      arr' <- force arr+      is' <- map fromTuple . snd <$> fromArray is+      vs' <- snd <$> fromArray vs+      foldM (update fun) arr' $ zip is' vs'       where         op = apply2 mempty mempty         update fun arr (Just idxs@[_, _], v) =@@ -1998,11 +2155,11 @@             <$> updateArray (op fun) (map (IndexingFix . asInt64) idxs) arr v         update _ _ _ =           error "hist_2d: bad index value"-    def "hist_3d" = Just . fun6 $ \_ arr fun _ is vs ->-      foldM-        (update fun)-        arr-        (zip (map fromTuple $ snd $ fromArray is) (snd $ fromArray vs))+    def "hist_3d" = Just . fun6 $ \_ arr fun _ is vs -> do+      arr' <- force arr+      is' <- map fromTuple . snd <$> fromArray is+      vs' <- snd <$> fromArray vs+      foldM (update fun) arr' $ zip is' vs'       where         op = apply2 mempty mempty         update fun arr (Just idxs@[_, _, _], v) =@@ -2012,8 +2169,10 @@           error "hist_2d: bad index value"     def "partition" = Just $       fun3 $ \k f xs -> do-        let (ShapeDim _ rowshape, xs') = fromArray xs+        (xs_shape, xs') <- fromArray xs +        let ShapeDim _ rowshape = xs_shape+             next outs x = do               i <- asInt <$> apply noLoc mempty f x               pure $ insertAt i x outs@@ -2031,8 +2190,10 @@         insertAt i x (l : ls) = l : insertAt (i - 1) x ls         insertAt _ _ ls = ls     def "scatter_stream" = Just $-      fun3 $ \dest f vs ->-        case (dest, vs) of+      fun3 $ \dest f vs -> do+        dest' <- force dest+        vs' <- force vs+        case (dest', vs') of           ( ValueArray dest_shape dest_arr,             ValueArray _ vs_arr             ) -> do@@ -2044,10 +2205,12 @@                 _ ->                   error $ "scatter_stream produced: " <> show acc'           _ ->-            error $ "scatter_stream expects array, but got: " <> prettyString (show vs, show vs)+            error $ "scatter_stream expects array, but got: " <> prettyString (show dest', show vs')     def "hist_stream" = Just $-      fun5 $ \dest op _ne f vs ->-        case (dest, vs) of+      fun5 $ \dest op _ne f vs -> do+        dest' <- force dest+        vs' <- force vs+        case (dest', vs') of           ( ValueArray dest_shape dest_arr,             ValueArray _ vs_arr             ) -> do@@ -2059,7 +2222,7 @@                 _ ->                   error $ "hist_stream produced: " <> show acc'           _ ->-            error $ "hist_stream expects array, but got: " <> prettyString (show dest, show vs)+            error $ "hist_stream expects array, but got: " <> prettyString (show dest', show vs')     def "acc_write" = Just $       fun3 $ \acc i v ->         case (acc, i) of@@ -2096,7 +2259,8 @@           f i j =             indexArray [IndexingFix $ offset' + i * s1' + j * s2'] arr -      case mk1 [mk2 [f i j | j <- iota n2'] | i <- iota n1'] of+      vs <- runMaybeT $ mk1 [mk2 [f i j | j <- iota n2'] | i <- iota n1']+      case vs of         Just arr' -> pure arr'         Nothing ->           bad mempty mempty $@@ -2110,9 +2274,11 @@         ShapeDim n1 (ShapeDim n2 _) -> do           let iota x = [0 .. x - 1]               f arr' (i, j) =-                writeArray [IndexingFix $ offset' + i * s1' + j * s2'] arr'+                MaybeT . pure . writeArray [IndexingFix $ offset' + i * s1' + j * s2'] arr'                   =<< indexArray [IndexingFix i, IndexingFix j] v-          case foldM f arr [(i, j) | i <- iota n1, j <- iota n2] of+          dest <- force arr+          o <- runMaybeT $ foldM f dest [(i, j) | i <- iota n1, j <- iota n2]+          case o of             Just arr' -> pure arr'             Nothing ->               bad mempty mempty $@@ -2135,7 +2301,8 @@           f i j l =             indexArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr -      case mk1 [mk2 [mk3 [f i j l | l <- iota n3'] | j <- iota n2'] | i <- iota n1'] of+      vs <- runMaybeT $ mk1 [mk2 [mk3 [f i j l | l <- iota n3'] | j <- iota n2'] | i <- iota n1']+      case vs of         Just arr' -> pure arr'         Nothing ->           bad mempty mempty $@@ -2150,9 +2317,11 @@         ShapeDim n1 (ShapeDim n2 (ShapeDim n3 _)) -> do           let iota x = [0 .. x - 1]               f arr' (i, j, l) =-                writeArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr'+                MaybeT . pure . writeArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr'                   =<< indexArray [IndexingFix i, IndexingFix j, IndexingFix l] v-          case foldM f arr [(i, j, l) | i <- iota n1, j <- iota n2, l <- iota n3] of+          dest <- force arr+          o <- runMaybeT $ foldM f dest [(i, j, l) | i <- iota n1, j <- iota n2, l <- iota n3]+          case o of             Just arr' -> pure arr'             Nothing ->               bad mempty mempty $@@ -2178,7 +2347,8 @@           f i j l m =             indexArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr -      case mk1 [mk2 [mk3 [mk4 [f i j l m | m <- iota n4'] | l <- iota n3'] | j <- iota n2'] | i <- iota n1'] of+      vs <- runMaybeT $ mk1 [mk2 [mk3 [mk4 [f i j l m | m <- iota n4'] | l <- iota n3'] | j <- iota n2'] | i <- iota n1']+      case vs of         Just arr' -> pure arr'         Nothing ->           bad mempty mempty $@@ -2194,9 +2364,11 @@         ShapeDim n1 (ShapeDim n2 (ShapeDim n3 (ShapeDim n4 _))) -> do           let iota x = [0 .. x - 1]               f arr' (i, j, l, m) =-                writeArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr'+                MaybeT . pure . writeArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr'                   =<< indexArray [IndexingFix i, IndexingFix j, IndexingFix l, IndexingFix m] v-          case foldM f arr [(i, j, l, m) | i <- iota n1, j <- iota n2, l <- iota n3, m <- iota n4] of+          dest <- force arr+          o <- runMaybeT $ foldM f dest [(i, j, l, m) | i <- iota n1, j <- iota n2, l <- iota n3, m <- iota n4]+          case o of             Just arr' -> pure arr'             Nothing ->               bad mempty mempty $@@ -2210,7 +2382,8 @@             listPair (xs, ys) =               [toArray' xs_shape xs, toArray' ys_shape ys] -        pure $ toTuple $ listPair $ unzip $ map (fromPair . fromTuple) $ snd $ fromArray x+        x' <- snd <$> fromArray x+        pure $ toTuple $ listPair $ unzip $ map (fromPair . fromTuple) x'       where         fromPair (Just [x, y]) = (x, y)         fromPair _ = error "Not a pair"@@ -2218,31 +2391,39 @@       fun2 $ \xs ys -> do         let ShapeDim _ xs_rowshape = valueShape xs             ShapeDim _ ys_rowshape = valueShape ys+        xs' <- snd <$> fromArray xs+        ys' <- snd <$> fromArray ys         pure $           toArray' (ShapeRecord (tupleFields [xs_rowshape, ys_rowshape])) $             map toTuple $-              transpose [snd $ fromArray xs, snd $ fromArray ys]+              transpose [xs', ys']     def "concat" = Just $       fun2 $ \xs ys -> do-        let (ShapeDim _ rowshape, xs') = fromArray xs-            (_, ys') = fromArray ys+        (xs_shape, xs') <- fromArray xs+        (_, ys') <- fromArray ys+        let ShapeDim _ rowshape = xs_shape         pure $ toArray' rowshape $ xs' ++ ys'     def "transpose" = Just $       fun1 $ \xs -> do-        let (ShapeDim n (ShapeDim m shape), xs') = fromArray xs+        (xs_shape, xs') <- fromArray xs+        let ShapeDim n (ShapeDim m shape) = xs_shape+        rows <- mapM (fmap snd . fromArray) xs'         pure $           toArray (ShapeDim m (ShapeDim n shape)) $             map (toArray (ShapeDim n shape)) $               -- Slight hack to work around empty dimensions.               genericTake m $-                transpose (map (snd . fromArray) xs') ++ repeat []+                transpose rows ++ repeat []     def "flatten" = Just $       fun1 $ \xs -> do-        let (ShapeDim n (ShapeDim m shape), xs') = fromArray xs-        pure $ toArray (ShapeDim (n * m) shape) $ concatMap (snd . fromArray) xs'+        (xs_shape, xs') <- fromArray xs+        let ShapeDim n (ShapeDim m shape) = xs_shape+        rows <- mapM (fmap snd . fromArray) xs'+        pure $ toArray (ShapeDim (n * m) shape) $ concat rows     def "unflatten" = Just $       fun3 $ \n m xs -> do-        let (ShapeDim xs_size innershape, xs') = fromArray xs+        (xs_shape, xs') <- fromArray xs+        let ShapeDim xs_size innershape = xs_shape             rowshape = ShapeDim (asInt64 m) innershape             shape = ShapeDim (asInt64 n) rowshape         if asInt64 n * asInt64 m /= xs_size || asInt64 n < 0 || asInt64 m < 0@@ -2261,22 +2442,28 @@     def "vjp2" = Just $ fun3 doVJP2     def "jmp2" = Just $ fun3 $ \f x seeds -> do       v <- apply noLoc mempty f x+      seeds' <- snd <$> fromArray seeds       dvs <-         toArray' (valueShape v) . map (project "1")-          <$> mapM (doJVP2 f x) (snd (fromArray seeds))+          <$> mapM (doJVP2 f x) seeds'       pure $ toTuple [v, dvs]     def "mjp2" = Just $ fun3 $ \f x seeds -> do       v <- apply noLoc mempty f x+      seeds' <- snd <$> fromArray seeds       dvs <-         toArray' (valueShape x) . map (project "1")-          <$> mapM (doVJP2 f x) (snd (fromArray seeds))+          <$> mapM (doVJP2 f x) seeds'       pure $ toTuple [v, dvs]     def "with_vjp" = Just $ fun3 $ \f _ arg ->       -- XXX? We simply ignore the custom derivative. This is correct, but makes       -- it more of a hassle to test them.       apply noLoc mempty f arg     def "acc" = Nothing-    def s | nameFromText s `M.member` namesToPrimTypes = Nothing+    def fname+      | nameFromText fname `M.member` namesToPrimTypes = Nothing+      | Just op <- determineIO fname =+          Just $ TermPoly Nothing $ \t ->+            pure $ ValueFun $ doIO <=< op (evalTypeFully t) <=< force     def s = error $ "Missing intrinsic: " ++ T.unpack s      tdef :: Name -> Maybe TypeBinding@@ -2296,9 +2483,16 @@ intrinsicsNot :: Value intrinsicsNot = intrinsicVal "!" +-- | Interpret a single expression. interpretExp :: Ctx -> Exp -> F ExtOp Value interpretExp ctx e = runEvalM (ctxImports ctx) $ eval (ctxEnv ctx) e +-- | Interpret an application of a function value to an argument value. It+-- better be well-typed!+interpretApply :: Ctx -> Value -> Value -> F ExtOp Value+interpretApply ctx f arg =+  runEvalM (ctxImports ctx) $ apply mempty (ctxEnv ctx) f arg+ interpretDecs :: Ctx -> [Dec] -> F ExtOp Env interpretDecs ctx decs =   runEvalM (ctxImports ctx) $ do@@ -2389,7 +2583,7 @@   where     updateType (vt : vts) (Scalar (Arrow als pn d pt (RetType dims rt))) = do       checkInput vt pt-      Scalar . Arrow als pn d (valueStructType vt) . RetType dims . toRes Nonunique+      Scalar . Arrow als pn d (valueStructType vt) . RetType dims . toRes Nonfresh         <$> updateType vts (toStruct rt)     updateType _ t =       Right t
+ src/Language/Futhark/Interpreter/FFI/AtomicList.hs view
@@ -0,0 +1,20 @@+module Language.Futhark.Interpreter.FFI.AtomicList+  ( AtomicList,+    new,+    prepend,+    flush,+  )+where++import Data.IORef (IORef, atomicModifyIORef, newIORef)++newtype AtomicList v = AtomicList (IORef [v])++new :: IO (AtomicList v)+new = AtomicList <$> newIORef []++prepend :: v -> AtomicList v -> IO ()+prepend v (AtomicList r) = atomicModifyIORef r $ (,()) . (v :)++flush :: AtomicList v -> IO [v]+flush (AtomicList r) = atomicModifyIORef r ([],)
+ src/Language/Futhark/Interpreter/FFI/Push.hs view
@@ -0,0 +1,184 @@+module Language.Futhark.Interpreter.FFI.Push+  ( put,+    putArgs,+    get,+    hasLazy,+    getLazy,+    lazyGet,+    ResShape (..),+    resultShape,+  )+where++import Control.Monad (zipWithM)+import Control.Monad.Except (throwError)+import Data.Array qualified as A+import Data.Map qualified as M+import Data.Text qualified as T+import Language.Futhark.Interpreter.FFI.ServerM+import Language.Futhark.Interpreter.Values qualified as I+import Language.Futhark.Syntax (Int64, Name, nameToString)++toArray :: [a] -> A.Array Int a+toArray vs = A.listArray (0, length vs - 1) vs++get :: I.ValueShape -> ValueRef -> ServerM (I.Value m)+get I.ShapeLeaf vr = I.ValuePrim <$> getPrim vr+get rshp@(I.ShapeDim {}) vr+  | primArray rshp =+      -- Retrieving the array in one go is much faster than element by+      -- element.+      maybe (getArray rshp) (pure . I.fromDataValue) =<< getData vr+  | otherwise = getArray rshp+  where+    primArray (I.ShapeDim _ shp) = primArray shp+    primArray I.ShapeLeaf = True+    primArray _ = False+    getArray :: I.ValueShape -> ServerM (I.Value m)+    getArray shp = getArray' shp []+    getArray' :: I.ValueShape -> [Int64] -> ServerM (I.Value m)+    getArray' shp@(I.ShapeDim n cshp) is = I.ValueArray shp . toArray <$> mapM (getArray' cshp . (: is)) [0 .. n - 1]+    getArray' cshp is = index (reverse is) vr >>= get cshp+get (I.ShapeRecord sm) vr =+  I.ValueRecord+    <$> sequence (M.mapWithKey (\fn cshp -> project vr fn >>= get cshp) sm)+get shp@(I.ShapeSum sm) vr = do+  (vn, vrs) <- destruct vr+  shps <- throwNothing ("Invalid variant " ++ nameToString vn ++ " in shape " ++ show sm ++ ".") $ M.lookup vn sm+  I.ValueSum shp vn <$> zipWithM get shps vrs++-- | Does this value contain any references to values residing on a server?+hasLazy :: I.Value m -> Bool+hasLazy I.ValueLazyFFI {} = True+hasLazy (I.ValueArray _ arr) = any hasLazy $ A.elems arr+hasLazy (I.ValueRecord fs) = any hasLazy fs+hasLazy (I.ValueSum _ _ vs) = any hasLazy vs+hasLazy _ = False++-- | Get all the values residing on the server. The resulting 'I.Value' has no+-- 'I.ValueLazyFFI' in it.+getLazy :: I.Value a -> ServerM (I.Value a)+getLazy (I.ValueArray shp arr) = I.ValueArray shp <$> mapM getLazy arr+getLazy (I.ValueRecord m) = I.ValueRecord <$> mapM getLazy m+getLazy (I.ValueSum shp vn vs) = I.ValueSum shp vn <$> mapM getLazy vs+getLazy (I.ValueLazyFFI shp r os) = do+  v <- get shp r+  pure $ foldl (\(I.ValueArray _ a) i -> a A.! fromIntegral i) v $ reverse os+getLazy v = pure v++-- | As 'get', but arrays, including those in records, are left on the server.+lazyGet :: I.ValueShape -> ValueRef -> ServerM (I.Value m)+lazyGet shp@(I.ShapeDim {}) vr = pure $ I.ValueLazyFFI shp vr []+lazyGet (I.ShapeRecord sm) vr =+  I.ValueRecord+    <$> sequence (M.mapWithKey (\fn cshp -> project vr fn >>= lazyGet cshp) sm)+lazyGet shp vr = get shp vr++-- | Put these values on the server as the arguments of the given entry point.+putArgs :: Name -> [I.Value m] -> ServerM [ValueRef]+putArgs fn vs = do+  ts <- inputs fn+  zipWithM put ts vs++put :: TypeName -> I.Value m -> ServerM ValueRef+put _ (I.ValuePrim p) = putPrim p+put tn pv@(I.ValueArray shp _)+  -- TODO: array elements residing on the server currently have to be fetched+  -- first, but this could be optimised further.+  | hasLazy pv = put tn =<< getLazy pv+  | otherwise = do+      et <- elemType tn+      mapM (put et) (flatten pv) >>= mkArray tn (dims shp)+  where+    flatten :: I.Value m -> [I.Value m]+    flatten (I.ValueArray _ a) = foldl (\o n -> o ++ flatten n) [] $ A.elems a+    flatten v = [v]+    dims :: I.ValueShape -> [Int64]+    dims (I.ShapeDim n cshp) = n : dims cshp+    dims _ = []+put tn (I.ValueRecord vm) = do+  fm <- M.fromList <$> fieldOrder tn+  vrm <- sequence $ M.intersectionWith put fm vm+  mkRecord tn vrm+put tn (I.ValueSum _ vn vs) = do+  vts <-+    throwNothing ("Invalid variant " ++ nameToString vn ++ " in type " ++ T.unpack tn ++ ".") . M.lookup vn+      =<< variants tn+  vrs <- zipWithM put vts vs+  mkSum tn vn vrs+-- The value already resides on the server.+put _ (I.ValueLazyFFI _ r []) = pure r+put tn v@(I.ValueLazyFFI {}) = do+  -- A partially indexed array cannot be constructed on the server, as the+  -- 'index' command only indexes all the way down to an element, so this+  -- one does have to go through the interpreter.+  iv <- getLazy v+  put tn iv+put _ v = error $ "Values of type " ++ show v ++ " are unsupported in FFI."++-- | How much of the shape of a value its type determines. Array dimensions may+-- be unknown at the type level, so they must be extracted from the actual+-- server-side value.+data ResShape+  = -- | An array of any rank; the argument describes its elements (after+    -- stripping array dimensions).+    ResArray ResShape+  | -- | A record, whose fields are described individually.+    ResRecord (M.Map Name ResShape)+  | -- | A sum type, whose constructor payloads are described individually.+    -- Only the payload of the constructor that is actually present can be+    -- inspected, so the resulting shape describes only that constructor.+    ResSum (M.Map Name [ResShape])+  | -- | Determined by the type alone.+    ResKnown I.ValueShape++-- | Determine the shape of a value residing on the server, consulting the+-- server for whatever the type did not settle.+resultShape :: ResShape -> ValueRef -> ServerM I.ValueShape+resultShape (ResKnown shp) _ = pure shp+resultShape (ResRecord fs) vr =+  I.ShapeRecord <$> M.traverseWithKey (\f shp -> resultShape shp =<< project vr f) fs+resultShape (ResSum cs) vr = do+  (c, vrs) <- destruct vr+  payload <- throwNothing ("Unexpected variant " ++ nameToString c ++ ".") $ M.lookup c cs+  I.ShapeSum . M.singleton c <$> zipWithM resultShape payload vrs+resultShape (ResArray eshp) vr = do+  dims <- shape vr+  foldr I.ShapeDim <$> elemShape (length dims) eshp vr <*> pure dims++-- | The shape of the elements of an array. The elements cannot be inspected+-- one at a time, as there may not be any, so a record is instead unzipped+-- into one array per field - which has a shape even when it is empty. The+-- outer dimensions of those arrays are the ones we started with, and are+-- dropped again.+elemShape :: Int -> ResShape -> ValueRef -> ServerM I.ValueShape+elemShape _ (ResKnown shp) _ = pure shp+elemShape k (ResRecord fs) arr = do+  etn <- elemType =<< vtype arr+  order <- fieldOrder etn+  refs <- unzipArray arr $ length order+  I.ShapeRecord . M.fromList <$> zipWithM onField order refs+  where+    onField (f, _) ref = do+      shp <- maybe (unknownField f) (\e -> resultShape (arrayOf e) ref) $ M.lookup f fs+      pure (f, dropDims k shp)+    unknownField f =+      throwError $ "Unzipping produced unexpected field " ++ nameToString f ++ "."+elemShape _ (ResSum _) _ =+  -- Unlike records, an array of sums cannot be split into arrays that have a+  -- shape even when empty.+  throwError "Cannot determine the sizes of an array of sum types."+elemShape _ (ResArray _) _ =+  -- 'ResArray' covers every dimension at once, so it never describes the+  -- elements of an array.+  throwError "Array element is itself an array."++-- | The shape of an array whose elements are described by the argument.+arrayOf :: ResShape -> ResShape+arrayOf (ResArray eshp) = ResArray eshp+arrayOf shp = ResArray shp++dropDims :: Int -> I.ValueShape -> I.ValueShape+dropDims 0 shp = shp+dropDims k (I.ShapeDim _ shp) = dropDims (k - 1) shp+dropDims _ _ = error "Unzipped field has too few dimensions."
+ src/Language/Futhark/Interpreter/FFI/ServerM.hs view
@@ -0,0 +1,393 @@+module Language.Futhark.Interpreter.FFI.ServerM+  ( FS.TypeName,+    ValueRef,+    Server,+    startServer,+    newServer,+    stopServer,+    ServerM,+    runServerM,+    gc,+    release,+    call,+    -- Interrogation+    inputs,+    output,+    kind,+    vtype,+    -- Primitives+    getPrim,+    putPrim,+    putData,+    getData,+    -- Arrays+    rank,+    elemType,+    mkArray,+    shape,+    index,+    -- Records+    fieldOrder,+    mkRecord,+    project,+    unzipArray,+    -- Sums+    variants,+    mkSum,+    destruct,+    -- Error handling convenience+    throwNothing,+  )+where++import Control.Exception (catch)+import Control.Monad (replicateM)+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Reader (ReaderT, asks, runReaderT)+import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef)+import Data.List (intercalate)+import Data.Map qualified as M+import Data.Set qualified as S+import Data.Text qualified as T+import Data.Unique (hashUnique, newUnique)+import Data.Vector.Storable qualified as V+import Futhark.Data qualified as D+import Futhark.Server qualified as FS+import Futhark.Server.Values qualified as FS+import Futhark.Util (mapAccumLM)+import Language.Futhark.Interpreter.FFI.AtomicList as AL+import Language.Futhark.Syntax++-- | Converts a PrimValue to a Data Value+pToD :: PrimValue -> D.Value+pToD (SignedValue (Int8Value i)) = D.putValue1 i+pToD (SignedValue (Int16Value i)) = D.putValue1 i+pToD (SignedValue (Int32Value i)) = D.putValue1 i+pToD (SignedValue (Int64Value i)) = D.putValue1 i+pToD (UnsignedValue (Int8Value i)) = D.putValue1 (fromIntegral i :: Word8)+pToD (UnsignedValue (Int16Value i)) = D.putValue1 (fromIntegral i :: Word16)+pToD (UnsignedValue (Int32Value i)) = D.putValue1 (fromIntegral i :: Word32)+pToD (UnsignedValue (Int64Value i)) = D.putValue1 (fromIntegral i :: Word64)+pToD (FloatValue (Float16Value f)) = D.putValue1 f+pToD (FloatValue (Float32Value f)) = D.putValue1 f+pToD (FloatValue (Float64Value f)) = D.putValue1 f+pToD (BoolValue b) = D.putValue1 b++-- | Converts a Data Value to a PrimValue, assuming that it is a singleton+dToP :: D.Value -> PrimValue+dToP (D.I8Value _ vs) = SignedValue $ Int8Value $ vs V.! 0+dToP (D.I16Value _ vs) = SignedValue $ Int16Value $ vs V.! 0+dToP (D.I32Value _ vs) = SignedValue $ Int32Value $ vs V.! 0+dToP (D.I64Value _ vs) = SignedValue $ Int64Value $ vs V.! 0+dToP (D.U8Value _ vs) = UnsignedValue $ Int8Value $ fromIntegral $ vs V.! 0+dToP (D.U16Value _ vs) = UnsignedValue $ Int16Value $ fromIntegral $ vs V.! 0+dToP (D.U32Value _ vs) = UnsignedValue $ Int32Value $ fromIntegral $ vs V.! 0+dToP (D.U64Value _ vs) = UnsignedValue $ Int64Value $ fromIntegral $ vs V.! 0+dToP (D.F16Value _ vs) = FloatValue $ Float16Value $ vs V.! 0+dToP (D.F32Value _ vs) = FloatValue $ Float32Value $ vs V.! 0+dToP (D.F64Value _ vs) = FloatValue $ Float64Value $ vs V.! 0+dToP (D.BoolValue _ vs) = BoolValue $ vs V.! 0++newtype ValueRef = ValueRef (IORef FS.VarName)++data Server = Server+  { server :: FS.Server,+    -- | Variables whose 'ValueRef' has been garbage collected.+    queue :: AL.AtomicList FS.VarName,+    -- | Variables created by us that have not yet been freed.+    live :: IORef (S.Set FS.VarName)+  }++newtype ServerM a = ServerM (ReaderT Server (ExceptT String IO) a)+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadError String,+      MonadIO+    )++askServer :: ServerM FS.Server+askServer = ServerM $ asks server++askQueue :: ServerM (AL.AtomicList FS.VarName)+askQueue = ServerM $ asks queue++modifyLive :: (S.Set FS.VarName -> S.Set FS.VarName) -> ServerM ()+modifyLive f = do+  r <- ServerM $ asks live+  liftIO $ atomicModifyIORef' r $ (,()) . f++startServer :: FS.ServerCfg -> IO Server+startServer cfg = newServer =<< FS.startServer cfg++-- | Use an already-running server. Shutting it down remains the+-- responsibility of whoever started it.+newServer :: FS.Server -> IO Server+newServer s = Server s <$> AL.new <*> newIORef mempty++-- | Shut down the server. Returns a message on termination failure.+stopServer :: Server -> IO (Maybe T.Text)+stopServer s =+  (Nothing <$ FS.stopServer (server s))+    `catch` \(FS.ServerException e) -> pure $ Just e++runServerM :: Server -> ServerM a -> IO (Either String a)+runServerM s (ServerM m) = runExceptT $ runReaderT m s++varName :: ValueRef -> ServerM FS.VarName+varName (ValueRef r) = liftIO $ readIORef r++uniqueName :: ServerM FS.VarName+uniqueName = ("v" <>) . T.show . hashUnique <$> liftIO newUnique++mkValueRef :: FS.VarName -> ServerM ValueRef+mkValueRef n = do+  modifyLive $ S.insert n+  r <- liftIO $ newIORef n+  q <- askQueue+  _ <- liftIO $ mkWeakIORef r $ AL.prepend n q+  pure $ ValueRef r++gc :: ServerM ()+gc = freeVars =<< liftIO . AL.flush =<< askQueue++freeVars :: [FS.VarName] -> ServerM ()+freeVars vns = do+  s <- askServer+  liftIO (FS.cmdFree s vns)+    >>= throwServerJust ("cmdFree failed on variables " ++ csList (map T.unpack vns) ++ ".")+  modifyLive (`S.difference` S.fromList vns)++-- | End the use of this 'Server'. The variables of the given values are+-- adopted by the caller under the given names, and every other variable we+-- have created is freed, whether or not its 'ValueRef' is still reachable.+-- Neither the 'Server' nor any 'ValueRef' may be used afterwards. A variable+-- may occur more than once, in which case it is adopted under the first of its+-- names. Returns the name of the variable of each value.+release :: [(ValueRef, FS.VarName)] -> ServerM [FS.VarName]+release adopted = do+  s <- askServer+  -- Everything in the queue is also live, so it is freed below.+  _ <- askQueue >>= liftIO . AL.flush+  srcs <- mapM (varName . fst) adopted+  let adopt renamed (src, dst)+        | Just dst' <- M.lookup src renamed = pure (renamed, dst')+        | otherwise = do+            liftIO (FS.cmdRename s src dst)+              >>= throwServerJust ("cmdRename failed on variable " ++ T.unpack src ++ ".")+            pure (M.insert src dst renamed, dst)+  (renamed, dsts) <- mapAccumLM adopt mempty $ zip srcs $ map snd adopted+  modifyLive (`S.difference` M.keysSet renamed)+  freeVars . S.toList =<< liftIO . readIORef =<< ServerM (asks live)+  pure dsts++call :: Name -> [ValueRef] -> ServerM ValueRef+call fn ps = do+  s <- askServer+  nps <- mapM varName ps+  ndst <- uniqueName+  -- A failing call is usually the program itself failing (e.g. OOB), so report+  -- just what the server said.+  _ <-+    liftIO (FS.cmdCall s (nameToText fn) ndst nps)+      >>= either (throwError . T.unpack . T.unlines . FS.failureMsg) pure+  mkValueRef ndst++-- Interrogation+inputs :: Name -> ServerM [FS.TypeName]+inputs fn = do+  s <- askServer+  map FS.inputType <$> (liftIO (FS.cmdInputs s $ nameToText fn) >>= throwServerLeft ("cmdInputs failed on function " ++ nameToString fn ++ "."))++output :: Name -> ServerM FS.TypeName+output fn = do+  s <- askServer+  FS.outputType <$> (liftIO (FS.cmdOutput s $ nameToText fn) >>= throwServerLeft ("cmdOutput failed on function " ++ nameToString fn ++ "."))++kind :: FS.TypeName -> ServerM FS.Kind+kind tn = do+  s <- askServer+  liftIO (FS.cmdKind s tn) >>= throwServerLeft ("cmdKind failed on type " ++ T.unpack tn ++ ".")++vtype :: ValueRef -> ServerM FS.TypeName+vtype vr = do+  s <- askServer+  vn <- varName vr+  liftIO (FS.cmdType s vn) >>= throwServerLeft ("cmdType failed on variable " ++ T.unpack vn ++ ".")++-- Primitives+getPrim :: ValueRef -> ServerM PrimValue+getPrim vr = do+  s <- askServer+  nsrc <- varName vr+  v <- liftIO (FS.getValue s nsrc) >>= throwLeft ("Failed to get primitive variable " ++ T.unpack nsrc ++ ".")+  pure $ dToP v++putPrim :: PrimValue -> ServerM ValueRef+putPrim = putData . pToD++-- | Put an entire value on the server at once. This is only possible for+-- values that can be represented in the Futhark data format (primitives and+-- arrays of primitive).+putData :: D.Value -> ServerM ValueRef+putData v = do+  s <- askServer+  ndst <- uniqueName+  liftIO (FS.putValue s ndst v)+    >>= throwServerJust ("Failed to put value of type " ++ T.unpack (D.valueTypeText (D.valueType v)) ++ ".")+  mkValueRef ndst++-- Arrays+rank :: FS.TypeName -> ServerM Int+rank tn = do+  s <- askServer+  liftIO (FS.cmdRank s tn) >>= throwServerLeft ("cmdRank failed on type " ++ T.unpack tn ++ ".")++elemType :: FS.TypeName -> ServerM FS.TypeName+elemType tn = do+  s <- askServer+  liftIO (FS.cmdElemtype s tn) >>= throwServerLeft ("cmdElemtype failed on type " ++ T.unpack tn ++ ".")++mkArray :: FS.TypeName -> [Int64] -> [ValueRef] -> ServerM ValueRef+mkArray tn dims vs = do+  s <- askServer+  vns <- mapM varName vs+  dst <- uniqueName+  liftIO (FS.cmdNewArray s dst tn (map fromIntegral dims) vns) >>= throwServerJust ("cmdNewArray failed on type " ++ T.unpack tn ++ " with variables " ++ csList (map T.unpack vns) ++ ".")+  mkValueRef dst++shape :: ValueRef -> ServerM [Int64]+shape vr = do+  s <- askServer+  vn <- varName vr+  map fromIntegral <$> (liftIO (FS.cmdShape s vn) >>= throwServerLeft ("cmdShape failed on variable " ++ T.unpack vn ++ "."))++-- | Retrieve an entire value from the server at once. This is only possible for+-- values that can be represented in the Futhark data format (primitives and+-- arrays of primitive).+getData :: ValueRef -> ServerM (Maybe D.Value)+getData vr = do+  s <- askServer+  n <- varName vr+  either (const Nothing) Just <$> liftIO (FS.getValue s n)++index :: [Int64] -> ValueRef -> ServerM ValueRef+index is src = do+  s <- askServer+  nsrc <- varName src+  ndst <- uniqueName+  liftIO (FS.cmdIndex s ndst nsrc $ map fromIntegral is) >>= throwServerJust ("cmdIndex failed on source " ++ T.unpack nsrc ++ ", destination " ++ T.unpack ndst ++ ", and index " ++ show is ++ ".")+  mkValueRef ndst++-- Records++-- | The fields of a record type, in the order the server uses.+fieldOrder :: FS.TypeName -> ServerM [(Name, FS.TypeName)]+fieldOrder tn = do+  s <- askServer+  fs <- liftIO (FS.cmdFields s tn) >>= throwServerLeft ("cmdFields failed on type " ++ T.unpack tn ++ ".")+  pure $ map (\f -> (nameFromText $ FS.fieldName f, FS.fieldType f)) fs++-- | Split an array of records into one array per field, in 'fieldOrder'. The+-- fields of an array cannot be projected one element at a time, and doing so+-- would anyway be impossible for an empty array.+unzipArray :: ValueRef -> Int -> ServerM [ValueRef]+unzipArray src n = do+  s <- askServer+  nsrc <- varName src+  ndsts <- replicateM n uniqueName+  liftIO (FS.cmdUnzip s nsrc ndsts)+    >>= throwServerJust ("cmdUnzip failed on variable " ++ T.unpack nsrc ++ ".")+  mapM mkValueRef ndsts++mkRecord :: FS.TypeName -> M.Map Name ValueRef -> ServerM ValueRef+mkRecord tn vrm = do+  s <- askServer+  fns <- map (nameFromText . FS.fieldName) <$> (liftIO (FS.cmdFields s tn) >>= throwServerLeft ("cmdFields failed on type " ++ T.unpack tn ++ "."))+  vns <-+    mapM+      ( \fn ->+          throwNothing ("Missing field " ++ nameToString fn ++ " when constructing record of type " ++ T.unpack tn ++ ".") (M.lookup fn vrm)+            >>= varName+      )+      fns+  dst <- uniqueName+  liftIO (FS.cmdNew s dst tn vns) >>= throwServerJust ("cmdNew failed on type " ++ T.unpack tn ++ " with variables " ++ csList (map T.unpack vns) ++ ".")+  mkValueRef dst++project :: ValueRef -> Name -> ServerM ValueRef+project src fn = do+  s <- askServer+  nsrc <- varName src+  ndst <- uniqueName+  liftIO (FS.cmdProject s ndst nsrc $ nameToText fn)+    >>= throwServerJust ("cmdProject failed on source " ++ T.unpack nsrc ++ ", destination " ++ T.unpack ndst ++ ", and field " ++ nameToString fn ++ ".")+  mkValueRef ndst++-- Sums+variants :: FS.TypeName -> ServerM (M.Map Name [FS.TypeName])+variants tn = do+  s <- askServer+  vs <- liftIO (FS.cmdVariants s tn) >>= throwServerLeft ("cmdVariants failed on type " ++ T.unpack tn ++ ".")+  pure $ M.fromList $ map (\v -> (nameFromText $ FS.variantName v, FS.variantTypes v)) vs++mkSum :: FS.TypeName -> Name -> [ValueRef] -> ServerM ValueRef+mkSum tn vn vrs = do+  s <- askServer+  vns <- mapM varName vrs+  dst <- uniqueName+  liftIO (FS.cmdConstruct s dst tn (nameToText vn) vns)+    >>= throwServerJust ("cmdConstruct failed on type " ++ T.unpack tn ++ ", variant " ++ nameToString vn ++ " with variables " ++ csList (map T.unpack vns) ++ ".")+  mkValueRef dst++-- | The variant of a sum, and its payload.+destruct :: ValueRef -> ServerM (Name, [ValueRef])+destruct src = do+  vn <- variant src+  tn <- vtype src+  vts <- variants tn >>= throwNothing ("Variant " ++ nameToString vn ++ " is not part of its own sum type, " ++ T.unpack tn ++ ". This should be impossible.") . M.lookup vn+  do+    s <- askServer+    nsrc <- varName src+    ndsts <- mapM (const uniqueName) vts+    liftIO (FS.cmdDestruct s nsrc ndsts)+      >>= throwServerJust ("cmdVariants failed on source " ++ T.unpack nsrc ++ ", destinations " ++ csList (map T.unpack ndsts) ++ ".")+    (vn,) <$> mapM mkValueRef ndsts++variant :: ValueRef -> ServerM Name+variant src = do+  s <- askServer+  nsrc <- varName src+  vn <-+    liftIO (FS.cmdVariant s nsrc)+      >>= throwServerLeft ("cmdIndex failed on variable " ++ T.unpack nsrc ++ ".")+  pure $ nameFromText vn++-- Error handling convenience+formatServerError :: String -> FS.CmdFailure -> String+formatServerError e f | e == mempty = formatServerError "Server error." f+formatServerError e f = T.unpack $ T.unlines $ T.pack e : "Failure message:" : FS.failureMsg f++throwServerLeft :: (MonadError String m) => String -> Either FS.CmdFailure a -> m a+throwServerLeft e (Left c) = throwError $ formatServerError e c+throwServerLeft _ (Right v) = pure v++throwServerJust :: (MonadError String m) => String -> Maybe FS.CmdFailure -> m ()+throwServerJust e c = throwJust $ formatServerError e <$> c++throwLeft :: (MonadError String m) => String -> Either T.Text a -> m a+throwLeft t (Left e) = throwError $ T.unpack $ T.unlines [T.pack t, e]+throwLeft _ (Right v) = pure v++throwJust :: (MonadError String m) => Maybe String -> m ()+throwJust (Just e) = throwError e+throwJust Nothing = pure ()++throwNothing :: (MonadError String m) => String -> Maybe a -> m a+throwNothing _ (Just v) = pure v+throwNothing e Nothing = throwError e++csList :: [String] -> String+csList = intercalate ","
+ src/Language/Futhark/Interpreter/IO.hs view
@@ -0,0 +1,255 @@+-- | IO operations exposed through the interpreter.+module Language.Futhark.Interpreter.IO+  ( IOOp (..),+    determineIO,+    doIOOp,+    ioRelativeTo,+  )+where++import Codec.BMP qualified as BMP+import Control.Exception (SomeException, displayException, try)+import Control.Monad+import Control.Monad.IO.Class+import Data.Bits+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.Read qualified as T+import Data.Vector.Storable qualified as SVec+import Data.Vector.Storable.ByteString qualified as SVec+import Futhark.Test.Values qualified as V+import Futhark.Util (runProgramWithExitCode)+import Language.Futhark+  ( FloatType (..),+    IntType (..),+    PrimType (..),+    RetTypeBase (..),+    ScalarTypeBase (..),+    Shape (..),+    TypeBase (..),+    ValueType,+    isTupleRecord,+    prettyString,+    toStruct,+  )+import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI+import Language.Futhark.Interpreter.Values+import System.Exit+import System.FilePath+import System.IO.Temp (withSystemTempDirectory)++-- | The IO operation to perform. The idea of splitting it out into a type like+-- this is to enforce some kind of auditing.+data IOOp+  = LoadBytes FilePath+  | LoadImg FilePath+  | LoadAudio FilePath+  | -- | Load a value of this type.+    LoadValue ValueType FilePath++load ::+  (m ValueType -> FilePath -> m IOOp) ->+  Maybe (m ValueType -> Value m -> m IOOp)+load c = Just $ \t v -> case asByteString v of+  Nothing -> error "loadbytes: not a string"+  Just v' -> c t $ T.unpack $ T.decodeUtf8 v'++primTypeToValueType :: PrimType -> V.PrimType+primTypeToValueType (Signed Int8) = V.I8+primTypeToValueType (Signed Int16) = V.I16+primTypeToValueType (Signed Int32) = V.I32+primTypeToValueType (Signed Int64) = V.I64+primTypeToValueType (Unsigned Int8) = V.U8+primTypeToValueType (Unsigned Int16) = V.U16+primTypeToValueType (Unsigned Int32) = V.U32+primTypeToValueType (Unsigned Int64) = V.U64+primTypeToValueType (FloatType Float16) = V.F16+primTypeToValueType (FloatType Float32) = V.F32+primTypeToValueType (FloatType Float64) = V.F64+primTypeToValueType Bool = V.Bool++-- | The types of the values in a data file that can be loaded as a value of+-- this type. A tuple corresponds to one value per element.+typeToValueTypes :: ValueType -> Maybe [V.ValueType]+typeToValueTypes t = mapM onValue $ fromMaybe [t] $ isTupleRecord t+  where+    onValue (Scalar (Prim pt)) =+      Just $ V.ValueType [] $ primTypeToValueType pt+    onValue (Array _ (Shape ds) (Prim pt)) =+      Just $ V.ValueType (map fromIntegral ds) $ primTypeToValueType pt+    onValue _ = Nothing++loadResType :: ValueType -> ValueType+loadResType (Scalar (Arrow _ _ _ _ (RetType _ rt))) = toStruct rt+loadResType t =+  error $ "loadResType: invalid type " <> prettyString t++-- | Determine which IO operation this is.+--+-- If you want to add a new one, then remember to also add it as an intrinsic in+-- the type checker, and probably also to the prelude.+determineIO :: (Monad m) => T.Text -> Maybe (m ValueType -> Value m -> m IOOp)+determineIO "io_loadbytes" = load $ const $ pure . LoadBytes+determineIO "io_loadimg" = load $ const $ pure . LoadImg+determineIO "io_loadaudio" = load $ const $ pure . LoadAudio+determineIO "io_loadvalue" = load $ \t fname -> do+  t' <- t+  pure $ LoadValue (loadResType t') fname+determineIO _ = Nothing+{-# NOINLINE determineIO #-}++withTempDir :: (FilePath -> IO a) -> IO a+withTempDir = withSystemTempDirectory "futhark"++system ::+  FilePath ->+  [String] ->+  T.Text ->+  IO T.Text+system prog options input = do+  res <- runProgramWithExitCode prog options $ T.encodeUtf8 input+  case res of+    Left err ->+      fail $ prog' <> " failed: " <> show err+    Right (ExitSuccess, stdout_t, _) ->+      pure $ T.pack stdout_t+    Right (ExitFailure code', _, stderr_t) ->+      fail $+        prog'+          <> " failed with exit code "+          <> show code'+          <> " and stderr:\n"+          <> stderr_t+  where+    prog' = "\"" <> prog <> "\""++loadBMP :: FilePath -> IO V.Value+loadBMP bmpfile = do+  res <- BMP.readBMP bmpfile+  case res of+    Left err ->+      fail $ "Failed to read BMP:\n" <> show err+    Right bmp -> do+      let bmp_bs = BMP.unpackBMPToRGBA32 bmp+          (w, h) = BMP.bmpDimensions bmp+          shape = SVec.fromList [fromIntegral h, fromIntegral w]+          pix l =+            let (i, j) = l `divMod` w+                l' = (h - 1 - i) * w + j+                r = fromIntegral $ bmp_bs `BS.index` (l' * 4)+                g = fromIntegral $ bmp_bs `BS.index` (l' * 4 + 1)+                b = fromIntegral $ bmp_bs `BS.index` (l' * 4 + 2)+                a = fromIntegral $ bmp_bs `BS.index` (l' * 4 + 3)+             in (a `shiftL` 24) .|. (r `shiftL` 16) .|. (g `shiftL` 8) .|. b+      pure $ V.U32Value shape $ SVec.generate (w * h) pix++loadImage :: FilePath -> IO V.Value+loadImage imgfile =+  withTempDir $ \dir -> do+    let bmpfile = dir </> takeBaseName imgfile `replaceExtension` "bmp"+    void $ system "convert" [imgfile, "-type", "TrueColorAlpha", bmpfile] mempty+    loadBMP bmpfile++loadPCM :: Int -> FilePath -> IO V.Value+loadPCM num_channels pcmfile = do+  contents <- LBS.readFile pcmfile+  let v = SVec.byteStringToVector $ LBS.toStrict contents+      channel_length = SVec.length v `div` num_channels+      shape =+        SVec.fromList+          [ fromIntegral num_channels,+            fromIntegral channel_length+          ]+      -- ffmpeg outputs audio data in column-major format. `backPermuter` computes the+      -- tranposed indexes for a backpermutation.+      backPermuter i = (i `mod` channel_length) * num_channels + i `div` channel_length+      perm = SVec.generate (SVec.length v) backPermuter+  pure $ V.F64Value shape $ SVec.backpermute v perm++loadAudio :: FilePath -> IO V.Value+loadAudio audiofile = do+  s <- system "ffprobe" [audiofile, "-show_entries", "stream=channels", "-select_streams", "a", "-of", "compact=p=0:nk=1", "-v", "0"] mempty+  case T.decimal s of+    Right (num_channels, _) -> do+      withTempDir $ \dir -> do+        let pcmfile = dir </> takeBaseName audiofile `replaceExtension` "pcm"+        void $ system "ffmpeg" ["-i", audiofile, "-c:a", "pcm_f64le", "-map", "0", "-f", "data", pcmfile] mempty+        loadPCM num_channels pcmfile+    _ -> fail "io.loadaudio failed to detect the number of channels in the audio input"++tryIO :: (MonadIO m) => IO a -> m (Either T.Text a)+tryIO =+  either+    ( pure+        . Left+        . T.pack+        . (displayException :: SomeException -> String)+    )+    (pure . Right)+    <=< liftIO . try++loadValues :: FilePath -> IO [V.Value]+loadValues datafile = do+  contents <- liftIO $ LBS.readFile datafile+  maybe (fail $ "Failed to read data file: " <> datafile) pure $+    V.readValues contents++-- | Resolve relative file paths in the operation relative to the given+-- directory, rather than the current working directory.+ioRelativeTo :: FilePath -> IOOp -> IOOp+ioRelativeTo dir (LoadBytes f) = LoadBytes $ dir </> f+ioRelativeTo dir (LoadImg f) = LoadImg $ dir </> f+ioRelativeTo dir (LoadAudio f) = LoadAudio $ dir </> f+ioRelativeTo dir (LoadValue t f) = LoadValue t $ dir </> f++-- | Turn a loaded value into an interpreter value. Arrays are put on the server,+-- if there is one, as they are very expensive to represent in the interpreter,+-- and are often just passed on to entry points. If the server cannot hold the+-- array, which happens when no entry point uses its type, it is kept in the+-- interpreter instead.+fromData :: Maybe FFI.Server -> V.Value -> IO (Value m)+fromData (Just s) v+  | dims@(_ : _) <- V.valueShape v = do+      let shape = foldr (ShapeDim . fromIntegral) ShapeLeaf dims+      -- We run the FFI GC just as if we call an entry point, to avoid building+      -- up too much data.+      either (const $ pure $ fromDataValue v) (\ref -> pure $ ValueLazyFFI shape ref [])+        =<< FFI.runServerM s (FFI.gc >> FFI.putData v)+fromData _ v = pure $ fromDataValue v++-- | Run an IO operation. Arrays are put on the server, if one is given.+doIOOp :: Maybe FFI.Server -> IOOp -> IO (Either T.Text (Value m))+doIOOp s (LoadBytes fname) =+  tryIO $ fromData s . V.putValue1 =<< BS.readFile fname+doIOOp s (LoadImg fname) =+  tryIO $ fromData s =<< loadImage fname+doIOOp s (LoadAudio fname) =+  tryIO $ fromData s =<< loadAudio fname+doIOOp s (LoadValue t fname) =+  case typeToValueTypes t of+    Nothing ->+      pure . Left . T.pack $+        "Cannot load a value of type "+          <> prettyString t+          <> ": only primitives, arrays of primitives, and tuples of these can be loaded."+    Just ts -> doLoadValue s ts fname+{-# NOINLINE doIOOp #-}++doLoadValue :: Maybe FFI.Server -> [V.ValueType] -> FilePath -> IO (Either T.Text (Value m))+doLoadValue s ts fname = tryIO $ do+  vs <- loadValues fname+  let vs_ts = map V.valueType vs+  when (vs_ts /= ts) . fail $+    "Expected file \""+      <> fname+      <> "\" to contain data of types "+      <> unwords (map prettyString ts)+      <> " but found data of types "+      <> unwords (map prettyString vs_ts)+  asValue <$> mapM (fromData s) vs+  where+    asValue [v] = v+    asValue vs = toTuple vs
src/Language/Futhark/Interpreter/Values.hs view
@@ -26,11 +26,13 @@      -- * Conversion     fromDataValue,+    asByteString,   ) where  import Control.Monad.Identity import Data.Array+import Data.ByteString qualified as BS import Data.List (genericLength) import Data.Map qualified as M import Data.Maybe@@ -42,6 +44,7 @@ import Futhark.Util.Pretty import Language.Futhark hiding (Shape, matchDims) import Language.Futhark.Interpreter.AD qualified as AD+import Language.Futhark.Interpreter.FFI.ServerM (ValueRef) import Language.Futhark.Primitive qualified as P import Prelude hiding (break, mod) @@ -80,7 +83,7 @@ emptyShape (ShapeDim d s) = d == 0 || emptyShape s emptyShape _ = False -typeShape :: TypeBase d u -> Shape d+typeShape :: TypeBase d o -> Shape d typeShape (Array _ shape et) =   foldr ShapeDim (typeShape (Scalar et)) $ shapeDims shape typeShape (Scalar (Record fs)) =@@ -93,19 +96,35 @@   | otherwise =       ShapeLeaf --- | A fully evaluated Futhark value.+-- | A Futhark value as produced and used by the interpreter. Some of these+-- represent semantically meaningful Futhark values, while others represent+-- internal operational things that should never be returned by an interpreter+-- entry point, but can be observed in its intermediate stage (e.g. when using+-- breakpoints to access the environment). data Value m-  = ValuePrim !PrimValue-  | ValueArray ValueShape !(Array Int (Value m))-  | -- Stores the full shape.+  = -- | A primitive value.+    ValuePrim !PrimValue+  | -- | An array, with explicit shape. The shape is the full shape of the+    -- value, including element shape.+    ValueArray ValueShape !(Array Int (Value m))+  | -- | A record, which also subsumes tuples.     ValueRecord (M.Map Name (Value m))-  | ValueFun (Value m -> m (Value m))-  | -- Stores the full shape.+  | -- | A function value.+    ValueFun (Value m -> m (Value m))+  | -- | A sum value.     ValueSum ValueShape Name [Value m]-  | -- The shape, the update function, and the array.+  | -- | Internal value: an accumulator. Represented by the shape, the update+    -- function, and the array.     ValueAcc ValueShape (Value m -> Value m -> m (Value m)) !(Array Int (Value m))-  | -- A primitive value with added information used in automatic differentiation+  | -- | Internal value: A primitive value with added information used in+    -- automatic differentiation     ValueAD AD.Depth AD.ADVariable+  | -- | A lazy reference to a value on a Futhark Server. These can be returned+    -- by the interpreter, although the only sane way to use them for anything+    -- is to retrieve them.+    --+    -- We store the full shape locally, along with the indexes applied so far.+    ValueLazyFFI ValueShape ValueRef [Int64]  instance Show (Value m) where   show (ValuePrim v) = "ValuePrim " <> show v <> ""@@ -115,6 +134,7 @@   show ValueFun {} = "ValueFun _"   show ValueAcc {} = "ValueAcc _"   show (ValueAD d v) = unwords ["ValueAD", show d, show v]+  show (ValueLazyFFI shape _ os) = unwords ["ValueLazyFFI", show shape, "_", show os]  instance Eq (Value m) where   ValuePrim (SignedValue x) == ValuePrim (SignedValue y) =@@ -147,6 +167,7 @@     pprPrec p (ValueSum _ n vs) =       parensIf (p > (0 :: Int)) $ "#" <> sep (pretty n : map (pprPrec 1) vs)     pprPrec _ (ValueAD _ v) = pprPrim $ putV $ AD.varPrimal v+    pprPrec _ (ValueLazyFFI {}) = "#<ffi_ref>"     pprElem v@ValueArray {} = pprPrec 0 v     pprElem v = group $ pprPrec 0 v @@ -182,11 +203,17 @@ valueText :: Value m -> T.Text valueText = docText . prettyValueWith pretty +-- | The shape of a value. valueShape :: Value m -> ValueShape valueShape (ValueArray shape _) = shape valueShape (ValueAcc shape _ _) = shape valueShape (ValueRecord fs) = ShapeRecord $ M.map valueShape fs valueShape (ValueSum shape _ _) = shape+valueShape (ValueLazyFFI shape _ os) = unDim shape $ length os+  where+    unDim s 0 = s+    unDim (ShapeDim _ cshp) n | n > 0 = unDim cshp $ n - 1+    unDim _ _ = error $ "Invalid offsets " ++ show os ++ " of shape " ++ show shape valueShape _ = ShapeLeaf  -- | Retrieve the part of the value shape that corresponds to outer array@@ -232,7 +259,7 @@ -- | String representation of an empty array with the provided element -- type.  This is pretty ad-hoc - don't expect good results unless the -- element type is a primitive.-prettyEmptyArray :: TypeBase () () -> Value m -> T.Text+prettyEmptyArray :: TypeBase () NoMode -> Value m -> T.Text prettyEmptyArray t v =   "empty(" <> dims (valueShape v) <> prettyText t' <> ")"   where@@ -307,3 +334,11 @@   fromDataValueWith (FloatValue . Float64Value) shape vector fromDataValue (V.BoolValue shape vector) =   fromDataValueWith BoolValue shape vector++-- | If the value represents an array of type @[]u8@, then return those bytes.+asByteString :: Value m -> Maybe BS.ByteString+asByteString (ValueArray _ vals) = BS.pack <$> mapM asU8 (elems vals)+  where+    asU8 (ValuePrim (UnsignedValue (Int8Value x))) = Just $ fromIntegral x+    asU8 _ = Nothing+asByteString _ = Nothing
src/Language/Futhark/Parser.hs view
@@ -3,6 +3,7 @@   ( parseFuthark,     parseFutharkWithComments,     parseExp,+    parseExpAt,     parseModExp,     parseType,     parseDecOrExp,@@ -12,17 +13,21 @@ where  import Data.Text qualified as T+import Futhark.Util.Loc (Pos (..)) import Language.Futhark.Parser.Parser import Language.Futhark.Prop import Language.Futhark.Syntax +initialPos :: FilePath -> Pos+initialPos fname = Pos fname 1 1 0+ -- | Parse an entire Futhark program from the given 'T.Text', using -- the 'FilePath' as the source name for error messages. parseFuthark ::   FilePath ->   T.Text ->   Either SyntaxError UncheckedProg-parseFuthark = parse prog+parseFuthark fname = parse prog (initialPos fname)  -- | Parse an entire Futhark program from the given 'T.Text', using -- the 'FilePath' as the source name for error messages.  Also returns@@ -31,7 +36,7 @@   FilePath ->   T.Text ->   Either SyntaxError (UncheckedProg, [Comment])-parseFutharkWithComments = parseWithComments prog+parseFutharkWithComments fname = parseWithComments prog (initialPos fname)  -- | Parse an Futhark expression from the given 'String', using the -- 'FilePath' as the source name for error messages.@@ -39,15 +44,26 @@   FilePath ->   T.Text ->   Either SyntaxError UncheckedExp-parseExp = parse expression+parseExp fname = parse expression (initialPos fname) +-- | As 'parseExp', but the expression is assumed to start at the+-- given position, rather than at the beginning of a file.  This is+-- useful when the expression is a fragment of a larger file, as the+-- source locations in the result will then refer to that file.  The+-- position also provides the source name for error messages.+parseExpAt ::+  Pos ->+  T.Text ->+  Either SyntaxError UncheckedExp+parseExpAt = parse expression+ -- | Parse a Futhark module expression from the given 'String', using the -- 'FilePath' as the source name for error messages. parseModExp ::   FilePath ->   T.Text ->   Either SyntaxError (ModExpBase NoInfo Name)-parseModExp = parse modExpression+parseModExp fname = parse modExpression (initialPos fname)  -- | Parse an Futhark type from the given 'String', using the -- 'FilePath' as the source name for error messages.@@ -55,15 +71,15 @@   FilePath ->   T.Text ->   Either SyntaxError UncheckedTypeExp-parseType = parse futharkType+parseType fname = parse futharkType (initialPos fname) --- | Parse either an expression or a declaration; favouring--- declarations in case of ambiguity.+-- | Parse either an expression or a declaration; favouring declarations in case+-- of ambiguity. parseDecOrExp ::   FilePath ->   T.Text ->   Either SyntaxError (Either UncheckedDec UncheckedExp)-parseDecOrExp file input =-  case parse declaration file input of-    Left {} -> Right <$> parseExp file input+parseDecOrExp fname input =+  case parse declaration (initialPos fname) input of+    Left {} -> Right <$> parseExp fname input     Right d -> Right $ Left d
src/Language/Futhark/Parser/Monad.hs view
@@ -102,6 +102,7 @@ data ParserState = ParserState   { _parserFile :: FilePath,     parserInput :: T.Text,+    parserOffset :: Int,     -- | Note: reverse order.     parserComments :: [Comment],     parserLexerState :: AlexInput@@ -198,8 +199,9 @@     Just "Unclosed string literal." parseError (L loc _, expected) = do   input <- lift $ gets parserInput+  offset <- lift $ gets parserOffset   let ~(Loc (Pos _ _ _ beg) (Pos _ _ _ end)) = locOf loc-      tok_src = T.take (end - beg) $ T.drop beg input+      tok_src = T.take (end - beg) $ T.drop (beg - offset) input   parseErrorAt loc . Just . T.unlines $     [ "Unexpected token: '" <> tok_src <> "'",       "Expected one of the following: " <> T.unwords (map T.pack expected)@@ -230,23 +232,26 @@ lexerErrToParseErr :: LexerError -> SyntaxError lexerErrToParseErr (LexerError loc msg) = SyntaxError loc msg +-- | Parse something starting at the given position. The position also contains+-- the input file name. parseWithComments ::   ParserMonad a ->-  FilePath ->+  Pos ->   T.Text ->   Either SyntaxError (a, [Comment])-parseWithComments p file program =+parseWithComments p start program =   onRes $ runState (runExceptT p) env   where     env =       ParserState-        file+        (posFile start)         program+        (posCoff start)         []         (initialLexerState start $ BS.fromStrict . T.encodeUtf8 $ program)-    start = Pos file 1 1 0     onRes (Left err, _) = Left err     onRes (Right x, s) = Right (x, reverse $ parserComments s) -parse :: ParserMonad a -> FilePath -> T.Text -> Either SyntaxError a-parse p file program = fst <$> parseWithComments p file program+-- | As 'parseWithComments, but throw away the comments.+parse :: ParserMonad a -> Pos -> T.Text -> Either SyntaxError a+parse p start program = fst <$> parseWithComments p start program
src/Language/Futhark/Parser/Parser.y view
@@ -101,6 +101,7 @@       '^'             { L $$ HAT }       '~'             { L $$ TILDE }       '|'             { L $$ PIPE  }+      '$'             { L $$ DOLLAR }        '+...'          { L _ (SYMBOL Plus _ _) }       '-...'          { L _ (SYMBOL Minus _ _) }@@ -469,7 +470,7 @@  TypeExpTerm :: { UncheckedTypeExp }          : '*' TypeExpTerm-           { TEUnique $2 (srcspan $1 $>) }+           { TEStar $2 (srcspan $1 $>) }          | TypeExpApply %prec typeprec { $1 }          | SumClauses %prec sumprec            { let (cs, loc) = $1 in TESum cs (srclocOf loc) }@@ -930,6 +931,7 @@           : id     { let L loc (ID s) =     $1 in (AtomName s, loc) }           | intlit { let L loc (INTLIT x) = $1 in (AtomInt x, loc) }           | natlit { let L loc (NATLIT _ x) = $1 in (AtomInt x, loc) }+          | '$' id { let L loc (ID s) = $2 in (AtomVar s, locOf (srcspan $1 loc)) }  AttrInfo :: { AttrInfo Name }          : AttrAtom         { let (x,y) = $1 in AttrAtom x (srclocOf y) }
src/Language/Futhark/Pretty.hs view
@@ -10,7 +10,7 @@     IsName (..),     prettyNameText,     prettyNameString,-    Annot (..),+    Annot,   ) where @@ -107,7 +107,15 @@ instance Pretty (Shape Bool) where   pretty (Shape ds) = mconcat (map (brackets . pretty) ds) -prettyRetType :: (Pretty (Shape dim), Pretty u) => Int -> RetTypeBase dim u -> Doc a+instance Pretty Diet where+  pretty Consume = "*"+  pretty Observe = ""++instance Pretty Freshness where+  pretty Fresh = "*"+  pretty Nonfresh = ""++prettyRetType :: (Pretty (Shape dim), Pretty o) => Int -> RetTypeBase dim o -> Doc a prettyRetType p (RetType [] t) =   prettyType p t prettyRetType _ (RetType dims t) =@@ -116,18 +124,14 @@     <> "."     <> pretty t -instance (Pretty (Shape dim), Pretty u) => Pretty (RetTypeBase dim u) where+instance (Pretty (Shape dim), Pretty o) => Pretty (RetTypeBase dim o) where   pretty = prettyRetType 0 -instance Pretty Diet where-  pretty Consume = "*"-  pretty Observe = ""--prettyScalarType :: (Pretty (Shape dim), Pretty u) => Int -> ScalarTypeBase dim u -> Doc a+prettyScalarType :: (Pretty (Shape dim), Pretty o) => Int -> ScalarTypeBase dim o -> Doc a prettyScalarType _ (Prim et) = pretty et-prettyScalarType p (TypeVar u v targs) =+prettyScalarType p (TypeVar o v targs) =   parensIf (not (null targs) && p > 3) $-    pretty u <> hsep (pretty v : map (prettyTypeArg 3) targs)+    pretty o <> hsep (pretty v : map (prettyTypeArg 3) targs) prettyScalarType _ (Record fs)   | Just ts <- areTupleFields fs =       group $ parens $ align $ mconcat $ punctuate ("," <> line) $ map pretty ts@@ -153,16 +157,16 @@     ppConstr (name, fs) = sep $ ("#" <> pretty name) : map (prettyType 2) fs     cs' = map ppConstr $ M.toList cs -instance (Pretty (Shape dim), Pretty u) => Pretty (ScalarTypeBase dim u) where+instance (Pretty (Shape dim), Pretty o) => Pretty (ScalarTypeBase dim o) where   pretty = prettyScalarType 0 -prettyType :: (Pretty (Shape dim), Pretty u) => Int -> TypeBase dim u -> Doc a-prettyType _ (Array u shape at) =-  pretty u <> pretty shape <> align (prettyScalarType 2 at)+prettyType :: (Pretty (Shape dim), Pretty o) => Int -> TypeBase dim o -> Doc a+prettyType _ (Array o shape at) =+  pretty o <> pretty shape <> align (prettyScalarType 2 at) prettyType p (Scalar t) =   prettyScalarType p t -instance (Pretty (Shape dim), Pretty u) => Pretty (TypeBase dim u) where+instance (Pretty (Shape dim), Pretty o) => Pretty (TypeBase dim o) where   pretty = prettyType 0  prettyTypeArg :: (Pretty (Shape dim)) => Int -> TypeArg dim -> Doc a@@ -173,7 +177,7 @@   pretty = prettyTypeArg 0  instance (IsName vn, Pretty d) => Pretty (TypeExp d vn) where-  pretty (TEUnique t _) = "*" <> pretty t+  pretty (TEStar t _) = "*" <> pretty t   pretty (TEArray d at _) = pretty d <> pretty at   pretty (TETuple ts _) = parens $ commasep $ map pretty ts   pretty (TERecord fs _) = braces $ commasep $ map ppField fs@@ -234,8 +238,8 @@ letBody body = "in" <+> align (pretty body)  prettyAppExp :: (IsName vn, Annot f) => Int -> AppExpBase f vn -> Doc a-prettyAppExp p (BinOp (bop, _) _ (x, _) (y, _) _) =-  prettyBinOp p bop x y+prettyAppExp p (BinOp (bop, _) bop_t (x, _) (y, _) _) =+  prettyBinOp p bop bop_t x y prettyAppExp _ (Match e cs _) = "match" <+> pretty e </> (stack . map pretty) (NE.toList cs) prettyAppExp _ (Loop sizeparams pat initexp form loopbody _) =   "loop"@@ -434,6 +438,7 @@  instance (IsName vn) => Pretty (AttrAtom vn) where   pretty (AtomName v) = pretty v+  pretty (AtomVar v) = prettyName v   pretty (AtomInt x) = pretty x  instance (IsName vn) => Pretty (AttrInfo vn) where@@ -619,13 +624,14 @@   (IsName vn, Annot f) =>   Int ->   QualName vn ->+  f StructType ->   ExpBase f vn ->   ExpBase f vn ->   Doc a-prettyBinOp p bop x y =+prettyBinOp p bop bop_t x y =   parensIf (p > symPrecedence) $     prettyExp symPrecedence x-      <+> bop'+      <+> (bop' <> prettyInst bop_t)       <+> prettyExp symRPrecedence y   where     bop' = case leading of
src/Language/Futhark/Primitive.hs view
@@ -456,14 +456,14 @@     UDiv IntType Safety   | -- | Unsigned integer division.  Rounds towards positive     -- infinity.-    UDivUp IntType Safety+    UCeilDiv IntType Safety   | -- | Signed integer division.  Rounds towards     -- negativity infinity.  Note: this is different     -- from LLVM.     SDiv IntType Safety   | -- | Signed integer division.  Rounds towards positive     -- infinity.-    SDivUp IntType Safety+    SCeilDiv IntType Safety   | -- | Floating-point division.     FDiv FloatType   | -- | Floating-point modulus.@@ -608,9 +608,9 @@       Mul <$> allIntTypes <*> [OverflowWrap, OverflowUndef],       map FMul allFloatTypes,       UDiv <$> allIntTypes <*> [Unsafe, Safe],-      UDivUp <$> allIntTypes <*> [Unsafe, Safe],+      UCeilDiv <$> allIntTypes <*> [Unsafe, Safe],       SDiv <$> allIntTypes <*> [Unsafe, Safe],-      SDivUp <$> allIntTypes <*> [Unsafe, Safe],+      SCeilDiv <$> allIntTypes <*> [Unsafe, Safe],       map FDiv allFloatTypes,       map FMod allFloatTypes,       UMod <$> allIntTypes <*> [Unsafe, Safe],@@ -731,9 +731,9 @@ doBinOp Mul {} = doIntBinOp doMul doBinOp FMul {} = doFloatBinOp (*) (*) (*) doBinOp UDiv {} = doRiskyIntBinOp doUDiv-doBinOp UDivUp {} = doRiskyIntBinOp doUDivUp+doBinOp UCeilDiv {} = doRiskyIntBinOp doUCeilDiv doBinOp SDiv {} = doRiskyIntBinOp doSDiv-doBinOp SDivUp {} = doRiskyIntBinOp doSDivUp+doBinOp SCeilDiv {} = doRiskyIntBinOp doSCeilDiv doBinOp FDiv {} = doFloatBinOp (/) (/) (/) doBinOp FMod {} = doFloatBinOp mod' mod' mod' doBinOp UMod {} = doRiskyIntBinOp doUMod@@ -831,8 +831,8 @@         intToWord64 v1 `div` intToWord64 v2  -- | Unsigned integer division.  Rounds towards positive infinity.-doUDivUp :: IntValue -> IntValue -> Maybe IntValue-doUDivUp v1 v2+doUCeilDiv :: IntValue -> IntValue -> Maybe IntValue+doUCeilDiv v1 v2   | zeroIshInt v2 = Nothing   | otherwise =       Just . intValue (intValueType v1) $@@ -849,8 +849,8 @@           intToInt64 v1 `div` intToInt64 v2  -- | Signed integer division.  Rounds towards positive infinity.-doSDivUp :: IntValue -> IntValue -> Maybe IntValue-doSDivUp v1 v2+doSCeilDiv :: IntValue -> IntValue -> Maybe IntValue+doSCeilDiv v1 v2   | zeroIshInt v2 = Nothing   | otherwise =       Just . intValue (intValueType v1) $@@ -1004,15 +1004,59 @@ doFPConv v Float32 = Float32Value $ floatToFloat v doFPConv v Float64 = Float64Value $ floatToDouble v +-- | Minimum and maximum value of this signed integer type.+signedMinMax :: (Num a) => IntType -> (a, a)+signedMinMax Int8 =+  ( fromIntegral (minBound :: Int8),+    fromIntegral (maxBound :: Int8)+  )+signedMinMax Int16 =+  ( fromIntegral (minBound :: Int16),+    fromIntegral (maxBound :: Int16)+  )+signedMinMax Int32 =+  ( fromIntegral (minBound :: Int32),+    fromIntegral (maxBound :: Int32)+  )+signedMinMax Int64 =+  ( fromIntegral (minBound :: Int64),+    fromIntegral (maxBound :: Int64)+  )++-- | Maximum value of this unsigned integer type.+unsignedMax :: (Num a) => IntType -> a+unsignedMax Int8 =+  fromIntegral (maxBound :: Word8)+unsignedMax Int16 =+  fromIntegral (minBound :: Word16)+unsignedMax Int32 =+  fromIntegral (maxBound :: Word32)+unsignedMax Int64 =+  fromIntegral (maxBound :: Word64)+ -- | Convert a floating-point value to the nearest -- unsigned integer (rounding towards zero). doFPToUI :: FloatValue -> IntType -> IntValue-doFPToUI v t = intValue t (truncate $ floatToDouble v :: Word64)+doFPToUI v t =+  intValue t $+    if v' < 0 || v' > high || isNaN v'+      then 0+      else truncate v' :: Word64+  where+    v' = floatToDouble v+    high = unsignedMax t  -- | Convert a floating-point value to the nearest -- signed integer (rounding towards zero). doFPToSI :: FloatValue -> IntType -> IntValue-doFPToSI v t = intValue t (truncate $ floatToDouble v :: Word64)+doFPToSI v t =+  intValue t $+    if v' < low || v' > high || isNaN v'+      then 0+      else truncate v' :: Word64+  where+    v' = floatToDouble v+    (low, high) = signedMinMax t  -- | Convert an unsigned integer to a floating-point value. doUIToFP :: IntValue -> FloatType -> FloatValue@@ -1130,12 +1174,12 @@ binOpType (Sub t _) = IntType t binOpType (Mul t _) = IntType t binOpType (SDiv t _) = IntType t-binOpType (SDivUp t _) = IntType t+binOpType (SCeilDiv t _) = IntType t binOpType (SMod t _) = IntType t binOpType (SQuot t _) = IntType t binOpType (SRem t _) = IntType t binOpType (UDiv t _) = IntType t-binOpType (UDivUp t _) = IntType t+binOpType (UCeilDiv t _) = IntType t binOpType (UMod t _) = IntType t binOpType (SMin t) = IntType t binOpType (UMin t) = IntType t@@ -1863,14 +1907,14 @@   pretty (FMul t) = taggedF "fmul" t   pretty (UDiv t Safe) = taggedI "udiv_safe" t   pretty (UDiv t Unsafe) = taggedI "udiv" t-  pretty (UDivUp t Safe) = taggedI "udiv_up_safe" t-  pretty (UDivUp t Unsafe) = taggedI "udiv_up" t+  pretty (UCeilDiv t Safe) = taggedI "uceil_div_safe" t+  pretty (UCeilDiv t Unsafe) = taggedI "uceil_div" t   pretty (UMod t Safe) = taggedI "umod_safe" t   pretty (UMod t Unsafe) = taggedI "umod" t   pretty (SDiv t Safe) = taggedI "sdiv_safe" t   pretty (SDiv t Unsafe) = taggedI "sdiv" t-  pretty (SDivUp t Safe) = taggedI "sdiv_up_safe" t-  pretty (SDivUp t Unsafe) = taggedI "sdiv_up" t+  pretty (SCeilDiv t Safe) = taggedI "sceil_div_safe" t+  pretty (SCeilDiv t Unsafe) = taggedI "sceil_div" t   pretty (SMod t Safe) = taggedI "smod_safe" t   pretty (SMod t Unsafe) = taggedI "smod" t   pretty (SQuot t Safe) = taggedI "squot_safe" t
src/Language/Futhark/Prop.hs view
@@ -46,8 +46,8 @@     patternOrderZero,      -- * Queries on types-    uniqueness,-    unique,+    freshness,+    fresh,     diet,     arrayRank,     arrayShape,@@ -70,7 +70,7 @@     resToParam,     paramToRes,     toResRet,-    setUniqueness,+    setMode,     noSizes,     traverseDims,     DimPos (..),@@ -156,16 +156,16 @@ -- | Return the dimensionality of a type.  For non-arrays, this is -- zero.  For a one-dimensional array it is one, for a two-dimensional -- it is two, and so forth.-arrayRank :: TypeBase d u -> Int+arrayRank :: TypeBase d o -> Int arrayRank = shapeRank . arrayShape  -- | Return the shape of a type - for non-arrays, this is 'mempty'.-arrayShape :: TypeBase dim as -> Shape dim+arrayShape :: TypeBase dim o -> Shape dim arrayShape (Array _ ds _) = ds arrayShape _ = mempty  -- | Change the shape of a type to be just the rank.-noSizes :: TypeBase Size as -> TypeBase () as+noSizes :: TypeBase Size o -> TypeBase () o noSizes = first $ const ()  -- | Where does this dimension occur?@@ -184,19 +184,19 @@ -- parameter names inside the type that have come in scope at the -- occurrence of the dimension. traverseDims ::-  forall f fdim tdim als.+  forall f fdim tdim o.   (Applicative f) =>   (S.Set VName -> DimPos -> fdim -> f tdim) ->-  TypeBase fdim als ->-  f (TypeBase tdim als)+  TypeBase fdim o ->+  f (TypeBase tdim o) traverseDims f = go mempty PosImmediate   where     go ::-      forall als'.+      forall o'.       S.Set VName ->       DimPos ->-      TypeBase fdim als' ->-      f (TypeBase tdim als')+      TypeBase fdim o' ->+      f (TypeBase tdim o')     go bound b t@Array {} =       bitraverse (f bound b) pure t     go bound b (Scalar (Record fields)) =@@ -207,8 +207,8 @@       Scalar . Sum <$> traverse (traverse (go bound b)) cs     go _ _ (Scalar (Prim t)) =       pure $ Scalar $ Prim t-    go bound _ (Scalar (Arrow als p u t1 (RetType dims t2))) =-      Scalar <$> (Arrow als p u <$> go bound' PosParam t1 <*> (RetType dims <$> go bound' PosReturn t2))+    go bound _ (Scalar (Arrow als p o t1 (RetType dims t2))) =+      Scalar <$> (Arrow als p o <$> go bound' PosParam t1 <*> (RetType dims <$> go bound' PosReturn t2))       where         bound' =           S.fromList dims@@ -226,19 +226,20 @@             then b             else PosParam --- | Return the uniqueness of a type.-uniqueness :: TypeBase shape Uniqueness -> Uniqueness-uniqueness (Array u _ _) = u-uniqueness (Scalar (TypeVar u _ _)) = u-uniqueness (Scalar (Sum ts))-  | any (any unique) ts = Unique-uniqueness (Scalar (Record fs))-  | any unique fs = Unique-uniqueness _ = Nonunique+-- | Return the freshness of a type.  A composite type is fresh if any+-- of its components are.+freshness :: TypeBase shape Freshness -> Freshness+freshness (Array o _ _) = o+freshness (Scalar (TypeVar o _ _)) = o+freshness (Scalar (Sum ts))+  | any (any fresh) ts = Fresh+freshness (Scalar (Record fs))+  | any fresh fs = Fresh+freshness _ = Nonfresh --- | @unique t@ is 'True' if the type of the argument is unique.-unique :: TypeBase shape Uniqueness -> Bool-unique = (== Unique) . uniqueness+-- | @fresh t@ is 'True' if the type of the argument is fresh.+fresh :: TypeBase shape Freshness -> Bool+fresh = (== Fresh) . freshness  -- | @diet t@ returns a description of how a function parameter of -- type @t@ consumes its argument.@@ -253,94 +254,94 @@ -- | Convert any type to one that has rank information, no alias -- information, and no embedded names. toStructural ::-  TypeBase dim as ->-  TypeBase () ()-toStructural = bimap (const ()) (const ())+  TypeBase dim o ->+  TypeBase () NoMode+toStructural = bimap (const ()) (const NoMode) --- | Remove uniquenss information from a type.-toStruct :: TypeBase dim u -> TypeBase dim NoUniqueness-toStruct = second (const NoUniqueness)+-- | Remove the annotation from a type.+toStruct :: TypeBase dim o -> TypeBase dim NoMode+toStruct = second (const NoMode)  -- | Uses 'Observe'.-toParam :: Diet -> TypeBase Size u -> ParamType+toParam :: Diet -> TypeBase Size o -> ParamType toParam d = fmap (const d)  -- | Convert to 'ResType'-toRes :: Uniqueness -> TypeBase Size u -> ResType-toRes u = fmap (const u)+toRes :: Freshness -> TypeBase Size o -> ResType+toRes o = fmap (const o)  -- | Convert to 'ResRetType'-toResRet :: Uniqueness -> RetTypeBase Size u -> ResRetType-toResRet u = second (const u)+toResRet :: Freshness -> RetTypeBase Size o -> ResRetType+toResRet o = second (const o) --- | Preserves relation between 'Diet' and 'Uniqueness'.+-- | Preserves relation between 'Diet' and 'Freshness'. resToParam :: ResType -> ParamType resToParam = second f   where-    f Unique = Consume-    f Nonunique = Observe+    f Fresh = Consume+    f Nonfresh = Observe --- | Preserves relation between 'Diet' and 'Uniqueness'.+-- | Preserves relation between 'Diet' and 'Freshness'. paramToRes :: ParamType -> ResType paramToRes = second f   where-    f Consume = Unique-    f Observe = Nonunique+    f Consume = Fresh+    f Observe = Nonfresh  -- | @peelArray n t@ returns the type resulting from peeling the first -- @n@ array dimensions from @t@.  Returns @Nothing@ if @t@ has less -- than @n@ dimensions.-peelArray :: Int -> TypeBase dim u -> Maybe (TypeBase dim u)-peelArray n (Array u shape t)+peelArray :: Int -> TypeBase dim o -> Maybe (TypeBase dim o)+peelArray n (Array o shape t)   | shapeRank shape == n =-      Just $ second (const u) (Scalar t)+      Just $ second (const o) (Scalar t)   | otherwise =-      Array u <$> stripDims n shape <*> pure t+      Array o <$> stripDims n shape <*> pure t peelArray _ _ = Nothing --- | @arrayOf u s t@ constructs an array type.  The convenience+-- | @arrayOf o s t@ constructs an array type.  The convenience -- compared to using the 'Array' constructor directly is that @t@ can -- itself be an array.  If @t@ is an @n@-dimensional array, and @s@ is -- a list of length @n@, the resulting type is of an @n+m@ dimensions. arrayOf ::   Shape dim ->-  TypeBase dim NoUniqueness ->-  TypeBase dim NoUniqueness+  TypeBase dim NoMode ->+  TypeBase dim NoMode arrayOf = arrayOfWithAliases mempty --- | Like 'arrayOf', but you can pass in uniqueness info of the+-- | Like 'arrayOf', but you can pass in the annotation of the -- resulting array. arrayOfWithAliases ::-  u ->+  o ->   Shape dim ->-  TypeBase dim u' ->-  TypeBase dim u-arrayOfWithAliases u shape2 (Array _ shape1 et) =-  Array u (shape2 <> shape1) et-arrayOfWithAliases u shape (Scalar t) =+  TypeBase dim o' ->+  TypeBase dim o+arrayOfWithAliases o shape2 (Array _ shape1 et) =+  Array o (shape2 <> shape1) et+arrayOfWithAliases o shape (Scalar t) =   if shapeRank shape == 0-    then Scalar t `setUniqueness` u-    else Array u shape (second (const mempty) t)+    then Scalar t `setMode` o+    else Array o shape (second (const mempty) t)  -- | @stripArray n t@ removes the @n@ outermost layers of the array. -- Essentially, it is the type of indexing an array of type @t@ with -- @n@ indexes.-stripArray :: Int -> TypeBase dim as -> TypeBase dim as-stripArray n (Array u shape et)+stripArray :: Int -> TypeBase dim o -> TypeBase dim o+stripArray n (Array o shape et)   | Just shape' <- stripDims n shape =-      Array u shape' et+      Array o shape' et   | otherwise =-      second (const u) (Scalar et)+      second (const o) (Scalar et) stripArray _ t = t  -- | Create a record type corresponding to a tuple with the given -- element types.-tupleRecord :: [TypeBase dim as] -> ScalarTypeBase dim as+tupleRecord :: [TypeBase dim o] -> ScalarTypeBase dim o tupleRecord = Record . M.fromList . zip tupleFieldNames  -- | Does this type corespond to a tuple?  If so, return the elements -- of that tuple.-isTupleRecord :: TypeBase dim as -> Maybe [TypeBase dim as]+isTupleRecord :: TypeBase dim o -> Maybe [TypeBase dim o] isTupleRecord (Scalar (Record fs)) = areTupleFields fs isTupleRecord _ = Nothing @@ -397,16 +398,16 @@ -- combining function is also passed the names bound within the type -- (from named parameters or return types). matchDims ::-  forall as m d1 d2.-  (Monoid as, Monad m) =>+  forall o m d1 d2.+  (Monoid o, Monad m) =>   ([VName] -> d1 -> d2 -> m d1) ->-  TypeBase d1 as ->-  TypeBase d2 as ->-  m (TypeBase d1 as)+  TypeBase d1 o ->+  TypeBase d2 o ->+  m (TypeBase d1 o) matchDims onDims = matchDims' mempty   where     matchDims' ::-      forall u'. (Monoid u') => [VName] -> TypeBase d1 u' -> TypeBase d2 u' -> m (TypeBase d1 u')+      forall o'. (Monoid o') => [VName] -> TypeBase d1 o' -> TypeBase d2 o' -> m (TypeBase d1 o')     matchDims' bound t1 t2 =       case (t1, t2) of         (Array u1 shape1 et1, Array u2 shape2 et2) ->@@ -446,10 +447,11 @@     onShapes bound shape1 shape2 =       Shape <$> zipWithM (onDims bound) (shapeDims shape1) (shapeDims shape2) --- | Set the uniqueness attribute of a type.  If the type is a record--- or sum type, the uniqueness of its components will be modified.-setUniqueness :: TypeBase dim u1 -> u2 -> TypeBase dim u2-setUniqueness t u = second (const u) t+-- | Set the annotation of a type - that is, its 'Diet' or 'Freshness',+-- or nothing at all.  If the type is a record or sum type, the+-- annotation of its components will be modified.+setMode :: TypeBase dim o1 -> o2 -> TypeBase dim o2+setMode t o = second (const o) t  intValueType :: IntValue -> IntType intValueType Int8Value {} = Int8@@ -512,27 +514,27 @@ typeOf (AppExp _ (Info res)) = appResType res  -- | The type of a function with the given parameters and return type.-funType :: [Pat (TypeBase d Diet)] -> RetTypeBase d Uniqueness -> TypeBase d NoUniqueness+funType :: [Pat (TypeBase d Diet)] -> RetTypeBase d Freshness -> TypeBase d NoMode funType params ret =   let RetType _ t = foldr (arrow . patternParam) ret params    in toStruct t   where     arrow (xp, d, xt) yt =-      RetType [] $ Scalar $ Arrow Nonunique xp d xt yt+      RetType [] $ Scalar $ Arrow Nonfresh xp d xt yt  -- | @foldFunType ts ret@ creates a function type ('Arrow') that takes -- @ts@ as parameters and returns @ret@.-foldFunType :: [TypeBase d Diet] -> RetTypeBase d Uniqueness -> TypeBase d NoUniqueness+foldFunType :: [TypeBase d Diet] -> RetTypeBase d Freshness -> TypeBase d NoMode foldFunType ps ret =   let RetType _ t = foldr arrow ret ps    in toStruct t   where     arrow t1 t2 =-      RetType [] $ Scalar $ Arrow Nonunique Unnamed (diet t1) (toStruct t1) t2+      RetType [] $ Scalar $ Arrow Nonfresh Unnamed (diet t1) (toStruct t1) t2  -- | Extract the parameter types and return type from a type. -- If the type is not an arrow type, the list of parameter types is empty.-unfoldFunType :: TypeBase dim as -> ([(PName, TypeBase dim Diet)], TypeBase dim NoUniqueness)+unfoldFunType :: TypeBase dim o -> ([(PName, TypeBase dim Diet)], TypeBase dim NoMode) unfoldFunType (Scalar (Arrow _ p d t1 (RetType _ t2))) =   let (ps, r) = unfoldFunType t2    in ((p, second (const d) t1) : ps, r)@@ -557,7 +559,7 @@       _ -> []  -- | The qualified type names mentioned in a type.-typeQualVars :: TypeBase dim as -> [QualName VName]+typeQualVars :: TypeBase dim o -> [QualName VName] typeQualVars t =   case t of     Scalar Prim {} -> mempty@@ -572,13 +574,13 @@     typeArgFree TypeArgDim {} = mempty  -- | The type names mentioned in a type.-typeVars :: TypeBase dim as -> S.Set VName+typeVars :: TypeBase dim o -> S.Set VName typeVars = S.fromList . map qualLeaf . typeQualVars  -- | @orderZero t@ is 'True' if the argument type has order 0, i.e., it is not -- a function type, does not contain a function type as a subcomponent, and may -- not be instantiated with a function type.-orderZero :: TypeBase dim as -> Bool+orderZero :: TypeBase dim o -> Bool orderZero Array {} = True orderZero (Scalar (Prim _)) = True orderZero (Scalar (Record fs)) = all orderZero $ M.elems fs@@ -588,7 +590,7 @@  -- | @patternOrderZero pat@ is 'True' if all of the types in the given pattern -- have order 0.-patternOrderZero :: Pat (TypeBase d u) -> Bool+patternOrderZero :: Pat (TypeBase d o) -> Bool patternOrderZero = orderZero . patternType  -- | The set of identifiers bound in a pattern.@@ -614,7 +616,7 @@     f (Ident v (Info t) _) = (v, t)  -- | The type of values bound by the pattern.-patternType :: Pat (TypeBase d u) -> TypeBase d u+patternType :: Pat (TypeBase d o) -> TypeBase d o patternType (Wildcard (Info t) _) = t patternType (PatParens p _) = patternType p patternType (Id _ (Info t) _) = t@@ -627,12 +629,12 @@ patternType (PatAttr _ p _) = patternType p  -- | The type matched by the pattern, including shape declarations if present.-patternStructType :: Pat (TypeBase Size u) -> StructType+patternStructType :: Pat (TypeBase Size o) -> StructType patternStructType = toStruct . patternType  -- | When viewed as a function parameter, does this pattern correspond -- to a named parameter of some type?-patternParam :: Pat (TypeBase d Diet) -> (PName, Diet, TypeBase d NoUniqueness)+patternParam :: Pat (TypeBase d Diet) -> (PName, Diet, TypeBase d NoMode) patternParam (PatParens p _) =   patternParam p patternParam (PatAttr _ p _) =@@ -667,7 +669,7 @@ data Intrinsic   = IntrinsicMonoFun [PrimType] PrimType   | IntrinsicOverloadedFun [PrimType] [Maybe PrimType] (Maybe PrimType)-  | IntrinsicPolyFun [TypeParamBase VName] [ParamType] (RetTypeBase Size Uniqueness)+  | IntrinsicPolyFun [TypeParamBase VName] [ParamType] (RetTypeBase Size Freshness)   | IntrinsicType Liftedness [TypeParamBase VName] StructType   | IntrinsicEquality -- Special cased. @@ -685,7 +687,7 @@  -- | If this type corresponds to the builtin "acc" type, return the -- type of the underlying array.-isAccType :: TypeBase d u -> Maybe (TypeBase d NoUniqueness)+isAccType :: TypeBase d o -> Maybe (TypeBase d NoMode) isAccType (Scalar (TypeVar _ (QualName [] v) [TypeArgType t]))   | v == fst intrinsicAcc =       Just t@@ -730,7 +732,7 @@                   [Scalar $ t_a mempty]                   $ RetType []                   $ Scalar-                  $ t_a Unique+                  $ t_a Fresh               ),               ( "flatten",                 IntrinsicPolyFun@@ -738,7 +740,7 @@                   [Array Observe (shape [n, m]) $ t_a mempty]                   $ RetType []                   $ Array-                    Nonunique+                    Nonfresh                     (Shape [size n `mkMul` size m])                     (t_a mempty)               ),@@ -750,7 +752,7 @@                     Array Observe (Shape [size n `mkMul` size m]) $ t_a mempty                   ]                   $ RetType []-                  $ Array Nonunique (shape [n, m]) (t_a mempty)+                  $ Array Nonfresh (shape [n, m]) (t_a mempty)               ),               ( "concat",                 IntrinsicPolyFun@@ -759,7 +761,7 @@                     array_a Observe $ shape [m]                   ]                   $ RetType []-                  $ array_a Unique+                  $ array_a Fresh                   $ Shape [size n `mkAdd` size m]               ),               ( "transpose",@@ -767,7 +769,7 @@                   [tp_a, sp_n, sp_m]                   [array_a Observe $ shape [n, m]]                   $ RetType []-                  $ array_a Nonunique+                  $ array_a Nonfresh                   $ shape [m, n]               ),               ( "scatter",@@ -778,7 +780,7 @@                     Array Observe (shape [l]) $ t_a mempty                   ]                   $ RetType []-                  $ Array Unique (shape [n]) (t_a mempty)+                  $ Array Fresh (shape [n]) (t_a mempty)               ),               ( "scatter_2d",                 IntrinsicPolyFun@@ -788,7 +790,7 @@                     Array Observe (shape [l]) $ t_a mempty                   ]                   $ RetType []-                  $ array_a Unique+                  $ array_a Fresh                   $ shape [n, m]               ),               ( "scatter_3d",@@ -799,7 +801,7 @@                     Array Observe (shape [l]) $ t_a mempty                   ]                   $ RetType []-                  $ array_a Unique+                  $ array_a Fresh                   $ shape [n, m, k]               ),               ( "zip",@@ -809,7 +811,7 @@                     array_b Observe (shape [n])                   ]                   $ RetType []-                  $ tuple_array Unique (Scalar $ t_a mempty) (Scalar $ t_b mempty)+                  $ tuple_array Fresh (Scalar $ t_a mempty) (Scalar $ t_b mempty)                   $ shape [n]               ),               ( "unzip",@@ -817,20 +819,20 @@                   [tp_a, tp_b, sp_n]                   [tuple_array Observe (Scalar $ t_a mempty) (Scalar $ t_b mempty) $ shape [n]]                   $ RetType [] . Scalar . Record . M.fromList-                  $ zip tupleFieldNames [array_a Unique $ shape [n], array_b Unique $ shape [n]]+                  $ zip tupleFieldNames [array_a Fresh $ shape [n], array_b Fresh $ shape [n]]               ),               ( "hist_1d",                 IntrinsicPolyFun                   [tp_a, sp_n, sp_m]                   [ Scalar $ Prim $ Signed Int64,                     array_a Consume $ shape [m],-                    Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonunique)),+                    Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonfresh)),                     Scalar $ t_a Observe,                     Array Observe (shape [n]) (tupInt64 1),                     array_a Observe (shape [n])                   ]                   $ RetType []-                  $ array_a Unique+                  $ array_a Fresh                   $ shape [m]               ),               ( "hist_2d",@@ -838,13 +840,13 @@                   [tp_a, sp_n, sp_m, sp_k]                   [ Scalar $ Prim $ Signed Int64,                     array_a Consume $ shape [m, k],-                    Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonunique)),+                    Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonfresh)),                     Scalar $ t_a Observe,                     Array Observe (shape [n]) (tupInt64 2),                     array_a Observe (shape [n])                   ]                   $ RetType []-                  $ array_a Unique+                  $ array_a Fresh                   $ shape [m, k]               ),               ( "hist_3d",@@ -852,52 +854,52 @@                   [tp_a, sp_n, sp_m, sp_k, sp_l]                   [ Scalar $ Prim $ Signed Int64,                     array_a Consume $ shape [m, k, l],-                    Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonunique)),+                    Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonfresh)),                     Scalar $ t_a Observe,                     Array Observe (shape [n]) (tupInt64 3),                     array_a Observe (shape [n])                   ]                   $ RetType []-                  $ array_a Unique+                  $ array_a Fresh                   $ shape [m, k, l]               ),               ( "map",                 IntrinsicPolyFun                   [tp_a, tp_b, sp_n]-                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonunique),+                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonfresh),                     array_a Observe $ shape [n]                   ]                   $ RetType []-                  $ array_b Unique+                  $ array_b Fresh                   $ shape [n]               ),               ( "reduce",                 IntrinsicPolyFun                   [tp_a, sp_n]-                  [ Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonunique)),+                  [ Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonfresh)),                     Scalar $ t_a Observe,                     array_a Observe $ shape [n]                   ]                   $ RetType []-                  $ Scalar (t_a Unique)+                  $ Scalar (t_a Fresh)               ),               ( "reduce_comm",                 IntrinsicPolyFun                   [tp_a, sp_n]-                  [ Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonunique)),+                  [ Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonfresh)),                     Scalar $ t_a Observe,                     array_a Observe $ shape [n]                   ]-                  $ RetType [] (Scalar (t_a Unique))+                  $ RetType [] (Scalar (t_a Fresh))               ),               ( "scan",                 IntrinsicPolyFun                   [tp_a, sp_n]-                  [ Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonunique)),+                  [ Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonfresh)),                     Scalar $ t_a Observe,                     array_a Observe $ shape [n]                   ]-                  $ RetType [] (array_a Unique $ shape [n])+                  $ RetType [] (array_a Fresh $ shape [n])               ),               ( "partition",                 IntrinsicPolyFun@@ -908,8 +910,8 @@                   ]                   ( RetType [k] . Scalar $                       tupleRecord-                        [ array_a Unique $ shape [n],-                          Array Unique (shape [k]) (Prim $ Signed Int64)+                        [ array_a Fresh $ shape [n],+                          Array Fresh (shape [k]) (Prim $ Signed Int64)                         ]                   )               ),@@ -922,7 +924,7 @@                   ]                   $ RetType []                   $ Scalar-                  $ accType Unique (array_ka mempty)+                  $ accType Fresh (array_ka mempty)               ),               ( "scatter_stream",                 IntrinsicPolyFun@@ -930,113 +932,147 @@                   [ array_ka Consume,                     Scalar (accType mempty (array_ka mempty))                       `carr` ( Scalar (t_b mempty)-                                 `arr` Scalar (accType Nonunique $ array_a mempty $ shape [k])+                                 `arr` Scalar (accType Nonfresh $ array_a mempty $ shape [k])                              ),                     array_b Observe $ shape [n]                   ]                   $ RetType []-                  $ array_ka Unique+                  $ array_ka Fresh               ),               ( "hist_stream",                 IntrinsicPolyFun                   [tp_a, tp_b, sp_k, sp_n]                   [ array_a Consume $ shape [k],-                    Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonunique)),+                    Scalar (t_a mempty) `arr` (Scalar (t_a mempty) `arr` Scalar (t_a Nonfresh)),                     Scalar $ t_a Observe,                     Scalar (accType mempty $ array_ka mempty)                       `carr` ( Scalar (t_b mempty)-                                 `arr` Scalar (accType Nonunique $ array_a mempty $ shape [k])+                                 `arr` Scalar (accType Nonfresh $ array_a mempty $ shape [k])                              ),                     array_b Observe $ shape [n]                   ]                   $ RetType []-                  $ array_a Unique+                  $ array_a Fresh                   $ shape [k]               ),               ( "jvp2",                 IntrinsicPolyFun                   [tp_a, tp_b]-                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonunique),+                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonfresh),                     Scalar (t_a Observe),                     Scalar (t_a Observe)                   ]                   $ RetType []                   $ Scalar-                  $ tupleRecord [Scalar $ t_b Nonunique, Scalar $ t_b Nonunique]+                  $ tupleRecord [Scalar $ t_b Fresh, Scalar $ t_b Fresh]               ),               ( "vjp2",                 IntrinsicPolyFun                   [tp_a, tp_b]-                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonunique),+                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonfresh),                     Scalar (t_a Observe),                     Scalar (t_b Observe)                   ]                   $ RetType []                   $ Scalar-                  $ tupleRecord [Scalar $ t_b Nonunique, Scalar $ t_a Nonunique]+                  $ tupleRecord [Scalar $ t_b Fresh, Scalar $ t_a Fresh]               ),               ( "jmp2",                 IntrinsicPolyFun                   [tp_a, tp_b, sp_n]-                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonunique),+                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonfresh),                     Scalar (t_a Observe),                     array_a Observe $ shape [n]                   ]                   $ RetType []                   $ Scalar                   $ tupleRecord-                    [ Scalar $ t_b Nonunique,-                      array_b Unique $ shape [n]+                    [ Scalar $ t_b Fresh,+                      array_b Fresh $ shape [n]                     ]               ),               ( "mjp2",                 IntrinsicPolyFun                   [tp_a, tp_b, sp_n]-                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonunique),+                  [ Scalar (t_a mempty) `arr` Scalar (t_b Nonfresh),                     Scalar (t_a Observe),                     array_b Observe $ shape [n]                   ]                   $ RetType []                   $ Scalar                   $ tupleRecord-                    [ Scalar $ t_b Nonunique,-                      array_a Unique $ shape [n]+                    [ Scalar $ t_b Fresh,+                      array_a Fresh $ shape [n]                     ]               ),               ( "with_vjp",                 IntrinsicPolyFun                   [tp_a, tp_b]-                  [ Scalar (t_a NoUniqueness) `arr` Scalar (t_b Nonunique),-                    Scalar (t_b NoUniqueness)-                      `arr` ( Scalar (t_b NoUniqueness)-                                `arr` Scalar (t_a Nonunique)+                  [ Scalar (t_a NoMode) `arr` Scalar (t_b Nonfresh),+                    Scalar (t_b NoMode)+                      `arr` ( Scalar (t_b NoMode)+                                `arr` Scalar (t_a Nonfresh)                             ),                     Scalar (t_a Observe)                   ]                   $ RetType []-                  $ Scalar (t_b Nonunique)+                  $ Scalar (t_b Nonfresh)               ),               ( "flatmap",                 IntrinsicPolyFun                   [tp_a, tp_b, tp_c, sp_n]                   [ Scalar $-                      Arrow mempty Unnamed Observe (Scalar (t_a NoUniqueness)) $+                      Arrow mempty Unnamed Observe (Scalar (t_a NoMode)) $                         RetType [k] . Scalar . tupleRecord $-                          [ array_b Nonunique (shape [k]),-                            Scalar $ t_c Nonunique+                          [ array_b Nonfresh (shape [k]),+                            Scalar $ t_c Nonfresh                           ],                     array_a Observe $ shape [n]                   ]                   $ RetType [m] . Scalar . tupleRecord-                  $ [ Array Unique (shape [n]) (Prim $ Signed Int64),-                      Array Unique (shape [m]) (Prim Bool),-                      Array Unique (shape [n]) (Prim $ Signed Int64),-                      array_b Unique $ shape [m],-                      array_c Unique $ shape [n]+                  $ [ Array Fresh (shape [n]) (Prim $ Signed Int64),+                      Array Fresh (shape [m]) (Prim Bool),+                      Array Fresh (shape [n]) (Prim $ Signed Int64),+                      array_b Fresh $ shape [m],+                      array_c Fresh $ shape [n]                     ]               )             ]               +++              -- Interpreter-only IO builtins. It is somewhat ugly (and+              -- non-extensible) that these have to baked-in here. The alternative+              -- is a general "intrinsic" language construct.+              [ ( "io_loadbytes",+                  IntrinsicPolyFun+                    [sp_k]+                    [Array Observe (shape [k]) (Prim $ Unsigned Int8)]+                    $ RetType [n]+                    $ Array Fresh (shape [n]) (Prim $ Unsigned Int8)+                ),+                ( "io_loadimg",+                  IntrinsicPolyFun+                    [sp_k]+                    [Array Observe (shape [k]) (Prim $ Unsigned Int8)]+                    $ RetType [n, m]+                    $ Array Fresh (shape [n, m]) (Prim $ Unsigned Int32)+                ),+                ( "io_loadaudio",+                  IntrinsicPolyFun+                    [sp_k]+                    [Array Observe (shape [k]) (Prim $ Unsigned Int8)]+                    $ RetType [n, m]+                    $ Array Fresh (shape [n, m]) (Prim $ FloatType Float64)+                ),+                ( "io_loadvalue",+                  IntrinsicPolyFun+                    [sp_k, tp_a]+                    [Array Observe (shape [k]) (Prim $ Unsigned Int8)]+                    $ RetType []+                    $ Scalar+                    $ t_a Fresh+                )+              ]+              ++               -- Experimental LMAD ones.               [ ( "flat_index_2d",                   IntrinsicPolyFun@@ -1049,7 +1085,7 @@                       Scalar (Prim $ Signed Int64)                     ]                     $ RetType [m, k]-                    $ array_a Nonunique+                    $ array_a Nonfresh                     $ shape [m, k]                 ),                 ( "flat_update_2d",@@ -1062,7 +1098,7 @@                       array_a Observe $ shape [k, l]                     ]                     $ RetType []-                    $ array_a Unique+                    $ array_a Fresh                     $ shape [n]                 ),                 ( "flat_index_3d",@@ -1078,7 +1114,7 @@                       Scalar (Prim $ Signed Int64)                     ]                     $ RetType [m, k, l]-                    $ array_a Nonunique+                    $ array_a Nonfresh                     $ shape [m, k, l]                 ),                 ( "flat_update_3d",@@ -1092,7 +1128,7 @@                       array_a Observe $ shape [k, l, p]                     ]                     $ RetType []-                    $ array_a Unique+                    $ array_a Fresh                     $ shape [n]                 ),                 ( "flat_index_4d",@@ -1110,7 +1146,7 @@                       Scalar (Prim $ Signed Int64)                     ]                     $ RetType [m, k, l, p]-                    $ array_a Nonunique+                    $ array_a Nonfresh                     $ shape [m, k, l, p]                 ),                 ( "flat_update_4d",@@ -1125,7 +1161,7 @@                       array_a Observe $ shape [k, l, p, q]                     ]                     $ RetType []-                    $ array_a Unique+                    $ array_a Fresh                     $ shape [n]                 )               ]@@ -1178,16 +1214,16 @@      [a, b, c, n, m, k, l, p, q] = zipWith VName (map nameFromText ["a", "b", "c", "n", "m", "k", "l", "p", "q"]) [0 ..] -    t_a u = TypeVar u (qualName a) []-    array_a u s = Array u s $ t_a mempty+    t_a o = TypeVar o (qualName a) []+    array_a o s = Array o s $ t_a mempty     tp_a = TypeParamType Unlifted a mempty -    t_b u = TypeVar u (qualName b) []-    array_b u s = Array u s $ t_b mempty+    t_b o = TypeVar o (qualName b) []+    array_b o s = Array o s $ t_b mempty     tp_b = TypeParamType Unlifted b mempty -    t_c u = TypeVar u (qualName c) []-    array_c u s = Array u s $ t_c mempty+    t_c o = TypeVar o (qualName c) []+    array_c o s = Array o s $ t_c mempty     tp_c = TypeParamType Unlifted c mempty      [sp_n, sp_m, sp_k, sp_l, sp_p, sp_q] = map (`TypeParamDim` mempty) [n, m, k, l, p, q]@@ -1195,16 +1231,16 @@     size = flip sizeFromName mempty . qualName     shape = Shape . map size -    tuple_array u x y s =-      Array u s (Record (M.fromList $ zip tupleFieldNames [x, y]))+    tuple_array o x y s =+      Array o s (Record (M.fromList $ zip tupleFieldNames [x, y]))      arr x y = Scalar $ Arrow mempty Unnamed Observe x (RetType [] y)     carr x y = Scalar $ Arrow mempty Unnamed Consume x (RetType [] y) -    array_ka u = Array u (Shape [sizeFromName (qualName k) mempty]) $ t_a mempty+    array_ka o = Array o (Shape [sizeFromName (qualName k) mempty]) $ t_a mempty -    accType u t =-      TypeVar u (qualName (fst intrinsicAcc)) [TypeArgType t]+    accType o t =+      TypeVar o (qualName (fst intrinsicAcc)) [TypeArgType t]      namify i (x, y) = (VName (nameFromText x) i, y)
src/Language/Futhark/Query.hs view
@@ -63,7 +63,7 @@     TermFun TermFunData   deriving (Eq, Show) -termBindingType :: TermBinding -> TypeBase Size NoUniqueness+termBindingType :: TermBinding -> TypeBase Size NoMode termBindingType = \case   TermSize -> Scalar (Prim (Signed Int64))   TermVar _ t _ -> t@@ -101,7 +101,7 @@  patternDefs ::   TermBindSrc ->-  Pat (TypeBase Size u) ->+  Pat (TypeBase Size o) ->   Defs patternDefs bindSrc (Id vn (Info t) loc) =   M.singleton vn $ DefBound $ BoundTerm tvar (locOf loc)@@ -317,7 +317,7 @@       msum $ map ((`atPosInTypeExp` pos) . snd) fields     TEArray dim te' _ ->       atPosInTypeExp te' pos `mplus` inDim dim-    TEUnique te' _ ->+    TEStar te' _ ->       atPosInTypeExp te' pos     TEApply e1 arg _ ->       atPosInTypeExp e1 pos `mplus` inArg arg@@ -333,7 +333,7 @@     inDim (SizeExp e _) = atPosInExp e pos     inDim SizeExpAny {} = Nothing -atPosInPat :: Pat (TypeBase Size u) -> Pos -> Maybe RawAtPos+atPosInPat :: Pat (TypeBase Size o) -> Pos -> Maybe RawAtPos atPosInPat (Id vn _ loc) pos = do   guard $ loc `contains` pos   Just $ RawAtName (qualName vn) $ locOf loc
src/Language/Futhark/Syntax.hs view
@@ -15,7 +15,6 @@     prettyText,      -- * Types-    Uniqueness (..),     IntType (..),     FloatType (..),     PrimType (..),@@ -38,6 +37,7 @@     ResRetType,     ValueType,     Diet (..),+    Freshness (..),      -- * Values     IntValue (..),@@ -111,6 +111,7 @@ import Data.Map.Strict qualified as M import Data.Monoid hiding (Sum) import Data.Ord+import Data.String (IsString (..)) import Data.Text qualified as T import Data.Traversable import Futhark.Util.Loc@@ -212,6 +213,7 @@ -- | The value of an v'AttrAtom'. data AttrAtom vn   = AtomName Name+  | AtomVar vn   | AtomInt Integer   deriving (Eq, Ord, Show) @@ -221,6 +223,12 @@   | AttrComp Name [AttrInfo vn] SrcLoc   deriving (Eq, Ord, Show) +instance IsString (AttrAtom vn) where+  fromString = AtomName . fromString++instance IsString (AttrInfo vn) where+  fromString s = AttrAtom (fromString s) mempty+ -- | The elaborated size of a dimension is just an expression. type Size = ExpBase Info VName @@ -277,9 +285,9 @@  -- | Types that can appear to the right of a function arrow.  This -- just means they can be existentially quantified.-data RetTypeBase dim as = RetType+data RetTypeBase dim o = RetType   { retDims :: [VName],-    retType :: TypeBase dim as+    retType :: TypeBase dim o   }   deriving (Eq, Ord, Show) @@ -304,14 +312,14 @@ -- | Types that can be elements of arrays.  This representation does -- allow arrays of records of functions, which is nonsensical, but it -- convolutes the code too much if we try to statically rule it out.-data ScalarTypeBase dim u+data ScalarTypeBase dim o   = Prim PrimType-  | TypeVar u (QualName VName) [TypeArg dim]-  | Record (M.Map Name (TypeBase dim u))-  | Sum (M.Map Name [TypeBase dim u])+  | TypeVar o (QualName VName) [TypeArg dim]+  | Record (M.Map Name (TypeBase dim o))+  | Sum (M.Map Name [TypeBase dim o])   | -- | The aliasing corresponds to the lexical     -- closure of the function.-    Arrow u PName Diet (TypeBase dim NoUniqueness) (RetTypeBase dim Uniqueness)+    Arrow o PName Diet (TypeBase dim NoMode) (RetTypeBase dim Freshness)   deriving (Eq, Ord, Show)  instance Bitraversable ScalarTypeBase where@@ -319,8 +327,8 @@   bitraverse f g (Record fs) = Record <$> traverse (bitraverse f g) fs   bitraverse f g (TypeVar als t args) =     TypeVar <$> g als <*> pure t <*> traverse (traverse f) args-  bitraverse f g (Arrow u v d t1 t2) =-    Arrow <$> g u <*> pure v <*> pure d <*> bitraverse f pure t1 <*> bitraverse f pure t2+  bitraverse f g (Arrow o v d t1 t2) =+    Arrow <$> g o <*> pure v <*> pure d <*> bitraverse f pure t1 <*> bitraverse f pure t2   bitraverse f g (Sum cs) = Sum <$> (traverse . traverse) (bitraverse f g) cs  instance Functor (ScalarTypeBase dim) where@@ -343,9 +351,14 @@ -- function parameter names are ignored.  This representation permits -- some malformed types (arrays of functions), but importantly rules -- out arrays-of-arrays.-data TypeBase dim u-  = Scalar (ScalarTypeBase dim u)-  | Array u (Shape dim) (ScalarTypeBase dim NoUniqueness)+-- The @o@ parameter is the /mode/: what the type says about how the+-- value may be used, beyond its structure.  It is 'Diet' for+-- parameters, 'Freshness' for return types, and 'NoMode' where nothing+-- is said.  Note that these are unrelated to each other - a mode is+-- whatever the position calls for, not a single property.+data TypeBase dim o+  = Scalar (ScalarTypeBase dim o)+  | Array o (Shape dim) (ScalarTypeBase dim NoMode)   deriving (Eq, Ord, Show)  instance Bitraversable TypeBase where@@ -371,7 +384,7 @@ -- | An argument passed to a type constructor. data TypeArg dim   = TypeArgDim dim-  | TypeArgType (TypeBase dim NoUniqueness)+  | TypeArgType (TypeBase dim NoMode)   deriving (Eq, Ord, Show)  instance Traversable TypeArg where@@ -386,23 +399,23 @@  -- | A "structural" type with shape annotations and no aliasing -- information, used for declarations.-type StructType = TypeBase Size NoUniqueness+type StructType = TypeBase Size NoMode  -- | A type with consumption information, used for function parameters -- (but not in function types). type ParamType = TypeBase Size Diet --- | A type with uniqueness information, used for function return types-type ResType = TypeBase Size Uniqueness+-- | A type with freshness information, used for function return types+type ResType = TypeBase Size Freshness  -- | A value type contains full, manifest size information.-type ValueType = TypeBase Int64 NoUniqueness+type ValueType = TypeBase Int64 NoMode  -- | The return type version of a 'ResType'.-type StructRetType = RetTypeBase Size NoUniqueness+type StructRetType = RetTypeBase Size NoMode  -- | The return type version of a 'StructType'.-type ResRetType = RetTypeBase Size Uniqueness+type ResRetType = RetTypeBase Size Freshness  -- | A dimension declaration expression for use in a 'TypeExp'. -- Syntactically includes the brackets.@@ -457,17 +470,18 @@   locOf (TypeArgExpSize e) = locOf e   locOf (TypeArgExpType t) = locOf t --- | An unstructured syntactic type with type variables and possibly--- shape declarations - this is what the user types in the source--- program.  These are used to construct 'TypeBase's in the type--- checker.+-- | An unstructured syntactic type with type variables and possibly shape+-- declarations - this is what the user types in the source program. These are+-- used to construct 'TypeBase's in the type checker. data TypeExp d vn   = TEVar (QualName vn) SrcLoc   | TEParens (TypeExp d vn) SrcLoc   | TETuple [TypeExp d vn] SrcLoc   | TERecord [(L Name, TypeExp d vn)] SrcLoc   | TEArray (SizeExp d) (TypeExp d vn) SrcLoc-  | TEUnique (TypeExp d vn) SrcLoc+  | -- | A @*@ prefix. The meaning depends on where the type expression occurs:+    -- consumption on a parameter, freshness on a return type.+    TEStar (TypeExp d vn) SrcLoc   | TEApply (TypeExp d vn) (TypeArgExp d vn) SrcLoc   | TEArrow (Maybe vn) (TypeExp d vn) (TypeExp d vn) SrcLoc   | TESum [(Name, [TypeExp d vn])] SrcLoc@@ -487,8 +501,8 @@     TESum <$> traverse (traverse (traverse (bitraverse f g))) cs <*> pure loc   bitraverse f g (TEArray d te loc) =     TEArray <$> traverse f d <*> bitraverse f g te <*> pure loc-  bitraverse f g (TEUnique te loc) =-    TEUnique <$> bitraverse f g te <*> pure loc+  bitraverse f g (TEStar te loc) =+    TEStar <$> bitraverse f g te <*> pure loc   bitraverse f g (TEApply te arg loc) =     TEApply <$> bitraverse f g te <*> bitraverse f g arg <*> pure loc   bitraverse f g (TEArrow pn te1 te2 loc) =@@ -517,14 +531,14 @@   locOf (TERecord _ loc) = locOf loc   locOf (TEVar _ loc) = locOf loc   locOf (TEParens _ loc) = locOf loc-  locOf (TEUnique _ loc) = locOf loc+  locOf (TEStar _ loc) = locOf loc   locOf (TEApply _ _ loc) = locOf loc   locOf (TEArrow _ _ _ loc) = locOf loc   locOf (TESum _ loc) = locOf loc   locOf (TEDim _ _ loc) = locOf loc --- | Information about which parts of a parameter are consumed.  This--- can be considered kind of an effect on the function.+-- | The mode of a function parameter: which parts of it are consumed.+-- This can be considered kind of an effect on the function. data Diet   = -- | Does not consume the parameter.     Observe@@ -537,6 +551,23 @@  instance Monoid Diet where   mempty = Observe++-- | The mode of a function result: whether it may alias the+-- arguments.  Note the+-- asymmetry: 'Fresh' is a guarantee about the result, while 'Nonfresh'+-- is a permission granted to the implementation.+data Freshness+  = -- | May alias the observed arguments.+    Nonfresh+  | -- | Aliases nothing that is visible to the caller.+    Fresh+  deriving (Eq, Ord, Show, Bounded)++instance Semigroup Freshness where+  (<>) = min++instance Monoid Freshness where+  mempty = Fresh  -- | An identifier consists of its name and the type of the value -- bound to the identifier.
src/Language/Futhark/Traversals.hs view
@@ -22,6 +22,7 @@   ( ASTMapper (..),     ASTMappable (..),     identityMapper,+    traversePat,     bareExp,   ) where@@ -250,8 +251,8 @@     TERecord <$> traverse (traverse $ astMap tv) ts <*> pure loc   astMap tv (TEArray te dim loc) =     TEArray <$> astMap tv te <*> astMap tv dim <*> pure loc-  astMap tv (TEUnique t loc) =-    TEUnique <$> astMap tv t <*> pure loc+  astMap tv (TEStar t loc) =+    TEStar <$> astMap tv t <*> pure loc   astMap tv (TEApply t1 t2 loc) =     TEApply <$> astMap tv t1 <*> astMap tv t2 <*> pure loc   astMap tv (TEArrow v t1 t2 loc) =@@ -295,11 +296,11 @@ traverseScalarType f g h (Record fs) = Record <$> traverse (traverseType f g h) fs traverseScalarType f g h (TypeVar als t args) =   TypeVar <$> h als <*> f t <*> traverse (traverseTypeArg f g) args-traverseScalarType f g h (Arrow als v u t1 (RetType dims t2)) =+traverseScalarType f g h (Arrow als v o t1 (RetType dims t2)) =   Arrow     <$> h als     <*> pure v-    <*> pure u+    <*> pure o     <*> traverseType f g pure t1     <*> (RetType dims <$> traverseType f g pure t2) traverseScalarType f g h (Sum cs) =@@ -328,7 +329,7 @@ instance ASTMappable ParamType where   astMap tv = traverseType (mapOnName tv) (mapOnExp tv) pure -instance ASTMappable (TypeBase Size Uniqueness) where+instance ASTMappable (TypeBase Size Freshness) where   astMap tv = traverseType (mapOnName tv) (mapOnExp tv) pure  instance ASTMappable ResRetType where@@ -338,6 +339,8 @@   astMap tv (Ident name (Info t) loc) =     Ident name <$> (Info <$> mapOnStructType tv t) <*> pure loc +-- | Traverse the types of a pattern, and the expressions in its type+-- ascriptions. traversePat ::   (Monad m) =>   (t1 -> m t2) ->@@ -453,7 +456,7 @@ bareTypeExp (TETuple tys loc) = TETuple (map bareTypeExp tys) loc bareTypeExp (TERecord fs loc) = TERecord (map (second bareTypeExp) fs) loc bareTypeExp (TEArray size ty loc) = TEArray (bareSizeExp size) (bareTypeExp ty) loc-bareTypeExp (TEUnique ty loc) = TEUnique (bareTypeExp ty) loc+bareTypeExp (TEStar ty loc) = TEStar (bareTypeExp ty) loc bareTypeExp (TEApply ty ta loc) = TEApply (bareTypeExp ty) (bareTypeArgExp ta) loc   where     bareTypeArgExp (TypeArgExpSize size) =
src/Language/Futhark/TypeChecker.hs view
@@ -635,7 +635,7 @@ -- | Check that a type is non-functional, looking up the liftedness of abstract -- types in the environment. This works because entry points cannot be -- polymorphic, so any remaining type names must be abstract.-orderZeroM :: TypeBase dim u -> TypeM Bool+orderZeroM :: TypeBase dim o -> TypeM Bool orderZeroM t = do   (orderZero t &&) . and <$> mapM isUnlifted (typeQualVars t)   where
src/Language/Futhark/TypeChecker/Constraints.hs view
@@ -18,7 +18,7 @@ import Language.Futhark  -- | The type representation used by the constraint solver.-type CtType d = TypeBase d NoUniqueness+type CtType d = TypeBase d NoMode  -- | The reason for a type constraint. Used to generate type error -- messages. The expected type is always the first one.@@ -50,7 +50,7 @@   locOf (ReasonBranches l _ _) = l  -- | A type constraint.-data CtTy d = CtEq (Reason (CtType d)) (TypeBase d NoUniqueness) (TypeBase d NoUniqueness)+data CtTy d = CtEq (Reason (CtType d)) (TypeBase d NoMode) (TypeBase d NoMode)   deriving (Show)  instance Functor CtTy where
src/Language/Futhark/TypeChecker/Consumption.hs view
@@ -1,1091 +1,1866 @@--- | Check that a value definition does not violate any consumption--- constraints.-module Language.Futhark.TypeChecker.Consumption-  ( checkValDef,--    -- * For testing-    Alias (..),-    Aliases,-    TypeAliases,-    inferReturnUniqueness,-  )-where--import Control.Monad-import Control.Monad.Reader-import Control.Monad.State.Strict-import Data.Bifoldable-import Data.Bifunctor-import Data.DList qualified as DL-import Data.Foldable-import Data.List qualified as L-import Data.List.NonEmpty qualified as NE-import Data.Map.Strict qualified as M-import Data.Maybe-import Data.Set qualified as S-import Futhark.Util.Pretty hiding (space)-import Language.Futhark-import Language.Futhark.Traversals-import Language.Futhark.TypeChecker.Monad (Notes, TypeError (..), withIndexLink)-import Prelude hiding (mod)--type Names = S.Set VName---- | A variable that is aliased.  Can be still in-scope, or have gone--- out of scope and be free.  In the latter case, it behaves more like--- an equivalence class.  See uniqueness-error18.fut for an example of--- why this is necessary.-data Alias-  = AliasBound {aliasVar :: VName, aliasFields :: [Name]}-  | AliasFree {aliasVar :: VName, aliasFields :: [Name]}-  deriving (Eq, Ord, Show)--instance Pretty Alias where-  pretty (AliasBound v fs) = prettyAlias v fs-  pretty (AliasFree v fs) = "~" <> prettyAlias v fs--prettyAlias :: VName -> [Name] -> Doc ann-prettyAlias v fs = prettyName v <> mconcat (map (("." <>) . prettyName) fs)--instance Pretty (S.Set Alias) where-  pretty = braces . commasep . map pretty . S.toList---- | The set of in-scope variables that are being aliased.-boundAliases :: Aliases -> S.Set VName-boundAliases = S.map aliasVar . S.filter bound-  where-    bound AliasBound {} = True-    bound AliasFree {} = False---- | Aliases for a type, which is a set of the variables that are--- aliased.-type Aliases = S.Set Alias--type TypeAliases = TypeBase Size Aliases---- | @t \`setAliases\` als@ returns @t@, but with @als@ substituted for--- any already present aliases.-setAliases :: TypeBase dim asf -> ast -> TypeBase dim ast-setAliases t = addAliases t . const---- | @t \`addAliases\` f@ returns @t@, but with any already present--- aliases replaced by @f@ applied to that aliases.-addAliases ::-  TypeBase dim asf ->-  (asf -> ast) ->-  TypeBase dim ast-addAliases = flip second--aliases :: TypeAliases -> Aliases-aliases = bifoldMap (const mempty) id--selfAliasType :: VName -> TypeBase Size asf -> TypeAliases-selfAliasType v = insertSelfAliases v . second (const mempty)--insertSelfAliases :: VName -> TypeAliases -> TypeAliases-insertSelfAliases v = onPath []-  where-    onPath fs (Array als shape et) = Array (S.insert (AliasBound v fs) als) shape et-    onPath fs (Scalar st) = Scalar $ onPath' fs st-    onPath' fs (TypeVar als tn args) = TypeVar (S.insert (AliasBound v fs) als) tn args-    onPath' fs (Record ts) = Record $ M.mapWithKey (\f -> onPath (fs ++ [f])) ts-    onPath' fs (Sum cs) = Sum $ fmap (map (onPath fs)) cs-    onPath' fs (Arrow als mn d ps rt) = Arrow (S.insert (AliasBound v fs) als) mn d ps rt-    onPath' _ et@Prim {} = et--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}-  | Nonconsumable {entryAliases :: a}-  deriving (Eq, Ord, Show)--instance Functor Entry where-  fmap f (Consumable als) = Consumable $ f als-  fmap f (Nonconsumable als) = Nonconsumable $ f als--data CheckEnv = CheckEnv-  { envVtable :: M.Map VName (Entry TypeAliases),-    -- | Location of the definition we are checking.-    envLoc :: Loc-  }---- | A description of where an artificial compiler-generated--- intermediate name came from.-data NameReason-  = -- | Name is the result of a function application.-    NameAppRes (Maybe (QualName VName)) SrcLoc-  | NameLoopRes SrcLoc--nameReason :: SrcLoc -> NameReason -> Doc a-nameReason loc (NameAppRes Nothing apploc) =-  "result of application at" <+> pretty (locStrRel loc apploc)-nameReason loc (NameAppRes fname apploc) =-  "result of applying"-    <+> dquotes (pretty fname)-    <+> parens ("at" <+> pretty (locStrRel loc apploc))-nameReason loc (NameLoopRes apploc) =-  "result of loop at" <+> pretty (locStrRel loc apploc)--type Consumed = M.Map VName Loc--data CheckState = CheckState-  { stateConsumed :: Consumed,-    stateErrors :: DL.DList TypeError,-    stateNames :: M.Map VName NameReason,-    stateCounter :: Int-  }--newtype CheckM a = CheckM (ReaderT CheckEnv (State CheckState) a)-  deriving-    ( Functor,-      Applicative,-      Monad,-      MonadReader CheckEnv,-      MonadState CheckState-    )--runCheckM :: Loc -> CheckM a -> (a, [TypeError])-runCheckM loc (CheckM m) =-  let (a, s) = runState (runReaderT m env) initial_state-   in (a, DL.toList (stateErrors s))-  where-    env =-      CheckEnv-        { envVtable = mempty,-          envLoc = loc-        }-    initial_state =-      CheckState-        { stateConsumed = mempty,-          stateErrors = mempty,-          stateNames = mempty,-          stateCounter = 0-        }--describeVar :: VName -> CheckM (Doc a)-describeVar v = do-  loc <- asks envLoc-  gets $-    maybe ("variable" <+> dquotes (prettyName v)) (nameReason (srclocOf loc))-      . M.lookup v-      . stateNames--noConsumable :: CheckM a -> CheckM a-noConsumable = local $ \env -> env {envVtable = M.map f $ envVtable env}-  where-    f = Nonconsumable . entryAliases--addError :: (Located loc) => loc -> Notes -> Doc () -> CheckM ()-addError loc notes e = modify $ \s ->-  s {stateErrors = DL.snoc (stateErrors s) (TypeError (locOf loc) notes e)}--incCounter :: CheckM Int-incCounter =-  state $ \s -> (stateCounter s, s {stateCounter = stateCounter s + 1})--returnAliased :: Name -> SrcLoc -> CheckM ()-returnAliased name loc =-  addError loc mempty . withIndexLink "return-aliased" $-    "Unique-typed return value is aliased to"-      <+> dquotes (prettyName name)-      <> ", which is not consumable."--uniqueReturnAliased :: SrcLoc -> CheckM ()-uniqueReturnAliased loc =-  addError loc mempty . withIndexLink "unique-return-aliased" $-    "A unique-typed component of the return value is aliased to some other component."--checkReturnAlias :: SrcLoc -> [Pat ParamType] -> ResType -> TypeAliases -> CheckM ()-checkReturnAlias loc params rettp =-  foldM_ (checkReturnAlias' params) S.empty . returnAliases rettp-  where-    checkReturnAlias' params' seen (Unique, names) = do-      when (any (`S.member` S.map snd seen) $ S.toList names) $-        uniqueReturnAliased loc-      notAliasesParam params' $ S.map aliasVar names-      pure $ seen `S.union` tag Unique names-    checkReturnAlias' _ seen (Nonunique, names) = do-      when (any (`S.member` seen) $ S.toList $ tag Unique names) $-        uniqueReturnAliased loc-      pure $ seen `S.union` tag Nonunique names--    notAliasesParam params' names =-      forM_ params' $ \p ->-        let consumedNonunique (v, t) =-              not (consumableParamType t) && (v `S.member` names)-         in case find consumedNonunique $ patternMap p of-              Just (v, _) ->-                returnAliased (baseName v) loc-              Nothing ->-                pure ()--    tag u = S.map (u,)--    returnAliases (Scalar (Record ets1)) (Scalar (Record ets2)) =-      concat $ M.elems $ M.intersectionWith returnAliases ets1 ets2-    returnAliases expected got =-      [(uniqueness expected, aliases got)]--    consumableParamType (Array u _ _) = u == Consume-    consumableParamType (Scalar Prim {}) = True-    consumableParamType (Scalar (TypeVar u _ _)) = u == Consume-    consumableParamType (Scalar (Record fs)) = all consumableParamType fs-    consumableParamType (Scalar (Sum fs)) = all (all consumableParamType) fs-    consumableParamType (Scalar Arrow {}) = False--unscope :: [VName] -> Aliases -> Aliases-unscope bound = S.map f-  where-    f (AliasFree v fs) = AliasFree v fs-    f (AliasBound v fs) = if v `elem` bound then AliasFree v fs else AliasBound v fs---- | Figure out the aliases of each bound name in a pattern.-matchPat :: Pat t -> TypeAliases -> DL.DList (VName, (t, TypeAliases))-matchPat (PatParens p _) t = matchPat p t-matchPat (TuplePat ps _) t-  | Just ts <- isTupleRecord t = mconcat $ zipWith matchPat ps ts-matchPat (RecordPat fs1 _) (Scalar (Record fs2)) =-  mconcat $-    zipWith-      matchPat-      (map snd (sortFields (M.fromList (map (first unLoc) fs1))))-      (map snd (sortFields fs2))-matchPat (Id v (Info t) _) als = DL.singleton (v, (t, als))-matchPat (PatAscription p _ _) t = matchPat p t-matchPat (PatConstr v _ ps _) (Scalar (Sum cs))-  | Just ts <- M.lookup v cs = mconcat $ zipWith matchPat ps ts-matchPat TuplePat {} _ = mempty-matchPat RecordPat {} _ = mempty-matchPat PatConstr {} _ = mempty-matchPat Wildcard {} _ = mempty-matchPat PatLit {} _ = mempty-matchPat (PatAttr _ p _) t = matchPat p t--bindingPat ::-  Pat StructType ->-  TypeAliases ->-  CheckM (a, TypeAliases) ->-  CheckM (a, TypeAliases)-bindingPat p t = fmap (second (second (unscope (patNames p)))) . local bind-  where-    bind env =-      env-        { envVtable =-            foldr (uncurry M.insert . f) (envVtable env) (matchPat p t)-        }-      where-        f (v, (_, als)) = (v, Consumable $ insertSelfAliases v als)--bindingParam :: Pat ParamType -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)-bindingParam p m = do-  mapM_ (noConsumable . bitraverse_ checkExp pure) p-  second (second (unscope (patNames p))) <$> local bind m-  where-    bind env =-      env-        { envVtable =-            foldr (uncurry M.insert . f) (envVtable env) (patternMap p)-        }-    f (v, t)-      | diet t == Consume = (v, Consumable $ selfAliasType v t)-      | otherwise = (v, Nonconsumable $ selfAliasType v t)--bindingIdent :: Diet -> Ident StructType -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)-bindingIdent d (Ident v (Info t) _) =-  fmap (second (second (unscope [v]))) . local bind-  where-    bind env = env {envVtable = M.insert v t' (envVtable env)}-    d' = case d of-      Consume -> Consumable-      Observe -> Nonconsumable-    t' = d' $ selfAliasType v t--bindingParams :: [Pat ParamType] -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)-bindingParams params m =-  noConsumable $-    second (second (unscope (foldMap patNames params)))-      <$> foldr bindingParam m params--bindingLoopForm :: LoopFormBase Info VName -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)-bindingLoopForm (For ident _) m = bindingIdent Observe ident m-bindingLoopForm (ForIn pat _) m = bindingParam pat' m-  where-    pat' = fmap (second (const Observe)) pat-bindingLoopForm While {} m = m--bindingFun :: VName -> TypeAliases -> CheckM a -> CheckM a-bindingFun v t = local $ \env ->-  env {envVtable = M.insert v (Nonconsumable t) (envVtable env)}--checkIfConsumed :: Loc -> Aliases -> CheckM ()-checkIfConsumed rloc als = do-  cons <- gets stateConsumed-  let bad v = fmap (v,) $ v `M.lookup` cons-  forM_ (mapMaybe (bad . aliasVar) $ S.toList als) $ \(v, wloc) -> do-    v' <- describeVar v-    addError rloc mempty . withIndexLink "use-after-consume" $-      "Using"-        <+> v'-        <> ", but this was consumed at"-          <+> pretty (locStrRel rloc wloc)-        <> ".  (Possibly through aliases.)"--consumed :: Consumed -> CheckM ()-consumed vs = modify $ \s -> s {stateConsumed = stateConsumed s <> vs}--consumeAliases :: Loc -> Aliases -> CheckM ()-consumeAliases loc als = do-  vtable <- asks envVtable-  let isBad v =-        case v `M.lookup` vtable of-          Just (Nonconsumable {}) -> True-          Just _ -> False-          Nothing -> True-      checkIfConsumable (AliasBound v _)-        | isBad v = do-            v' <- describeVar v-            addError loc mempty . withIndexLink "not-consumable" $-              "Consuming" <+> v' <> ", which is not consumable."-      checkIfConsumable _ = pure ()-  mapM_ checkIfConsumable $ S.toList als-  checkIfConsumed loc als-  consumed als'-  where-    als' = M.fromList $ map ((,loc) . aliasVar) $ S.toList als---- | Observe the given name here and return its aliases.-observeVar :: Loc -> VName -> StructType -> CheckM TypeAliases-observeVar loc v t = do-  als <--    asks $ \env ->-      maybe (isGlobal (envVtable env)) isLocal $-        M.lookup v (envVtable env)-  checkIfConsumed loc (aliases als)-  pure als-  where-    isLocal = entryAliases--    -- Handling globals is tricky.  For arrays and such, we do want to-    -- track their aliases.  We do not want to track the aliases of-    -- functions.  However, array bindings that are *polymorphic*-    -- should be treated like functions.  However, we do not have-    -- access to the original binding information here.  To avoid-    -- having to plumb that all the way here, we infer that an array-    -- binding is a polymorphic instantiation if its size contains any-    -- locally bound names.-    isGlobal vtable-      | isInstantiation vtable t = second (const mempty) t-      | otherwise = selfAlias $ second (const mempty) t--    isInstantiation vtable =-      any (`M.member` vtable) . fvVars . freeInType--    selfAlias = onPath []-      where-        onPath fs (Array als shape et) = Array (S.insert (AliasBound v fs) als) shape et-        onPath fs (Scalar st) = Scalar $ onPath' fs st-        onPath' _ (TypeVar als tn args) = TypeVar als tn args -- #1675 FIXME-        onPath' fs (Record ts) = Record $ M.mapWithKey (\f -> onPath (fs ++ [f])) ts-        onPath' fs (Sum cs) = Sum $ fmap (map (onPath fs)) cs-        onPath' _ et@Arrow {} = et-        onPath' _ et@Prim {} = et---- Capture any newly consumed variables that occur during the provided action.-contain :: CheckM a -> CheckM (a, Consumed)-contain m = do-  prev_cons <- gets stateConsumed-  x <- m-  new_cons <- gets $ (`M.difference` prev_cons) . stateConsumed-  modify $ \s -> s {stateConsumed = prev_cons}-  pure (x, new_cons)---- | The two types are assumed to be approximately structurally equal,--- but not necessarily regarding sizes.  Combines aliases and prefers--- other information from first argument.-combineAliases :: TypeAliases -> TypeAliases -> TypeAliases-combineAliases (Array als1 et1 shape1) t2 =-  Array (als1 <> aliases t2) et1 shape1-combineAliases (Scalar (TypeVar als1 tv1 targs1)) t2 =-  Scalar $ TypeVar (als1 <> aliases t2) tv1 targs1-combineAliases t1 (Scalar (TypeVar als2 tv2 targs2)) =-  Scalar $ TypeVar (als2 <> aliases t1) tv2 targs2-combineAliases (Scalar (Record ts1)) (Scalar (Record ts2))-  | length ts1 == length ts2,-    L.sort (M.keys ts1) == L.sort (M.keys ts2) =-      Scalar $ Record $ M.intersectionWith combineAliases ts1 ts2-combineAliases-  (Scalar (Arrow als1 mn1 d1 pt1 (RetType dims1 rt1)))-  (Scalar (Arrow als2 _ _ _ (RetType _ _))) =-    Scalar (Arrow (als1 <> als2) mn1 d1 pt1 (RetType dims1 rt1))-combineAliases (Scalar (Sum cs1)) (Scalar (Sum cs2))-  | length cs1 == length cs2,-    L.sort (M.keys cs1) == L.sort (M.keys cs2) =-      Scalar $ Sum $ M.intersectionWith (zipWith combineAliases) cs1 cs2-combineAliases (Scalar (Prim t)) _ = Scalar $ Prim t-combineAliases t1 t2 =-  error $ "combineAliases invalid args: " ++ show (t1, t2)---- An alias inhibits uniqueness if it is used in disjoint values.-aliasesMultipleTimes :: TypeAliases -> Names-aliasesMultipleTimes = S.fromList . map fst . filter ((> 1) . snd) . M.toList . delve-  where-    delve (Scalar (Record fs)) =-      foldl' (M.unionWith (+)) mempty $ map delve $ M.elems fs-    delve (Scalar (TypeVar als _ _)) =-      -- We cannot know anything about abstract types, but must conservatively-      -- assume the worst.-      M.fromList $ map ((,2 :: Int) . aliasVar) $ S.toList als-    delve t =-      M.fromList $ map ((,1 :: Int) . aliasVar) $ S.toList $ aliases t--consumingParams :: [Pat ParamType] -> Names-consumingParams =-  S.fromList . map fst . filter ((== Consume) . diet . snd) . foldMap patternMap--arrayAliases :: TypeAliases -> Aliases-arrayAliases (Array als _ _) = als-arrayAliases (Scalar Prim {}) = mempty-arrayAliases (Scalar (Record fs)) = foldMap arrayAliases fs-arrayAliases (Scalar (TypeVar als _ _)) = als-arrayAliases (Scalar Arrow {}) = mempty-arrayAliases (Scalar (Sum fs)) =-  mconcat $ concatMap (map arrayAliases) $ M.elems fs--overlapCheck :: (Pretty src, Pretty ve) => Loc -> (src, TypeAliases) -> (ve, TypeAliases) -> CheckM ()-overlapCheck loc (src, src_als) (ve, ve_als) =-  when (any (`S.member` aliases src_als) (aliases ve_als)) $-    addError loc mempty $-      "Source array for in-place update"-        </> indent 2 (pretty src)-        </> "might alias update value"-        </> indent 2 (pretty ve)-        </> "Hint: use"-        <+> dquotes "copy"-        <+> "to remove aliases from the value."--inferReturnUniqueness :: [Pat ParamType] -> ResType -> TypeAliases -> ResType-inferReturnUniqueness [] ret _ = ret `setUniqueness` Nonunique-inferReturnUniqueness params ret ret_als = delve ret ret_als-  where-    forbidden = aliasesMultipleTimes ret_als-    consumings = consumingParams params-    delve (Scalar (Record fs1)) (Scalar (Record fs2)) =-      Scalar $ Record $ M.intersectionWith delve fs1 fs2-    delve (Scalar (Sum cs1)) (Scalar (Sum cs2)) =-      Scalar $ Sum $ M.intersectionWith (zipWith delve) cs1 cs2-    delve t t_als-      | all (`S.member` consumings) $ boundAliases (arrayAliases t_als),-        not $ any ((`S.member` forbidden) . aliasVar) (aliases t_als) =-          t `setUniqueness` Unique-      | otherwise =-          t `setUniqueness` Nonunique--checkSubExps :: (ASTMappable e) => e -> CheckM e-checkSubExps = astMap identityMapper {mapOnExp = fmap fst . checkExp}--noAliases :: Exp -> CheckM (Exp, TypeAliases)-noAliases e = do-  e' <- checkSubExps e-  pure (e', second (const mempty) (typeOf e))--aliasParts :: TypeAliases -> [Aliases]-aliasParts (Scalar (Record ts)) = foldMap aliasParts $ M.elems ts-aliasParts t = [aliases t]--noSelfAliases :: Loc -> TypeAliases -> CheckM ()-noSelfAliases loc = foldM_ check mempty . aliasParts-  where-    check seen als = do-      when (any (`S.member` seen) als) $-        addError loc mempty . withIndexLink "self-aliasing-arg" $-          "Argument passed for consuming parameter is self-aliased."-      pure $ als <> seen--consumeAsNeeded :: Loc -> ParamType -> TypeAliases -> CheckM ()-consumeAsNeeded loc pt t = consumeAliases loc $ consumeAliasesOf pt t-  where-    consumeAliasesOf (Scalar (Record fs1)) (Scalar (Record fs2)) =-      mconcat $ M.elems $ M.intersectionWith consumeAliasesOf fs1 fs2-    consumeAliasesOf p_t t_als-      | diet p_t == Consume = aliases t_als-      | otherwise = mempty--checkArg :: [(Exp, TypeAliases)] -> ParamType -> Exp -> CheckM (Exp, TypeAliases)-checkArg prev p_t e = do-  ((e', e_als), e_cons) <- contain $ checkExp e-  consumed e_cons-  let e_t = typeOf e'-  when (e_cons /= mempty && not (orderZero e_t)) $-    addError (locOf e) mempty . withIndexLink "consuming-argument" $-      "Argument of functional type"-        </> indent 2 (pretty e_t)-        </> "contains consumption, which is not allowed."-  when (diet p_t == Consume) $ do-    noSelfAliases (locOf e) e_als-    consumeAsNeeded (locOf e) p_t e_als-    case mapMaybe prevAlias $ S.toList $ boundAliases $ aliases e_als of-      [] -> pure ()-      (v, prev_arg) : _ ->-        addError (locOf e) mempty $-          "Argument is consumed, but aliases"-            </> indent 2 (prettyName v)-            </> "which is also aliased by other argument"-            </> indent 2 (pretty prev_arg)-            </> "at"-            <+> pretty (locTextRel (locOf e) (locOf prev_arg))-            <> "."-  pure (e', e_als)-  where-    prevAlias v =-      (v,) . fst <$> find (S.member v . boundAliases . aliases . snd) prev---- | @returnType appres ret_type arg_diet arg_type@ gives result of applying--- an argument the given types to a function with the given return--- type, consuming the argument with the given diet.-returnType :: Aliases -> ResType -> Diet -> TypeAliases -> TypeAliases-returnType _ (Array Unique et shape) _ _ =-  Array mempty et shape-returnType appres (Array Nonunique et shape) Consume _ =-  Array appres et shape-returnType appres (Array Nonunique et shape) Observe arg =-  Array (appres <> aliases arg) et shape-returnType _ (Scalar (TypeVar Unique t targs)) _ _ =-  Scalar $ TypeVar mempty t targs-returnType appres (Scalar (TypeVar Nonunique t targs)) Consume _ =-  Scalar $ TypeVar appres t targs-returnType appres (Scalar (TypeVar Nonunique t targs)) Observe arg =-  Scalar $ TypeVar (appres <> aliases arg) t targs-returnType appres (Scalar (Record fs)) d arg =-  Scalar $ Record $ fmap (\et -> returnType appres et d arg) fs-returnType _ (Scalar (Prim t)) _ _ =-  Scalar $ Prim t-returnType appres (Scalar (Arrow _ v pd t1 (RetType dims t2))) Consume _ =-  Scalar $ Arrow appres v pd t1 $ RetType dims t2-returnType appres (Scalar (Arrow _ v pd t1 (RetType dims t2))) Observe arg =-  Scalar $ Arrow (appres <> aliases arg) v pd t1 $ RetType dims t2-returnType appres (Scalar (Sum cs)) d arg =-  Scalar $ Sum $ (fmap . fmap) (\et -> returnType appres et d arg) cs--applyArg :: TypeAliases -> TypeAliases -> TypeAliases-applyArg (Scalar (Arrow closure_als _ d _ (RetType _ rettype))) arg_als =-  returnType closure_als rettype d arg_als-applyArg _ arg_als = arg_als--applyLoopArg :: Aliases -> ParamType -> TypeAliases -> ResType -> TypeAliases-applyLoopArg appres (Scalar (Record pfs)) (Scalar (Record afs)) (Scalar (Record rfs)) =-  Scalar . Record $-    M.mapWithKey-      (\k p_t -> applyLoopArg appres p_t (afs M.! k) (rfs M.! k))-      pfs-applyLoopArg appres p_t arg_als rettype =-  returnType appres rettype (diet p_t) arg_als--boundFreeInExp :: Exp -> CheckM (M.Map VName TypeAliases)-boundFreeInExp e = do-  vtable <- asks envVtable-  pure $-    M.mapMaybe (fmap entryAliases) . M.fromSet (`M.lookup` vtable) $-      fvVars (freeInExp e)---- Loops are tricky because we want to infer the uniqueness of their--- parameters.  This is pretty unusual: we do not do this for ordinary--- functions.-type Loop = (Pat ParamType, LoopInitBase Info VName, LoopFormBase Info VName, Exp)---- | Mark bindings of consumed names as Consume, except those under a--- 'PatAscription', which are left unchanged.-updateParamDiet :: (VName -> Bool) -> Pat ParamType -> Pat ParamType-updateParamDiet cons = recurse-  where-    recurse (Wildcard (Info t) wloc) =-      Wildcard (Info $ t `setUniqueness` Observe) wloc-    recurse (PatParens p ploc) =-      PatParens (recurse p) ploc-    recurse (PatAttr attr p ploc) =-      PatAttr attr (recurse p) ploc-    recurse (Id name (Info t) iloc)-      | cons name =-          let t' = t `setUniqueness` Consume-           in Id name (Info t') iloc-      | otherwise =-          let t' = t `setUniqueness` Observe-           in Id name (Info t') iloc-    recurse (TuplePat pats ploc) =-      TuplePat (map recurse pats) ploc-    recurse (RecordPat fs ploc) =-      RecordPat (map (fmap recurse) fs) ploc-    recurse (PatAscription p t ploc) =-      PatAscription p t ploc-    recurse p@PatLit {} = p-    recurse (PatConstr n t ps ploc) =-      PatConstr n t (map recurse ps) ploc--convergeLoopParam :: Loc -> Pat ParamType -> Names -> TypeAliases -> CheckM (Pat ParamType)-convergeLoopParam loop_loc param body_cons body_als = do-  let -- Make the pattern Consume where needed.-      param' = updateParamDiet (`S.member` S.filter (`elem` patNames param) body_cons) param--  -- Check that the new values of consumed merge parameters do not-  -- alias something bound outside the loop, AND that anything-  -- returned for a unique merge parameter does not alias anything-  -- else returned.-  let checkMergeReturn (Id pat_v (Info pat_v_t) patloc) t = do-        let free_als = S.filter (`notElem` patNames param) $ boundAliases (aliases t)-        when (diet pat_v_t == Consume) $ forM_ free_als $ \v ->-          lift-            . addError loop_loc mempty-            . withIndexLink "consuming-loop-param-aliases"-            $ "Return value for consuming loop parameter"-              <+> dquotes (prettyName pat_v)-              <+> "aliases"-              <+> dquotes (prettyName v)-              <> "."-        (cons, obs) <- get-        unless (S.null $ aliases t `S.intersection` cons)-          $ lift-            . addError loop_loc mempty-            . withIndexLink "loop-parameter-aliases-other"-          $ "Return value for loop parameter"-            <+> dquotes (prettyName pat_v)-            <+> "aliases other consumed loop parameter."-        when-          ( diet pat_v_t == Consume-              && not (S.null (aliases t `S.intersection` (cons <> obs)))-          )-          $ lift . addError loop_loc mempty-          $ withIndexLink "aliases-previously-returned"-          $ "Return value for consuming loop parameter"-            <+> dquotes (prettyName pat_v)-            <+> "aliases previously returned value."-        if diet pat_v_t == Consume-          then put (cons <> aliases t, obs)-          else put (cons, obs <> aliases t)--        pure $ Id pat_v (Info pat_v_t) patloc-      checkMergeReturn (Wildcard (Info pat_v_t) patloc) _ =-        pure $ Wildcard (Info pat_v_t) patloc-      checkMergeReturn (PatParens p _) t =-        checkMergeReturn p t-      checkMergeReturn (PatAscription p _ _) t =-        checkMergeReturn p t-      checkMergeReturn (RecordPat pfs patloc) (Scalar (Record tfs)) =-        RecordPat . map unshuffle . M.toList <$> sequence pfs' <*> pure patloc-        where-          pfs' = M.intersectionWith check (M.fromList (map shuffle pfs)) tfs-          check (loc, x) y = (loc,) <$> checkMergeReturn x y-          shuffle (L loc v, t) = (v, (loc, t))-          unshuffle (v, (loc, t)) = (L loc v, t)-      checkMergeReturn (TuplePat pats patloc) t-        | Just ts <- isTupleRecord t =-            TuplePat <$> zipWithM checkMergeReturn pats ts <*> pure patloc-      checkMergeReturn p _ =-        pure p--  (param'', (param_cons, _)) <--    runStateT (checkMergeReturn param' body_als) (mempty, mempty)--  let body_cons' = body_cons <> S.map aliasVar param_cons-  if body_cons' == body_cons && patternType param'' == patternType param-    then pure param'-    else convergeLoopParam loop_loc param'' body_cons' body_als--checkLoop :: Loc -> Loop -> CheckM (Loop, TypeAliases)-checkLoop loop_loc (param, arg, form, body) = do-  form' <- checkSubExps form-  -- We pretend that every part of the loop parameter has a consuming-  -- diet, as we need to allow consumption in the body, which we then-  -- use to infer the proper diet of the parameter.-  ((body', body_cons), body_als) <--    noConsumable-      . bindingParam (updateParamDiet (const True) param)-      . bindingLoopForm form'-      $ do-        ((body', body_als), body_cons) <- contain $ checkExp body-        pure ((body', body_cons), body_als)-  param' <- convergeLoopParam loop_loc param (M.keysSet body_cons) body_als--  let param_t = patternType param'-  ((arg', arg_als), arg_cons) <- case arg of-    LoopInitImplicit (Info e) ->-      contain $ first (LoopInitImplicit . Info) <$> checkArg [] param_t e-    LoopInitExplicit e ->-      contain $ first LoopInitExplicit <$> checkArg [] param_t e-  consumed arg_cons--  let checkFree what e = do-        free_bound <- boundFreeInExp e--        let bad = any (`M.member` arg_cons) . boundAliases . aliases . snd-        forM_ (filter bad $ M.toList free_bound) $ \(v, _) -> do-          v' <- describeVar v-          addError loop_loc mempty $-            what-              <+> "uses"-              <+> v'-              <> " (or an alias),"-                </> "but this is consumed by the initial loop argument."--  checkFree "Loop body" body--  case form of-    While cond -> checkFree "Loop condition" cond-    _ -> pure ()--  v <- VName "internal_loop_result" <$> incCounter-  modify $ \s -> s {stateNames = M.insert v (NameLoopRes (srclocOf loop_loc)) $ stateNames s}--  let loop_als =-        applyLoopArg-          (S.singleton (AliasFree v []))-          param_t-          arg_als-          (paramToRes param_t)-  pure-    ( (param', arg', form', body'),-      loop_als `combineAliases` body_als-    )--checkFuncall ::-  (Foldable f) =>-  SrcLoc ->-  Maybe (QualName VName) ->-  TypeAliases ->-  f TypeAliases ->-  CheckM TypeAliases-checkFuncall loc fname f_als arg_als = do-  v <- VName "internal_app_result" <$> incCounter-  modify $ \s -> s {stateNames = M.insert v (NameAppRes fname loc) $ stateNames s}-  pure $ foldl applyArg (second (S.insert (AliasFree v [])) f_als) arg_als--checkExp :: Exp -> CheckM (Exp, TypeAliases)--- First we have the complicated cases.-----checkExp (AppExp (Apply f args loc) appres) = do-  (f', f_als) <- checkExp f-  (args', args_als) <- NE.unzip <$> checkArgs (diets $ toRes Nonunique f_als) args-  res_als <- checkFuncall loc (fname f) f_als args_als-  pure (AppExp (Apply f' args' loc) appres, res_als)-  where-    fname (Var v _ _) = Just v-    fname (AppExp (Apply e _ _) _) = fname e-    fname _ = Nothing-    checkArg' prev d (Info p, e) = do-      (e', e_als) <- checkArg prev (second (const d) (typeOf e)) e-      pure ((Info p, e'), e_als)--    diets (Scalar (Arrow _ _ d _ (RetType _ rt))) =-      d : diets rt-    diets _ = repeat Observe--    checkArgs ds (x NE.:| args') = do-      let (d, ds') = fromMaybe (Observe, []) $ L.uncons ds-      -- Note Futhark uses right-to-left evaluation of applications.-      args'' <- maybe (pure []) (fmap NE.toList . checkArgs ds') $ NE.nonEmpty args'-      (x', x_als) <- checkArg' (map (first snd) args'') d x-      pure $ (x', x_als) NE.:| args''-----checkExp (AppExp (Loop sparams pat loopinit form body loc) appres) = do-  ((pat', loopinit', form', body'), als) <--    checkLoop (locOf loc) (pat, loopinit, form, body)-  pure-    ( AppExp (Loop sparams pat' loopinit' form' body' loc) appres,-      als-    )-----checkExp (AppExp (LetPat sizes p e body loc) appres) = do-  ((e', e_als), e_cons) <- contain $ checkExp e-  consumed e_cons-  let e_t = typeOf e'-  when (e_cons /= mempty && not (orderZero e_t)) $-    addError (locOf e) mempty . withIndexLink "contains-consumption" $-      "Let-bound expression of higher-order type"-        </> indent 2 (pretty e_t)-        </> "contains consumption, which is not allowed."-  bindingPat p e_als $ do-    (body', body_als) <- checkExp body-    pure-      ( AppExp (LetPat sizes p e' body' loc) appres,-        body_als-      )-----checkExp (AppExp (If cond te fe loc) appres) = do-  (cond', _) <- checkExp cond-  ((te', te_als), te_cons) <- contain $ checkExp te-  ((fe', fe_als), fe_cons) <- contain $ checkExp fe-  let all_cons = te_cons <> fe_cons-      notConsumed = not . (`M.member` all_cons) . aliasVar-      comb_als = second (S.filter notConsumed) $ te_als `combineAliases` fe_als-  consumed all_cons-  pure-    ( AppExp (If cond' te' fe' loc) appres,-      appResType (unInfo appres) `setAliases` mempty `combineAliases` comb_als-    )-----checkExp (AppExp (Match cond cs loc) appres) = do-  (cond', cond_als) <- checkExp cond-  ((cs', cs_als), cs_cons) <--    first NE.unzip . NE.unzip <$> mapM (checkCase cond_als) cs-  let all_cons = fold cs_cons-      notConsumed = not . (`M.member` all_cons) . aliasVar-      comb_als = second (S.filter notConsumed) $ foldl1 combineAliases cs_als-  consumed all_cons-  pure-    ( AppExp (Match cond' cs' loc) appres,-      appResType (unInfo appres) `setAliases` mempty `combineAliases` comb_als-    )-  where-    checkCase cond_als (CasePat p body caseloc) =-      contain $ bindingPat p cond_als $ do-        (body', body_als) <- checkExp body-        pure (CasePat p body' caseloc, body_als)-----checkExp (AppExp (LetFun fname (typarams, params, retdecl, Info (RetType ext ret), funbody) letbody loc) appres) = do-  ((ret', funbody'), ftype) <- bindingParams params $ do-    -- Throw away the consumption - it can refer only to the parameters-    -- anyway.-    ((funbody', funbody_als), _body_cons) <- contain $ checkExp funbody-    checkReturnAlias loc params ret funbody_als-    checkGlobalAliases loc params funbody_als-    free_bound <- boundFreeInExp funbody-    let ret' = maybe (inferReturnUniqueness params ret funbody_als) (const ret) retdecl-        als = foldMap aliases (M.elems free_bound)-        ftype = funType params (RetType ext ret') `setAliases` als-    pure ((ret', funbody'), ftype)-  (letbody', letbody_als) <- bindingFun (fst fname) ftype $ checkExp letbody-  pure-    ( AppExp (LetFun fname (typarams, params, retdecl, Info (RetType ext ret'), funbody') letbody' loc) appres,-      letbody_als-    )-----checkExp (AppExp (BinOp (op, oploc) opt (x, xp) (y, yp) loc) appres) = do-  op_als <- observeVar (locOf oploc) (qualLeaf op) (unInfo opt)-  let (_, at1) : (_, at2) : _ = fst $ unfoldFunType op_als-  (x', x_als) <- checkArg [] at1 x-  (y', y_als) <- checkArg [(x', x_als)] at2 y-  res_als <- checkFuncall loc (Just op) op_als [x_als, y_als]-  pure-    ( AppExp (BinOp (op, oploc) opt (x', xp) (y', yp) loc) appres,-      res_als-    )-----checkExp e@(Lambda params body te (Info (RetType ext ret)) loc) =-  bindingParams params $ do-    -- Throw away the consumption - it can refer only to the parameters-    -- anyway.-    ((body', body_als), _body_cons) <- contain $ checkExp body-    checkReturnAlias loc params ret body_als-    checkGlobalAliases loc params body_als-    free_bound <- boundFreeInExp e-    let ret' = maybe (inferReturnUniqueness params ret body_als) (const ret) te-        als = foldMap aliases (M.elems free_bound)-        ftype = funType params (RetType ext ret') `setAliases` als-    pure-      ( Lambda params body' te (Info (RetType ext ret')) loc,-        ftype-      )-----checkExp (AppExp (LetWith dst src steps ve body loc) appres) = do-  steps' <- mapM checkStep steps-  (ve', ve_als) <- checkExp ve-  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 steps ve t loc) = do-  steps' <- mapM checkStep steps-  (ve', ve_als) <- checkExp ve-  (src', src_als) <- checkExp src-  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-  als <- observeVar (locOf loc) (qualLeaf v) t-  checkIfConsumed (locOf loc) (aliases als)-  pure (Var v (Info t) loc, als)-checkExp (OpSection v (Info t) loc) = do-  als <- observeVar (locOf loc) (qualLeaf v) t-  checkIfConsumed (locOf loc) (aliases als)-  pure (OpSection v (Info t) loc, als)-checkExp (OpSectionLeft op ftype arg arginfo retinfo loc) = do-  let (_, Info (pn, pt2)) = arginfo-      (Info ret, _) = retinfo-  als <- observeVar (locOf loc) (qualLeaf op) (unInfo ftype)-  (arg', arg_als) <- checkExp arg-  pure-    ( OpSectionLeft op ftype arg' arginfo retinfo loc,-      Scalar $ Arrow (aliases arg_als <> aliases als) pn (diet pt2) (toStruct pt2) ret-    )-checkExp (OpSectionRight op ftype arg arginfo retinfo loc) = do-  let (Info (pn, pt2), _) = arginfo-      Info ret = retinfo-  als <- observeVar (locOf loc) (qualLeaf op) (unInfo ftype)-  (arg', arg_als) <- checkExp arg-  pure-    ( OpSectionRight op ftype arg' arginfo retinfo loc,-      Scalar $ Arrow (aliases arg_als <> aliases als) pn (diet pt2) (toStruct pt2) ret-    )-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)-checkExp (Ascript e te loc) = do-  (e', e_als) <- checkExp e-  pure (Ascript e' te loc, e_als)-checkExp (AppExp (Index v slice loc) appres) = do-  (v', v_als) <- checkExp v-  slice' <- checkSubExps slice-  pure-    ( AppExp (Index v' slice' loc) appres,-      appResType (unInfo appres) `setAliases` aliases v_als-    )-checkExp (Assert e1 e2 t loc) = do-  (e1', _) <- checkExp e1-  (e2', e2_als) <- checkExp e2-  pure (Assert e1' e2' t loc, e2_als)-checkExp (Parens e loc) = do-  (e', e_als) <- checkExp e-  pure (Parens e' loc, e_als)-checkExp (QualParens v e loc) = do-  (e', e_als) <- checkExp e-  pure (QualParens v e' loc, e_als)-checkExp (Attr attr e loc) = do-  (e', e_als) <- checkExp e-  pure (Attr attr e' loc, e_als)-checkExp (Project name e t loc) = do-  (e', e_als) <- checkExp e-  pure-    ( Project name e' t loc,-      case e_als of-        Scalar (Record fs)-          | Just name_als <- M.lookup name fs -> name_als-        _ -> error $ "checkExp Project: bad type " <> prettyString e_als-    )-checkExp (TupLit es loc) = do-  (es', es_als) <- mapAndUnzipM checkExp es-  pure (TupLit es' loc, Scalar $ tupleRecord es_als)-checkExp (Constr name es t loc) = do-  (es', es_als) <- mapAndUnzipM checkExp es-  pure-    ( Constr name es' t loc,-      case unInfo t of-        Scalar (Sum cs) ->-          Scalar . Sum . M.insert name es_als $-            M.map (map (`setAliases` mempty)) cs-        t' -> error $ "checkExp Constr: bad type " <> prettyString t'-    )-checkExp (RecordLit fs loc) = do-  (fs', fs_als) <- mapAndUnzipM checkField fs-  pure (RecordLit fs' loc, Scalar $ Record $ M.fromList fs_als)-  where-    checkField (RecordFieldExplicit name e floc) = do-      (e', e_als) <- checkExp e-      pure (RecordFieldExplicit name e' floc, (unLoc name, e_als))-    checkField (RecordFieldImplicit name t floc) = do-      name_als <- observeVar (locOf floc) (unLoc name) $ unInfo t-      pure (RecordFieldImplicit name t floc, (baseName (unLoc name), name_als))---- Cases that create alias-free values.-checkExp e@(AppExp Range {} _) = noAliases e-checkExp e@IntLit {} = noAliases e-checkExp e@FloatLit {} = noAliases e-checkExp e@Literal {} = noAliases e-checkExp e@StringLit {} = noAliases e-checkExp e@ArrayVal {} = noAliases e-checkExp e@ArrayLit {} = noAliases e-checkExp e@Negate {} = noAliases e-checkExp e@Not {} = noAliases e-checkExp e@Hole {} = noAliases e--checkGlobalAliases :: SrcLoc -> [Pat ParamType] -> TypeAliases -> CheckM ()-checkGlobalAliases loc params body_t = do-  vtable <- asks envVtable-  let global = flip M.notMember vtable-  unless (null params) $ forM_ (boundAliases $ arrayAliases body_t) $ \v ->-    when (global v) . addError loc mempty . withIndexLink "alias-free-variable" $-      "Function result aliases the free variable "-        <> dquotes (prettyName v)-        <> "."-          </> "Use"-          <+> dquotes "copy"-          <+> "to break the aliasing."---- | Type-check a value definition.  This also infers a new return--- type that may be more unique than previously.-checkValDef ::-  (VName, [Pat ParamType], Exp, ResRetType, Maybe (TypeExp Exp VName), SrcLoc) ->-  ((Exp, ResRetType), [TypeError])-checkValDef (_fname, params, body, RetType ext ret, retdecl, loc) = runCheckM (locOf loc) $ do-  fmap fst . bindingParams params $ do-    (body', body_als) <- checkExp body-    checkReturnAlias loc params ret body_als-    checkGlobalAliases loc params body_als-    -- If the user did not provide an annotation (meaning the return-    -- type is fully inferred), we infer the uniqueness.  Otherwise,-    -- we go with whatever they wanted.  This lets the user define-    -- non-unique return types even if the body actually has no-    -- aliases.-    ret' <- case retdecl of-      Just retdecl' -> do-        when (null params && unique ret) $-          addError retdecl' mempty "A top-level constant cannot have a unique type."-        pure $ RetType ext ret-      Nothing ->-        pure $-          RetType ext $-            inferReturnUniqueness params ret body_als--    pure-      ( (body', ret'),-        body_als -- Don't matter.-      )-{-# NOINLINE checkValDef #-}+-- | Check that a value definition does not violate any consumption constraints,+-- via alias analysis.+--+-- This is a very subtle part of the language. The basic idea is "the result of+-- an expression aliases everything that goes into it", but this is in practice+-- too restrictive when we have functions (and polymorphic and higher-order+-- functions!) as well. However, we also do not want to make the user-facing+-- type system too complicated.+--+-- Our solution is to infer more precise function types, that directly talk+-- about alias information, via parametricity. These never escape into the+-- user-facing language.+--+-- Our overall philosophy is that soundness is (of course) non-negotiable, but+-- simplicity is better than flexibility. Futhark is not a language for very+-- fine-grained reasoning about aliasing.+--+-- As an example of the compromise, @x |> copy@ works and produces a fresh+-- result, whilst @id >-> copy@ loses freshness information.+--+-- Further, we only infer freshness for fully saturated higher-order functions,+-- so refactoring to take advantage of partial application may not work.+-- Likewise, we infer only the freshness of the value a function returns, not+-- of what a returned function in turn returns: that must be declared on the+-- returned lambda itself.+module Language.Futhark.TypeChecker.Consumption+  ( checkValDef,++    -- * For testing+    Alias (..),+    Aliases,+    TypeAliases,+    inferReturnFreshness,+  )+where++import Control.Monad+import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.Bifoldable+import Data.Bifunctor+import Data.DList qualified as DL+import Data.Foldable+import Data.Functor.Const+import Data.Functor.Identity+import Data.List qualified as L+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Set qualified as S+import Data.Text qualified as T+import Futhark.Util (nubOrd)+import Futhark.Util.Pretty hiding (space)+import Language.Futhark+import Language.Futhark.Traversals+import Language.Futhark.TypeChecker.Monad (BoundV (..), Notes, TypeError (..), withIndexLink)+import Prelude hiding (mod)++-- | A position within a compound type. A path step is a record field name, or a+-- constructor name followed by the tuple field name of a position in its+-- payload.+type Path = [Name]++-- | A variable together with a path: the component of that variable at that+-- path, as defined by 'traverseLeaves'.  See Note [Locations].+type Location = (VName, Path)++-- | Something a value may share memory with. Every constructor but 'AliasSelf'+-- denotes a 'Location'. Its variable may be in scope, or be free: either it has+-- gone out of scope, or it is an internal name standing for an intermediate+-- value. A free alias behaves more like an equivalence class. See+-- uniqueness-error18.fut for an example of why this is necessary.+data Alias+  = AliasBound Location+  | AliasFree Location+  | -- | Used to represent unknowable internal aliasing, which for example may+    -- occur for a function that returns a nonfresh abstract type. (That+    -- abstract type may internally be a pair of arrays that alias each other.)+    AliasSelf+  deriving (Eq, Ord, Show)++instance Pretty Alias where+  pretty (AliasBound (v, fs)) = prettyAlias v fs+  pretty (AliasFree (v, fs)) = "~" <> prettyAlias v fs+  pretty AliasSelf = "self"++-- | The location an alias refers to.  'AliasSelf' refers to none.+aliasLoc :: Alias -> Maybe Location+aliasLoc (AliasBound l) = Just l+aliasLoc (AliasFree l) = Just l+aliasLoc AliasSelf = Nothing++-- | The variable an alias refers to.  'AliasSelf' does not refer to any+-- variable, as it denotes aliasing internal to a value.+aliasVar :: Alias -> Maybe VName+aliasVar = fmap fst . aliasLoc++-- | Apply a function to every leaf of a type (every component that is neither a+-- record nor a sum) along with its path.+traverseLeaves ::+  (Applicative f) =>+  (Path -> TypeBase dim o -> f (TypeBase dim v)) ->+  TypeBase dim o ->+  f (TypeBase dim v)+traverseLeaves f = go []+  where+    go p (Scalar (Record ts)) =+      Scalar . Record <$> M.traverseWithKey (\k -> go (p ++ [k])) ts+    go p (Scalar (Sum cs)) =+      Scalar . Sum <$> M.traverseWithKey (\c -> zipWithM (\i -> go (p ++ [c, i])) tupleFieldNames) cs+    go p t = f p t++-- | Apply a function to every leaf of a type along with its path.+mapLeaves :: (Path -> TypeBase dim o -> TypeBase dim v) -> TypeBase dim o -> TypeBase dim v+mapLeaves f = runIdentity . traverseLeaves (\p -> Identity . f p)++-- | The leaves of a type along with their paths.+leaves :: TypeBase dim o -> [(Path, TypeBase dim o)]+leaves = getConst . traverseLeaves (\p t -> Const [(p, t)])++-- | The locations these aliases refer to.+aliasLocs :: Aliases -> [Location]+aliasLocs = mapMaybe aliasLoc . S.toList++-- | The variables these aliases refer to.  'AliasSelf' contributes nothing,+-- as it refers to no variable.+aliasVars :: Aliases -> S.Set VName+aliasVars = S.fromList . mapMaybe aliasVar . S.toList++-- | Does this value have internal aliasing, meaning it can neither be consumed+-- nor given a fresh type?  See 'AliasSelf'.+selfAliased :: Aliases -> Bool+selfAliased = S.member AliasSelf++-- | Might two values with these aliases share memory? This is not the same+-- question as whether the sets intersect: 'AliasSelf' denotes a property of a+-- single value rather than a shared referent ('aliasVar' is 'Nothing' for it),+-- so two values that both have internal aliasing are not thereby aliases of+-- each other. Avoid comparing alias sets in any other way than through this+-- function.+overlaps :: Aliases -> Aliases -> Bool+overlaps x y = not $ S.disjoint (referents x) (referents y)+  where+    referents = S.filter (isJust . aliasVar)++prettyAlias :: VName -> [Name] -> Doc ann+prettyAlias v fs = prettyName v <> mconcat (map (("." <>) . prettyName) fs)++instance Pretty (S.Set Alias) where+  pretty = braces . commasep . map pretty . S.toList++-- | Does this alias refer to an in-scope variable?  'AliasFree' has left+-- scope and 'AliasSelf' is no variable at all.  This is not the way to ask+-- whether two values may share memory; see 'overlaps'.+isBoundAlias :: Alias -> Bool+isBoundAlias AliasBound {} = True+isBoundAlias _ = False++-- | What a value may share memory with.+type Aliases = S.Set Alias++type TypeAliases = TypeBase Size Aliases++-- | @t \`setAliases\` als@ returns @t@, but with @als@ substituted for+-- any already present aliases.+setAliases :: TypeBase dim o1 -> o2 -> TypeBase dim o2+setAliases t = addAliases t . const++-- | @t \`addAliases\` f@ returns @t@, but with any already present+-- aliases replaced by @f@ applied to that aliases.+addAliases :: TypeBase dim o1 -> (o1 -> o2) -> TypeBase dim o2+addAliases = flip second++aliases :: TypeAliases -> Aliases+aliases = bifoldMap (const mempty) id++-- | Add an alias to a leaf of a type. That means we assume the type passed in+-- here is not a compound type.+aliasLeaf :: Alias -> TypeAliases -> TypeAliases+aliasLeaf a (Array als shape et) = Array (S.insert a als) shape et+aliasLeaf a (Scalar (TypeVar als tn args)) = Scalar $ TypeVar (S.insert a als) tn args+aliasLeaf a (Scalar (Arrow als mn d ps rt)) = Scalar $ Arrow (S.insert a als) mn d ps rt+aliasLeaf _ t = t++-- | @insertSelfAliases v t@ adds an alias of @v@ to every component of @t@,+-- noting the path at which the component sits.+insertSelfAliases :: VName -> TypeAliases -> TypeAliases+insertSelfAliases v = mapLeaves $ aliasLeaf . AliasBound . (v,)++-- | Does any component of the value that this type ultimately produces satisfy+-- the predicate? Function types are followed to their (curried) result, as the+-- only way to obtain a value from a function is to apply it.+anyResultComponent :: (ResType -> Bool) -> ResType -> Bool+anyResultComponent p (Scalar (Arrow _ _ _ _ (RetType _ t))) = anyResultComponent p t+anyResultComponent p (Scalar (Record fs)) = any (anyResultComponent p) fs+anyResultComponent p (Scalar (Sum cs)) = any (any (anyResultComponent p)) cs+anyResultComponent p t = p t++-- | The aliases of a use of the global @v@, given its type scheme and the type+-- it is used at. A use of a global name aliases that name, except where+-- parametricity rules it out. In particular, a non-function component whose+-- declared type contains one of the type parameters cannot be (part of) a+-- global, and a function can only yield a value aliasing a global if some+-- nonfresh component of its result is not of that kind. See Note [Parametric+-- results].+globalAliases :: VName -> BoundV -> StructType -> TypeAliases+globalAliases v (BoundV tparams decl) = mapLeaves onLeaf . second (const mempty)+  where+    tparams' = S.fromList [p | TypeParamType _ p _ <- tparams]++    -- A type parameter counts only where it is itself a type, not where it is+    -- an argument to an abstract type, which may ignore it.+    parametric :: TypeBase Size u -> Bool+    parametric (Array _ _ et) = parametric $ Scalar et+    parametric (Scalar (TypeVar _ tn _)) = qualLeaf tn `S.member` tparams'+    parametric (Scalar (Record fs)) = any parametric fs+    parametric (Scalar (Sum cs)) = any (any parametric) cs+    parametric _ = False++    decl_leaves = leaves decl++    onLeaf p t =+      case listToMaybe [d | (dp, d) <- decl_leaves, dp `L.isPrefixOf` p] of+        Just d@(Scalar Arrow {})+          | anyResultComponent maybeGlobal (toRes Nonfresh d) ->+              aliasLeaf (AliasBound (v, p)) t+          | otherwise -> t+        Just d | parametric d -> t+        _ -> aliasLeaf (AliasBound (v, p)) t++    maybeGlobal t@(Array Nonfresh _ _) = not $ parametric t+    maybeGlobal t@(Scalar (TypeVar Nonfresh _ _)) = not $ parametric t+    maybeGlobal _ = False++-- | Instantiate the aliases of a local binding at the type of an occurrence,+-- just as the type of a global is instantiated. The binding's type is that of+-- its definition, which for a local function may be polymorphic: where it has a+-- type parameter, every part of what the occurrence instantiates it with gets+-- the aliases, or in a return type the freshness, of that type parameter.+instantiateAliases :: TypeBase Size u -> TypeAliases -> TypeAliases+instantiateAliases+  (Scalar (Arrow _ _ _ t_p (RetType _ t_r)))+  (Scalar (Arrow als pn d _ (RetType ext r))) =+    Scalar $ Arrow als pn d t_p $ RetType ext $ instantiateFreshness t_r r+instantiateAliases (Scalar (Record ts)) (Scalar (Record als)) =+  Scalar $ Record $ M.intersectionWith instantiateAliases ts als+instantiateAliases (Scalar (Sum ts)) (Scalar (Sum als)) =+  Scalar $ Sum $ M.intersectionWith (zipWith instantiateAliases) ts als+instantiateAliases t als = t `setAliases` aliases als++-- | Like 'instantiateAliases', but for the freshness of a return type.+instantiateFreshness :: TypeBase Size u -> ResType -> ResType+instantiateFreshness+  (Scalar (Arrow _ _ _ t_p (RetType _ t_r)))+  (Scalar (Arrow u pn d _ (RetType ext r))) =+    Scalar $ Arrow u pn d t_p $ RetType ext $ instantiateFreshness t_r r+instantiateFreshness (Scalar (Record ts)) (Scalar (Record rs)) =+  Scalar $ Record $ M.intersectionWith instantiateFreshness ts rs+instantiateFreshness (Scalar (Sum ts)) (Scalar (Sum rs)) =+  Scalar $ Sum $ M.intersectionWith (zipWith instantiateFreshness) ts rs+instantiateFreshness t r = t `setMode` freshness r++-- | Update the aliases at a given position. It is expected that the second+-- 'TypeAliases' has the same type (modulo alias information) as the field at+-- the given path.+updateAliases :: TypeAliases -> [UpdateStep Info VName] -> TypeAliases -> TypeAliases+updateAliases _ [] ve_als =+  ve_als+updateAliases (Scalar (Record fs)) (UpdateStepField f : rest) ve_als+  | Just sub <- M.lookup f fs =+      Scalar $ Record $ M.insert f (updateAliases sub rest ve_als) fs+updateAliases src_als (UpdateStepSlice _ : _) _ = second (const mempty) src_als+updateAliases src_als _ _ = error $ "updateAliases: no such field in " <> prettyString src_als++data Entry a+  = Consumable {entryAliases :: a}+  | Nonconsumable {entryAliases :: a}+  deriving (Eq, Ord, Show)++instance Functor Entry where+  fmap f (Consumable als) = Consumable $ f als+  fmap f (Nonconsumable als) = Nonconsumable $ f als++data CheckEnv = CheckEnv+  { envVtable :: M.Map VName (Entry TypeAliases),+    -- | Location of the definition we are checking.+    envLoc :: Loc,+    -- | The declared type of a global, along with the type parameters it is+    -- polymorphic in.  This is what lets us exploit parametricity; see Note+    -- [Parametric results].+    envGlobal :: QualName VName -> Maybe BoundV+  }++-- | A description of where an artificial compiler-generated+-- intermediate name came from.+data NameReason+  = -- | Name is the result of a function application.+    NameAppRes (Maybe (QualName VName)) SrcLoc+  | -- | Name is a loop result.+    NameLoopRes SrcLoc+  | -- | Name ties together the components of the result of the given kind+    -- of branching expression; see Note [Locations].+    NameBranchRes T.Text SrcLoc++nameReason :: SrcLoc -> NameReason -> Doc a+nameReason loc (NameAppRes Nothing apploc) =+  "result of application at" <+> pretty (locStrRel loc apploc)+nameReason loc (NameAppRes fname apploc) =+  "result of applying"+    <+> dquotes (pretty fname)+    <+> parens ("at" <+> pretty (locStrRel loc apploc))+nameReason loc (NameLoopRes apploc) =+  "result of loop at" <+> pretty (locStrRel loc apploc)+nameReason loc (NameBranchRes what eloc) =+  "result of" <+> pretty what <+> "at" <+> pretty (locStrRel loc eloc)++-- | The locations consumed so far, each with where it was consumed.+type Consumed = M.Map Location Loc++data CheckState = CheckState+  { stateConsumed :: Consumed,+    stateErrors :: DL.DList TypeError,+    stateNames :: M.Map VName NameReason,+    stateCounter :: Int+  }++newtype CheckM a = CheckM (ReaderT CheckEnv (State CheckState) a)+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadReader CheckEnv,+      MonadState CheckState+    )++runCheckM ::+  (QualName VName -> Maybe BoundV) ->+  Loc ->+  CheckM a ->+  (a, [TypeError])+runCheckM globals loc (CheckM m) =+  let (a, s) = runState (runReaderT m env) initial_state+   in (a, DL.toList (stateErrors s))+  where+    env =+      CheckEnv+        { envVtable = mempty,+          envLoc = loc,+          envGlobal = globals+        }+    initial_state =+      CheckState+        { stateConsumed = mempty,+          stateErrors = mempty,+          stateNames = mempty,+          stateCounter = 0+        }++incCounter :: CheckM Int+incCounter =+  state $ \s -> (stateCounter s, s {stateCounter = stateCounter s + 1})++-- | The part of a path that steps only into records.+recordPath :: Path -> TypeBase dim o -> Path+recordPath (f : fs) (Scalar (Record ts))+  | Just t <- M.lookup f ts = f : recordPath fs t+recordPath _ _ = []++-- | Describe a location for the user.  A path into a sum payload is not+-- something the user can write, so the path is cut off at the first sum.+describeLoc :: Location -> CheckM (Doc a)+describeLoc (v, fs) = do+  loc <- asks envLoc+  fs' <- asks $ maybe fs (recordPath fs . entryAliases) . M.lookup v . envVtable+  gets $+    maybe ("variable" <+> dquotes (prettyAlias v fs')) (nameReason (srclocOf loc))+      . M.lookup v+      . stateNames++-- | Describe a variable for the user.+describeVar :: VName -> CheckM (Doc a)+describeVar v = describeLoc (v, [])++-- | Like 'describeVar', but naming a variable written by the programmer without+-- calling it one.+describeName :: VName -> CheckM (Doc a)+describeName v = do+  loc <- asks envLoc+  gets $+    maybe (dquotes (prettyName v)) (nameReason (srclocOf loc))+      . M.lookup v+      . stateNames++-- | Mark everything as nonconsumable within this action.+noConsumable :: CheckM a -> CheckM a+noConsumable = local $ \env -> env {envVtable = M.map f $ envVtable env}+  where+    f = Nonconsumable . entryAliases++addError :: (Located loc) => loc -> Notes -> Doc () -> CheckM ()+addError loc notes e = modify $ \s ->+  s {stateErrors = DL.snoc (stateErrors s) (TypeError (locOf loc) notes e)}++returnAliased :: Name -> SrcLoc -> CheckM ()+returnAliased name loc =+  addError loc mempty . withIndexLink "return-aliased" $+    "Fresh-declared return value is aliased to"+      <+> dquotes (prettyName name)+      <> ", which is not consumable."++-- | Returning a value for a fresh return type is equivalent to consuming it,+-- so a value with internal aliasing cannot be returned that way.+selfAliasedReturn :: (Located loc) => loc -> CheckM ()+selfAliasedReturn loc =+  addError loc mempty $+    "A fresh-declared component of the return value may have internal aliases,"+      </> "and so cannot be declared fresh."++freshReturnAliased :: SrcLoc -> CheckM ()+freshReturnAliased loc =+  addError loc mempty . withIndexLink "fresh-return-aliased" $+    "A fresh-declared component of the return value is aliased to some other component."++-- | A reason why a component of a function result cannot be fresh.+data Unfresh+  = -- | It aliases this variable, which is in scope and not a consumed+    -- parameter.+    UnfreshAliases VName+  | -- | It aliases a location that some other component also aliases.+    UnfreshShared+  | -- | It may have internal aliasing.+    UnfreshSelf++-- | Why a component of the result of a function with these parameters cannot be+-- fresh, given the 'sharedLocations' of the whole result. The component may be+-- fresh exactly when there is no reason. See Note [Locations].+unfreshness :: [Pat ParamType] -> S.Set Location -> TypeAliases -> [Unfresh]+unfreshness params shared t_als =+  [UnfreshShared | any (`S.member` shared) (aliasLocs (aliases t_als))]+    <> [UnfreshSelf | selfAliased (aliases t_als)]+    <> map (UnfreshAliases . fst) (filter (not . consumedParamLoc params) in_scope)+  where+    -- Mention the parameters before other variables.+    in_scope =+      L.sortOn ((`notElem` foldMap patNames params) . fst) . nubOrd . aliasLocs $+        S.filter isBoundAlias $+          aliases t_als++-- | Check that every component of a function result declared fresh may be.+checkReturnAlias :: SrcLoc -> [Pat ParamType] -> ResType -> TypeAliases -> CheckM ()+checkReturnAlias loc params rettp ret_als =+  forM_ (returnAliases rettp ret_als) $ \(u, t_als) ->+    when (u == Fresh) . mapM_ report $ unfreshness params shared t_als+  where+    shared = sharedLocations ret_als++    report (UnfreshAliases v) = returnAliased (baseName v) loc+    report UnfreshShared = freshReturnAliased loc+    report UnfreshSelf = selfAliasedReturn loc++    returnAliases (Scalar (Record ets1)) (Scalar (Record ets2)) =+      concat $ M.elems $ M.intersectionWith returnAliases ets1 ets2+    returnAliases expected got =+      [(freshness expected, got)]++unscope :: [VName] -> Aliases -> Aliases+unscope bound = S.map f+  where+    f (AliasBound (v, fs)) =+      if v `elem` bound+        then AliasFree (v, fs)+        else AliasBound (v, fs)+    f a = a++-- | Figure out the aliases of each bound name in a pattern.+matchPat :: Pat t -> TypeAliases -> DL.DList (VName, (t, TypeAliases))+matchPat (PatParens p _) t = matchPat p t+matchPat (TuplePat ps _) t+  | Just ts <- isTupleRecord t = mconcat $ zipWith matchPat ps ts+matchPat (RecordPat fs1 _) (Scalar (Record fs2)) =+  mconcat $+    zipWith+      matchPat+      (map snd (sortFields (M.fromList (map (first unLoc) fs1))))+      (map snd (sortFields fs2))+matchPat (Id v (Info t) _) als = DL.singleton (v, (t, als))+matchPat (PatAscription p _ _) t = matchPat p t+matchPat (PatConstr v _ ps _) (Scalar (Sum cs))+  | Just ts <- M.lookup v cs = mconcat $ zipWith matchPat ps ts+matchPat Wildcard {} _ = mempty+matchPat PatLit {} _ = mempty+matchPat (PatAttr _ p _) t = matchPat p t+matchPat _ t = error $ "matchPat: pattern does not match " <> prettyString t++bindingPat ::+  Pat StructType ->+  TypeAliases ->+  CheckM (a, TypeAliases) ->+  CheckM (a, TypeAliases)+bindingPat p t m = do+  void . noConsumable $ traversePat pure (fmap fst . checkExp) p+  second (second (unscope (patNames p))) <$> local bind m+  where+    bind env =+      env+        { envVtable =+            foldr (uncurry M.insert . f) (envVtable env) (matchPat p t)+        }+      where+        f (v, (_, als)) = (v, Consumable $ insertSelfAliases v als)++bindingParam :: Pat ParamType -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)+bindingParam = bindingParamAliasing mempty++-- | Check the size expressions in a type.  A size expression may be evaluated+-- before the expression or binding it appears in, so it may consume nothing.+checkSizes :: (Bifoldable t) => t Exp a -> CheckM ()+checkSizes = noConsumable . bitraverse_ checkExp pure++-- | Like 'bindingParam', but every component of the parameter also aliases the+-- given aliases.+bindingParamAliasing :: Aliases -> Pat ParamType -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)+bindingParamAliasing als p m = do+  mapM_ checkSizes p+  second (second (unscope (patNames p))) <$> local bind m+  where+    bind env =+      env+        { envVtable =+            foldr (uncurry M.insert . f) (envVtable env) (patternMap p)+        }+    f (v, t)+      | diet t == Consume = (v, Consumable t_als)+      | otherwise = (v, Nonconsumable t_als)+      where+        t_als = second (<> als) $ selfAliasType v t++bindingIdent :: Diet -> Ident StructType -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)+bindingIdent d (Ident v (Info t) _) =+  fmap (second (second (unscope [v]))) . local bind+  where+    bind env = env {envVtable = M.insert v t' (envVtable env)}+    d' = case d of+      Consume -> Consumable+      Observe -> Nonconsumable+    t' = d' $ selfAliasType v t++bindingParams :: [Pat ParamType] -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)+bindingParams params m =+  noConsumable $+    second (second (unscope (foldMap patNames params)))+      <$> foldr bindingParam m params++-- | Bind the names of a loop form, given the aliases of the array a for-in loop+-- iterates over.  An element of that array aliases it, as indexing does.+bindingLoopForm :: Aliases -> LoopFormBase Info VName -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)+bindingLoopForm _ (For ident _) m = bindingIdent Observe ident m+bindingLoopForm arr_als (ForIn pat _) m = bindingParamAliasing arr_als pat' m+  where+    pat' = fmap (second (const Observe)) pat+bindingLoopForm _ While {} m = m++bindingFun :: VName -> TypeAliases -> CheckM a -> CheckM a+bindingFun v t = local $ \env ->+  env {envVtable = M.insert v (Nonconsumable t) (envVtable env)}++-- | Is this location dead because of something in the consumed set?  That is+-- the case if a location on the same variable has been consumed whose path is+-- a prefix of this one, or of which this one is a prefix.  The result is where+-- the killing consumption happened.+deadIn :: Consumed -> Location -> Maybe Loc+deadIn cons (v, p) = listToMaybe $ mapMaybe killing $ M.toList on_v+  where+    on_v = M.takeWhileAntitone ((== v) . fst) $ M.dropWhileAntitone ((< v) . fst) cons+    killing ((_, q), loc)+      | q `L.isPrefixOf` p || p `L.isPrefixOf` q = Just loc+      | otherwise = Nothing++checkIfConsumed :: Loc -> Aliases -> CheckM ()+checkIfConsumed rloc als = do+  cons <- gets stateConsumed+  names <- gets stateNames+  let bad l = (l,) <$> deadIn cons l+      -- Mention the variables the programmer wrote before internal names.+      internal = (`M.member` names) . fst . fst+  forM_ (L.sortOn internal $ mapMaybe bad $ aliasLocs als) $ \(l, wloc) -> do+    v' <- describeLoc l+    addError rloc mempty . withIndexLink "use-after-consume" $+      "Using"+        <+> v'+        <> ", but this was consumed at"+          <+> pretty (locStrRel rloc wloc)+        <> ".  (Possibly through aliases.)"++consumed :: Consumed -> CheckM ()+consumed vs = modify $ \s -> s {stateConsumed = stateConsumed s <> vs}++consumeAliases :: Loc -> Aliases -> CheckM ()+consumeAliases loc als = do+  vtable <- asks envVtable+  let isBad v =+        case v `M.lookup` vtable of+          Just (Nonconsumable {}) -> True+          Just _ -> False+          Nothing -> True+      checkIfConsumable AliasFree {} = pure ()+      checkIfConsumable AliasSelf =+        addError+          loc+          mempty+          "Consuming a value that may have internal aliases."+      checkIfConsumable a+        | Just v <- aliasVar a,+          isBad v = do+            v' <- describeName v+            addError loc mempty . withIndexLink "not-consumable" $+              "Consuming" <+> v' <> ", which is not consumable."+      checkIfConsumable _ = pure ()+      -- Mention local variables before globals.+      global = maybe False (`M.notMember` vtable) . aliasVar+  mapM_ checkIfConsumable $ L.sortOn global $ S.toList als+  checkIfConsumed loc als+  consumed als'+  where+    als' = M.fromList $ map (,loc) $ aliasLocs als++-- | Add 'AliasSelf' to every function component of a type, recording that+-- applying it may yield a value with internal aliasing.  See Note [Parametric+-- results].+addSelfAliases :: TypeAliases -> TypeAliases+addSelfAliases (Scalar (Arrow als mn d pt rt)) =+  Scalar $ Arrow (S.insert AliasSelf als) mn d pt rt+addSelfAliases (Scalar (Record fs)) = Scalar $ Record $ fmap addSelfAliases fs+addSelfAliases (Scalar (Sum cs)) = Scalar $ Sum $ (fmap . fmap) addSelfAliases cs+addSelfAliases t = t++-- | Can a function with this type scheme produce, when its function components+-- are applied, a value whose internal aliasing we cannot see? That is so+-- exactly when some component of what it produces is a nonfresh abstract type+-- that is not one of the type parameters it is polymorphic in: it must then+-- have manufactured that value, rather than been handed it. Intrinsic types+-- (notably accumulators) are exempt, as the compiler does know their+-- representation, and they have no components that could alias each other. See+-- Note [Parametric results].+manufacturesAbstract :: BoundV -> Bool+manufacturesAbstract (BoundV tparams vt) = anyResultComponent manufactured . toRes Nonfresh $ vt+  where+    tparams' = [v | TypeParamType _ v _ <- tparams]+    manufactured (Scalar (TypeVar u t _)) =+      u == Nonfresh+        && not (isIntrinsic (qualLeaf t))+        && qualLeaf t `notElem` tparams'+    manufactured _ = False++-- | Add 'AliasSelf' to the function components of a value, recording that+-- applying them may produce a value with internal aliasing, when the given+-- declared type says they may.  See Note [Parametric results].+maybeAddSelfAliases :: BoundV -> TypeAliases -> TypeAliases+maybeAddSelfAliases tscheme+  | manufacturesAbstract tscheme = addSelfAliases+  | otherwise = id++-- | Observe the given name here and return its aliases.+observeVar :: Loc -> QualName VName -> StructType -> CheckM TypeAliases+observeVar loc qv t = do+  als <-+    asks $ \env ->+      maybe (isGlobal env) (instantiateAliases t . entryAliases) $+        M.lookup v (envVtable env)+  checkIfConsumed loc (aliases als)+  pure als+  where+    v = qualLeaf qv++    -- The declared type of a global is what makes parametricity visible; if we+    -- cannot find it, fall back to the instantiated type, which amounts to+    -- assuming no parametricity at all. An intrinsic aliases nothing. See Note+    -- [Parametric results].+    isGlobal env+      | isIntrinsic v = second (const mempty) t+      | otherwise =+          let tscheme = fromMaybe (BoundV [] t) $ envGlobal env qv+           in maybeAddSelfAliases tscheme $ globalAliases v tscheme t++-- Capture any newly consumed locations that occur during the provided action.+contain :: CheckM a -> CheckM (a, Consumed)+contain m = do+  prev_cons <- gets stateConsumed+  x <- m+  new_cons <- gets $ (`M.difference` prev_cons) . stateConsumed+  modify $ \s -> s {stateConsumed = prev_cons}+  pure (x, new_cons)++-- | The two types are assumed to be approximately structurally equal,+-- but not necessarily regarding sizes.  Combines aliases and prefers+-- other information from first argument.+combineAliases :: TypeAliases -> TypeAliases -> TypeAliases+combineAliases (Array als1 et1 shape1) t2 =+  Array (als1 <> aliases t2) et1 shape1+combineAliases (Scalar (TypeVar als1 tv1 targs1)) t2 =+  Scalar $ TypeVar (als1 <> aliases t2) tv1 targs1+combineAliases (Scalar (Record ts1)) (Scalar (Record ts2)) =+  Scalar $ Record $ M.intersectionWith combineAliases ts1 ts2+combineAliases+  (Scalar (Arrow als1 mn1 d1 pt1 (RetType dims1 rt1)))+  (Scalar (Arrow als2 _ _ _ (RetType _ _))) =+    Scalar (Arrow (als1 <> als2) mn1 d1 pt1 (RetType dims1 rt1))+combineAliases (Scalar (Sum cs1)) (Scalar (Sum cs2)) =+  Scalar $ Sum $ M.intersectionWith (zipWith combineAliases) cs1 cs2+combineAliases (Scalar (Prim t)) _ = Scalar $ Prim t+combineAliases t1 t2 =+  error $ "combineAliases invalid args: " ++ show (t1, t2)++-- | The locations that occur in more than one component of a value.  A+-- component aliasing any of them cannot be fresh.+sharedLocations :: TypeAliases -> S.Set Location+sharedLocations =+  M.keysSet+    . M.filter (> 1)+    . M.fromListWith (+)+    . concatMap (map (,1 :: Int) . S.toList . S.fromList . aliasLocs)+    . aliasParts++-- | Is this location entirely within a part of a parameter that is consumed?+consumedParamLoc :: [Pat ParamType] -> Location -> Bool+consumedParamLoc params (v, fs) =+  case maybe [] (filter ((fs `L.isPrefixOf`) . fst) . leaves) $+    lookup v (foldMap patternMap params) of+    [] -> False+    within -> all (consumable . snd) within+  where+    consumable (Array d _ _) = d == Consume+    consumable (Scalar (TypeVar d _ _)) = d == Consume+    consumable (Scalar Arrow {}) = False+    consumable _ = True++-- | Free variables and their aliases.+boundFreeInExp :: Exp -> CheckM (M.Map VName TypeAliases)+boundFreeInExp e = do+  vtable <- asks envVtable+  pure $+    M.mapMaybe (fmap entryAliases) . M.fromSet (`M.lookup` vtable) $+      fvVars (freeInExp e)++-- | The aliases of the free local variables captured by a closure with the given+-- parameters and body, plus any globals that its result aliases, which it may+-- return.+closureAliases :: [Pat ParamType] -> Exp -> TypeAliases -> CheckM Aliases+closureAliases params body body_als = do+  vtable <- asks envVtable+  free_bound <-+    (`M.withoutKeys` S.fromList (foldMap patNames params)) <$> boundFreeInExp body+  -- The closure may return aliases to globals, and if the body may have+  -- internal aliasing ('AliasSelf'), so may the result of applying the closure.+  let isGlobal AliasFree {} = False+      isGlobal AliasSelf = True+      isGlobal a = maybe False (`M.notMember` vtable) $ aliasVar a+  pure $+    foldMap aliases (M.elems free_bound)+      <> S.filter isGlobal (aliases body_als)++-- | An in-place update through record fields consumes the component at the+-- end of that path, but its result keeps the other components, which must+-- therefore not share memory with it.+checkUpdatePath :: Loc -> [UpdateStep Info VName] -> TypeAliases -> CheckM ()+checkUpdatePath loc steps src_als =+  when (foldMap (aliases . snd) inside `overlaps` foldMap (aliases . snd) outside) $+    addError loc mempty $+      "In-place update of a component that shares memory with"+        </> "other components of the same value."+  where+    (inside, outside) = L.partition ((fieldPath steps `L.isPrefixOf`) . fst) $ leaves src_als+    fieldPath (UpdateStepField f : steps') = f : fieldPath steps'+    fieldPath _ = []++overlapCheck :: (Pretty src, Pretty ve) => Loc -> (src, TypeAliases) -> (ve, TypeAliases) -> CheckM ()+overlapCheck loc (src, src_als) (ve, ve_als) =+  when (aliases src_als `overlaps` aliases ve_als) $+    addError loc mempty $+      "Source array for in-place update"+        </> indent 2 (pretty src)+        </> "might alias update value"+        </> indent 2 (pretty ve)+        </> "Hint: use"+        <+> dquotes "copy"+        <+> "to remove aliases from the value."++inferReturnFreshness :: [Pat ParamType] -> ResType -> TypeAliases -> ResType+inferReturnFreshness [] ret _ = ret `setMode` Nonfresh+inferReturnFreshness params ret ret_als = delve ret ret_als+  where+    shared = sharedLocations ret_als+    delve (Scalar (Record fs1)) (Scalar (Record fs2)) =+      Scalar $ Record $ M.intersectionWith delve fs1 fs2+    delve (Scalar (Sum cs1)) (Scalar (Sum cs2)) =+      Scalar $ Sum $ M.intersectionWith (zipWith delve) cs1 cs2+    delve t t_als =+      t `setMode` if null (unfreshness params shared t_als) then Fresh else Nonfresh++checkSubExps :: (ASTMappable e) => e -> CheckM e+checkSubExps = astMap identityMapper {mapOnExp = fmap fst . checkExp}++noAliases :: Exp -> CheckM (Exp, TypeAliases)+noAliases e = do+  e' <- checkSubExps e+  pure (e', unknownAliases (typeOf e))++-- | The aliases of each leaf of a value.+aliasParts :: TypeAliases -> [Aliases]+aliasParts = map (aliases . snd) . leaves++-- | Are the components of this value pairwise disjoint?+separated :: TypeAliases -> Bool+separated = S.null . sharedLocations++-- | The leaf at the given path, if there is one.+componentAt :: Path -> TypeBase dim o -> Maybe (TypeBase dim o)+componentAt fs = lookup fs . leaves++-- | The locations in the alias set of a location: those of the leaf at that+-- path of the variable's entry in the vtable.  Empty for a location that is+-- not a leaf of a variable in scope.+aliasOf :: M.Map VName (Entry TypeAliases) -> Location -> [Location]+aliasOf vtable (v, fs) =+  maybe [] (aliasLocs . aliases) $ componentAt fs . entryAliases =<< M.lookup v vtable++-- | The aliases of the components of a value passed for a parameter of this+-- type that the parameter treats with the given diet.+aliasesWithDiet :: Diet -> ParamType -> TypeAliases -> Aliases+aliasesWithDiet d p_t t_als =+  foldMap (aliases . snd . snd) . filter ((== d) . diet . snd . fst) $+    zip (leaves p_t) (leaves t_als)++-- | Check an expression passed as an argument.  This does not pass it; see+-- 'passArgs'.+checkArg :: Exp -> CheckM (Exp, TypeAliases)+checkArg e = do+  ((e', e_als), e_cons) <- contain $ checkExp e+  consumed e_cons+  let e_t = typeOf e'+  when (e_cons /= mempty && not (orderZero e_t)) $+    addError (locOf e) mempty . withIndexLink "consuming-argument" $+      "Argument of functional type"+        </> indent 2 (pretty e_t)+        </> "contains consumption, which is not allowed."+  pure (e', e_als)++-- | An alias of a new internal name standing for an intermediate value, with+-- the reason it exists recorded for error messages.+internalAlias :: Name -> NameReason -> CheckM Alias+internalAlias desc reason = do+  v <- VName desc <$> incCounter+  modify $ \s -> s {stateNames = M.insert v reason $ stateNames s}+  pure $ AliasFree (v, [])++-- | Signal an error if a component of an argument that a parameter of this type+-- consumes shares a location with another component of the argument.+noSelfAliases :: Loc -> ParamType -> TypeAliases -> CheckM ()+noSelfAliases loc p_t t =+  when (any (`S.member` sharedLocations t) $ aliasLocs $ aliasesWithDiet Consume p_t t) $+    addError loc mempty . withIndexLink "self-aliasing-arg" $+      "Argument passed for consuming parameter is self-aliased."++-- | Pass checked arguments, each with the type of its parameter, to a function+-- with the given aliases.  The call uses the function and every argument, and+-- then consumes what the parameters consume.  See Note [Locations].+passArgs :: Loc -> Aliases -> [(ParamType, (Exp, TypeAliases))] -> CheckM ()+passArgs loc f_als args = do+  checkIfConsumed loc $ f_als <> foldMap (aliases . snd . snd) args+  forM_ (zip [0 :: Int ..] args) $ \(i, (p_t, (e, e_als))) ->+    when (diet p_t == Consume) $ do+      noSelfAliases (locOf e) p_t e_als+      let cons_als = aliasesWithDiet Consume p_t e_als+          others = map (snd . snd) . filter ((/= i) . fst) $ zip [0 ..] args+      when (cons_als `overlaps` f_als) . addError (locOf e) mempty $+        "Argument is consumed, but aliases the function being applied."+      case find ((cons_als `overlaps`) . aliases . snd) others of+        Nothing -> pure ()+        Just (other, other_als) -> do+          shared <- describeShared $ aliasLocs $ cons_als `S.intersection` aliases other_als+          addError (locOf e) mempty $+            "Argument is consumed, but aliases"+              </> indent 2 shared+              </> "which is also aliased by other argument"+              </> indent 2 (pretty other)+              </> "at"+              <+> pretty (locTextRel (locOf e) (locOf other))+              <> "."+      -- Passing an argument for a consuming parameter is consumption even+      -- when the argument aliases nothing, as what the call returns may hold+      -- it (see 'checkBound').  A fresh name records that.+      passed <- internalAlias "internal_consumed_arg" $ NameAppRes Nothing $ srclocOf e+      consumeAliases (locOf e) $ S.insert passed cons_als+  where+    -- Name a variable the programmer wrote if there is one.+    describeShared locs = do+      names <- gets stateNames+      case L.partition ((`M.notMember` names) . fst) locs of+        ((v, fs) : _, _) -> pure $ prettyAlias v fs+        ([], l : _) -> describeLoc l+        ([], []) -> pure mempty++selfAliasType :: VName -> TypeBase Size o -> TypeAliases+selfAliasType v = insertSelfAliases v . unknownAliases++-- | The aliases to assume for a value whose provenance we know nothing about:+-- none at all, except what its own type says it may manufacture. This is+-- 'maybeAddSelfAliases' with no type parameters to exploit. See Note+-- [Parametric results].+unknownAliases :: TypeBase Size o -> TypeAliases+unknownAliases t = maybeAddSelfAliases (BoundV [] $ toStruct t) $ second (const mempty) t++-- | @returnType appres ret_type arg_diet arg_type@ gives result of applying+-- an argument the given types to a function with the given return+-- type, consuming the argument with the given diet.+returnType :: Aliases -> ResType -> Diet -> TypeAliases -> TypeAliases+returnType _ (Array Fresh et shape) _ _ =+  Array mempty et shape+returnType appres (Array Nonfresh et shape) Consume _ =+  Array appres et shape+returnType appres (Array Nonfresh et shape) Observe arg =+  Array (appres <> aliases arg) et shape+returnType _ (Scalar (TypeVar Fresh t targs)) _ _ =+  Scalar $ TypeVar mempty t targs+returnType appres (Scalar (TypeVar Nonfresh t targs)) Consume _ =+  Scalar $ TypeVar appres t targs+returnType appres (Scalar (TypeVar Nonfresh t targs)) Observe arg =+  Scalar $ TypeVar (appres <> aliases arg) t targs+returnType appres (Scalar (Record fs)) d arg =+  Scalar $ Record $ fmap (\et -> returnType appres et d arg) fs+returnType _ (Scalar (Prim t)) _ _ =+  Scalar $ Prim t+returnType appres (Scalar (Arrow _ v pd t1 (RetType dims t2))) Consume _ =+  Scalar $ Arrow appres v pd t1 $ RetType dims t2+returnType appres (Scalar (Arrow _ v pd t1 (RetType dims t2))) Observe arg =+  Scalar $ Arrow (appres <> aliases arg) v pd t1 $ RetType dims t2+returnType appres (Scalar (Sum cs)) d arg =+  Scalar $ Sum $ (fmap . fmap) (\et -> returnType appres et d arg) cs++-- | Check the argument that an operator section supplies for a parameter of the+-- given type.  The section is a function that captures the argument, so, just as+-- a lambda cannot consume what it captures, the parameter cannot be consuming.+checkSectionArg :: TypeAliases -> ParamType -> Exp -> CheckM (Exp, TypeAliases)+checkSectionArg op_als p_t e = do+  when (diet p_t == Consume) $+    addError (locOf e) mempty $+      textwrap "Operator sections may not supply an argument for a consuming parameter."+  (e', e_als) <- checkExp e+  checkIfConsumed (locOf e) $ aliases op_als+  pure (e', e_als)++applyArg :: TypeAliases -> TypeAliases -> TypeAliases+applyArg (Scalar (Arrow closure_als _ d _ (RetType _ rettype))) arg_als =+  returnType closure_als rettype d arg_als+applyArg _ arg_als = arg_als++applyLoopArg :: Aliases -> ParamType -> TypeAliases -> ResType -> TypeAliases+applyLoopArg appres (Scalar (Record pfs)) (Scalar (Record afs)) (Scalar (Record rfs)) =+  Scalar . Record $+    M.mapWithKey+      (\k p_t -> applyLoopArg appres p_t (afs M.! k) (rfs M.! k))+      pfs+applyLoopArg appres p_t arg_als rettype =+  returnType appres rettype (diet p_t) arg_als++-- Loops are tricky because we want to infer the diets of their parameters.+-- This is pretty unusual: we do not do this for ordinary functions.+type Loop = (Pat ParamType, LoopInitBase Info VName, LoopFormBase Info VName, Exp)++-- | Mark bindings of consumed names as Consume, except those under a+-- 'PatAscription', which are left unchanged.+updateParamDiet :: (VName -> Bool) -> Pat ParamType -> Pat ParamType+updateParamDiet cons = recurse+  where+    recurse (Wildcard (Info t) wloc) =+      Wildcard (Info $ t `setMode` Observe) wloc+    recurse (PatParens p ploc) =+      PatParens (recurse p) ploc+    recurse (PatAttr attr p ploc) =+      PatAttr attr (recurse p) ploc+    recurse (Id name (Info t) iloc) =+      Id name (Info $ t `setMode` m) iloc+      where+        m = if cons name then Consume else Observe+    recurse (TuplePat pats ploc) =+      TuplePat (map recurse pats) ploc+    recurse (RecordPat fs ploc) =+      RecordPat (map (fmap recurse) fs) ploc+    recurse (PatAscription p t ploc) =+      PatAscription p t ploc+    recurse p@PatLit {} = p+    recurse (PatConstr n t ps ploc) =+      PatConstr n t (map recurse ps) ploc++-- | Check the values a loop body returns for its consumed parameters, as the+-- arguments of a call that consumes them: each must be fresh, as the result of+-- a function with the loop parameters as its parameters would have to be.+checkLoopResult :: Loc -> Pat ParamType -> TypeAliases -> CheckM ()+checkLoopResult loop_loc param body_als =+  forM_ (matchPat param body_als) $ \(v, (t, als)) ->+    when (diet t == Consume) . mapM_ (report v) $ unfreshness [param] shared als+  where+    shared = sharedLocations body_als+    what v = "Return value for consuming loop parameter" <+> dquotes (prettyName v)+    report v (UnfreshAliases w) =+      addError loop_loc mempty . withIndexLink "consuming-loop-param-aliases" $+        what v <+> "aliases" <+> dquotes (prettyName w) <> "."+    report v UnfreshShared =+      addError loop_loc mempty . withIndexLink "aliases-previously-returned" $+        what v <+> "aliases another returned value."+    report v UnfreshSelf =+      addError loop_loc mempty $+        what v <+> "may have internal aliases."++-- | Infer which loop parameters are consumed, and check what the body returns+-- for them.  A parameter is consumed if the body consumes it, or if the value+-- returned for a consumed parameter aliases it, as that value is consumed in+-- the next iteration.  See Note [Locations].+convergeLoopParam :: Loc -> Pat ParamType -> S.Set VName -> TypeAliases -> CheckM (Pat ParamType)+convergeLoopParam loop_loc param body_cons body_als+  | body_cons' /= body_cons = convergeLoopParam loop_loc param body_cons' body_als+  | otherwise = do+      checkLoopResult loop_loc param' body_als+      pure param'+  where+    param' = updateParamDiet (`S.member` body_cons) param+    returned = toList $ matchPat param' body_als+    cons_als = foldMap (aliases . snd . snd) $ filter ((== Consume) . diet . fst . snd) returned+    body_cons' = body_cons <> S.filter (`elem` patNames param) (aliasVars cons_als)++-- | Check the form of a loop with the given parameter, returning the array a+-- for-in loop iterates over.+checkLoopForm ::+  Pat ParamType ->+  LoopFormBase Info VName ->+  CheckM (LoopFormBase Info VName, Maybe (Exp, TypeAliases))+checkLoopForm _ (ForIn pat e) = do+  (e', e_als) <- checkExp e+  pure (ForIn pat e', Just (e', e_als))+checkLoopForm param (While cond) = do+  -- A condition is evaluated repeatedly and may not consume anything.+  ((cond', _), _) <-+    contain . noConsumable . bindingParam (fmap (second (const Observe)) param) $+      checkExp cond+  pure (While cond', Nothing)+checkLoopForm _ form = (,Nothing) <$> checkSubExps form++-- | A loop evaluates its initial value and then its form, and then passes the+-- initial value to the first iteration, as if calling a function that also+-- observes the array a for-in loop iterates over.  See Note [Locations].+checkLoop :: Loc -> Loop -> CheckM (Loop, TypeAliases)+checkLoop loop_loc (param, arg, form, body) = do+  ((arg', (arg_e, arg_als)), init_cons) <- contain $ case arg of+    LoopInitImplicit (Info e) -> do+      (e', e_als) <- checkArg e+      pure (LoopInitImplicit (Info e'), (e', e_als))+    LoopInitExplicit e -> do+      (e', e_als) <- checkArg e+      pure (LoopInitExplicit e', (e', e_als))+  consumed init_cons+  (form', iterated) <- checkLoopForm param form+  let arr_als = foldMap (aliases . snd) iterated+  -- We pretend that every part of the loop parameter has a consuming diet, as+  -- we need to allow consumption in the body, which we then use to infer the+  -- proper diet of the parameter.+  ((body', body_cons), body_als) <-+    noConsumable+      . bindingParam (updateParamDiet (const True) param)+      . bindingLoopForm arr_als form'+      $ do+        ((body', body_als), body_cons) <- contain $ checkExp body+        pure ((body', body_cons), body_als)+  param' <- convergeLoopParam loop_loc param (S.map fst (M.keysSet body_cons)) body_als++  let param_t = patternType param'+      iteratedArg (e, e_als) = (toParam Observe (typeOf e), (e, e_als))+  (_, entry_cons) <-+    contain . passArgs loop_loc mempty $+      (param_t, (arg_e, arg_als)) : maybeToList (iteratedArg <$> iterated)+  consumed entry_cons+  let arg_cons = init_cons <> entry_cons++  let checkFree what e = do+        free_bound <- boundFreeInExp e++        let bad = any (isJust . deadIn arg_cons) . aliasLocs . aliases . snd+        forM_ (filter bad $ M.toList free_bound) $ \(v, _) -> do+          v' <- describeVar v+          addError loop_loc mempty $+            what+              <+> "uses"+              <+> v'+              <> " (or an alias),"+                </> "but this is consumed by the initial loop argument."++  checkFree "Loop body" body++  case form of+    While cond -> checkFree "Loop condition" cond+    _ -> pure ()++  loop_al <- internalAlias "internal_loop_result" $ NameLoopRes $ srclocOf loop_loc++  -- The value of an observed parameter may come from any observed part of the+  -- initial value, or of what the body returns, as the loop may move values+  -- between parameters from one iteration to the next.+  let loop_als =+        applyLoopArg+          ( S.insert loop_al $+              aliasesWithDiet Observe param_t arg_als+                <> aliasesWithDiet Observe param_t body_als+          )+          param_t+          arg_als+          (paramToRes param_t)+  pure+    ( (param', arg', form', body'),+      loop_als `combineAliases` body_als+    )++-- | The type parameters at the components of a result, if every component is+-- either primitive or a type parameter.+resultVars :: [VName] -> ResType -> Maybe [VName]+resultVars tps (Scalar (Record fs)) = concat <$> mapM (resultVars tps) (M.elems fs)+resultVars _ (Scalar Prim {}) = Just []+resultVars tps (Scalar (TypeVar _ v []))+  | qualLeaf v `elem` tps = Just [qualLeaf v]+resultVars _ _ = Nothing++-- | Does the type parameter occur at no negative position in the type, which+-- is itself at a positive position if the flag is set?  An occurrence in the+-- argument of an abstract type counts as negative, as we cannot see where it+-- ends up.+noNegative :: VName -> Bool -> TypeBase dim o -> Bool+noNegative a pos (Array _ _ et) = noNegative a pos (Scalar et)+noNegative _ _ (Scalar Prim {}) = True+noNegative a pos (Scalar (TypeVar _ v targs)) =+  (pos || qualLeaf v /= a) && all argOk targs+  where+    argOk (TypeArgType t) = not $ a `S.member` typeVars t+    argOk TypeArgDim {} = True+noNegative a pos (Scalar (Record fs)) = all (noNegative a pos) fs+noNegative a pos (Scalar (Sum cs)) = all (all (noNegative a pos)) cs+noNegative a pos (Scalar (Arrow _ _ _ pt (RetType _ rt))) =+  noNegative a (not pos) pt && noNegative a pos rt++-- | The sources of a type parameter among the parameters of a function, as+-- parameter positions and paths through records: the components that are+-- functions which observe their argument and return the type parameter.+-- 'Nothing' if the type parameter occurs at a negative position that is not a+-- source. See Note [Parametric results].+callSources :: VName -> [StructType] -> Maybe [(Int, Path)]+callSources a = fmap concat . zipWithM onParam [0 ..]+  where+    onParam i = fmap (map (i,)) . onComponent []++    onComponent p (Scalar (Record fs)) =+      concat <$> mapM (\(k, t) -> onComponent (p ++ [k]) t) (M.toList fs)+    onComponent p (Scalar (Arrow _ _ Observe pt (RetType _ (Scalar (TypeVar _ v [])))))+      | qualLeaf v == a = [p] <$ guard (noNegative a True pt)+    onComponent _ t = [] <$ guard (noNegative a False t)++-- | The sources of the type parameters in the result of a function with this+-- declared type, if parametricity says that the result can only be made of what+-- calls of them return. This is the case when every component of the result is+-- primitive or a type parameter, each type parameter occurs once, and each has+-- a source and no other negative occurrence. See Note [Parametric results].+resultSources :: [TypeParam] -> [StructType] -> ResType -> Maybe [(Int, Path)]+resultSources tparams params res = do+  vs <- resultVars [v | TypeParamType _ v _ <- tparams] res+  guard $ length (nubOrd vs) == length vs+  fmap concat . forM vs $ \v -> do+    srcs <- callSources v params+    guard $ not $ null srcs+    pure srcs++-- | Peel the parameters off a function type, returning their types (in order)+-- and the type of the final result. 'Nothing' for a non-function type. This is+-- 'unfoldFunType' except that it preserves the freshness of the result, which+-- is exactly what we are asking about here.+funParts :: TypeBase Size u -> Maybe ([StructType], ResType)+funParts (Scalar (Arrow _ _ _ pt (RetType _ t))) = Just $ go [pt] t+  where+    go ps (Scalar (Arrow _ _ _ pt' (RetType _ t'))) = go (pt' : ps) t'+    go ps t' = (reverse ps, t')+funParts _ = Nothing++-- | Does applying this function construct its result freshly?  That is so when+-- every part of its (curried) result is fresh or primitive.  Requiring the+-- result to be order zero keeps us from claiming that a closure over the other+-- arguments aliases nothing.+constructsFresh :: TypeBase Size u -> Bool+constructsFresh t+  | Just (_, rt) <- funParts t = orderZero rt && allFresh rt+  | otherwise = False+  where+    allFresh (Scalar (Record fs)) = all allFresh fs+    allFresh (Scalar (Sum cs)) = all (all allFresh) cs+    allFresh (Scalar Prim {}) = True+    allFresh (Scalar (TypeVar u _ _)) = u == Fresh+    allFresh (Array u _ _) = u == Fresh+    allFresh (Scalar Arrow {}) = False++-- | Mark as fresh the result of a function with this many parameters.+freshenResult :: Int -> TypeBase Size o -> TypeBase Size o+freshenResult n (Scalar (Arrow u pn d pt (RetType ext rt))) =+  Scalar . Arrow u pn d pt . RetType ext $+    if n == 1 then rt `setMode` Fresh else freshenResult (n - 1) rt+freshenResult _ t = t++-- | The type of a global applied to arguments of the given types, with what+-- parametricity tells us about the freshness of the result recorded in it. Only+-- an application that supplies every parameter of the type is refined. See Note+-- [Parametric results].+parametricFreshness ::+  QualName VName ->+  StructType ->+  [StructType] ->+  CheckM StructType+parametricFreshness qn ftype argtypes = do+  globals <- asks envGlobal+  pure $ fromMaybe ftype $ do+    BoundV tparams decl <- globals qn+    (param_ts, res) <- funParts decl+    guard $ length argtypes == length param_ts+    srcs <- resultSources tparams param_ts res+    guard $ all (maybe False constructsFresh . argAt) srcs+    Just $ freshenResult (length param_ts) ftype+  where+    argAt (i, p) = componentAt p $ argtypes !! i++-- | Apply a function with the given aliases to checked arguments, returning the+-- aliases of the result.+checkApply :: SrcLoc -> Maybe (QualName VName) -> TypeAliases -> [(Exp, TypeAliases)] -> CheckM TypeAliases+checkApply loc fname f_als args = do+  passArgs (locOf loc) (aliases f_als) $ zipWith withParam (diets f_als) args+  app_al <- internalAlias "internal_app_result" $ NameAppRes fname loc+  pure $ foldl applyArg (second (S.insert app_al) f_als) $ map snd args+  where+    withParam d (e, e_als) = (toParam d (typeOf e), (e, e_als))++    diets :: TypeBase dim o -> [Diet]+    diets (Scalar (Arrow _ _ d _ (RetType _ rt))) = d : diets rt+    diets _ = repeat Observe++-- | Join the results of the branches of a branching expression (described by+-- the string), given everything consumed by any of them. An alias survives if+-- it and everything it aliases is still alive; the rest are consumed. If the+-- components of some branch's result overlap, the components of the joined+-- result are tied together by a fresh name. See Note [Locations].+joinBranches :: T.Text -> Loc -> Consumed -> NE.NonEmpty TypeAliases -> CheckM TypeAliases+joinBranches what loc all_cons branches = do+  vtable <- asks envVtable+  let alive = isNothing . deadIn all_cons+      keep a = case aliasLoc a of+        Nothing -> True+        Just l -> alive l && all alive (aliasOf vtable l)+      t = foldl1 combineAliases branches+      dropped = S.filter (not . keep) $ aliases t+  consumed $ all_cons <> M.fromList (map (,loc) (aliasLocs dropped))+  tie <-+    if all separated branches+      then pure id+      else S.insert <$> internalAlias "internal_branch_result" (NameBranchRes what (srclocOf loc))+  pure $ second (tie . S.filter keep) t++-- | Check an expression whose value is bound to names (described by the+-- string). If that expression is a higher-order type, then it may not have+-- consumed anything. This is because we want to be able to duplicate the+-- computation for defunctionalisation purposes.+checkBound :: Doc () -> Exp -> CheckM (Exp, TypeAliases)+checkBound what e = do+  ((e', e_als), e_cons) <- contain $ checkExp e+  consumed e_cons+  let e_t = typeOf e'+  when (e_cons /= mempty && not (orderZero e_t)) $+    addError (locOf e) mempty . withIndexLink "contains-consumption" $+      what+        <+> "of higher-order type"+        </> indent 2 (pretty e_t)+        </> "contains consumption, which is not allowed."+  pure (e', e_als)++-- Note that this may modify the type annotations inside the expression, which+-- is why we return a new one.+checkExp :: Exp -> CheckM (Exp, TypeAliases)+-- First we have the complicated cases.++--+checkExp (AppExp (Apply f args loc) appres) = do+  -- Futhark evaluates the arguments of an application from right to left, and+  -- then the function.+  args' <- NE.reverse <$> traverse (traverse checkArg) (NE.reverse args)+  f_fresh <- case f of+    Var qn (Info t) floc -> do+      -- It is important to use the checked arguments here, as their refined+      -- types can affect parametricFreshness.+      t' <- parametricFreshness qn t $ map (typeOf . fst . snd) $ NE.toList args'+      pure $ Var qn (Info t') floc+    _ -> pure f+  (f', f_als) <- checkExp f_fresh+  res_als <- checkApply loc (fname f) f_als $ map snd $ NE.toList args'+  pure (AppExp (Apply f' (fmap (second fst) args') loc) appres, res_als)+  where+    fname (Var v _ _) = Just v+    fname (AppExp (Apply e _ _) _) = fname e+    fname _ = Nothing++--+checkExp (AppExp (Loop sparams pat loopinit form body loc) appres) = do+  ((pat', loopinit', form', body'), als) <-+    checkLoop (locOf loc) (pat, loopinit, form, body)+  pure+    ( AppExp (Loop sparams pat' loopinit' form' body' loc) appres,+      als+    )++--+checkExp (AppExp (LetPat sizes p e body loc) appres) = do+  (e', e_als) <- checkBound "Let-bound expression" e+  bindingPat p e_als $ do+    (body', body_als) <- checkExp body+    pure+      ( AppExp (LetPat sizes p e' body' loc) appres,+        body_als+      )++--+checkExp (AppExp (If cond te fe loc) appres) = do+  (cond', _) <- checkExp cond+  ((te', te_als), te_cons) <- contain $ checkExp te+  ((fe', fe_als), fe_cons) <- contain $ checkExp fe+  comb_als <- joinBranches "if-expression" (locOf loc) (te_cons <> fe_cons) $ te_als NE.:| [fe_als]+  pure+    ( AppExp (If cond' te' fe' loc) appres,+      appResType (unInfo appres) `setAliases` mempty `combineAliases` comb_als+    )++--+checkExp (AppExp (Match cond cs loc) appres) = do+  (cond', cond_als) <- checkBound "Matched expression" cond+  ((cs', cs_als), cs_cons) <-+    first NE.unzip . NE.unzip <$> mapM (checkCase cond_als) cs+  comb_als <- joinBranches "match-expression" (locOf loc) (fold cs_cons) cs_als+  pure+    ( AppExp (Match cond' cs' loc) appres,+      appResType (unInfo appres) `setAliases` mempty `combineAliases` comb_als+    )+  where+    checkCase cond_als (CasePat p body caseloc) =+      contain $ bindingPat p cond_als $ do+        (body', body_als) <- checkExp body+        pure (CasePat p body' caseloc, body_als)++--+checkExp (AppExp (LetFun fname (typarams, params, retdecl, Info (RetType ext ret), funbody) letbody loc) appres) = do+  ((ret', funbody'), ftype) <- bindingParams params $ do+    mapM_ checkSizes retdecl+    -- Throw away the consumption - it can refer only to the parameters anyway.+    ((funbody', funbody_als), _body_cons) <- contain $ checkExp funbody+    checkReturnAlias loc params ret funbody_als+    als <- closureAliases params funbody funbody_als+    let ret' = maybe (inferReturnFreshness params ret funbody_als) (const ret) retdecl+        ftype = funType params (RetType ext ret') `setAliases` als+    pure ((ret', funbody'), ftype)+  (letbody', letbody_als) <- bindingFun (fst fname) ftype $ checkExp letbody+  pure+    ( AppExp (LetFun fname (typarams, params, retdecl, Info (RetType ext ret'), funbody') letbody' loc) appres,+      letbody_als+    )++--+checkExp (AppExp (BinOp (op, oploc) (Info op_t) (x, xp) (y, yp) loc) appres) = do+  (x', x_als) <- checkArg x+  (y', y_als) <- checkArg y+  op_t' <- parametricFreshness op op_t [typeOf x', typeOf y']+  op_als <- observeVar (locOf oploc) op op_t'+  res_als <- checkApply loc (Just op) op_als [(x', x_als), (y', y_als)]+  pure+    ( AppExp (BinOp (op, oploc) (Info op_t') (x', xp) (y', yp) loc) appres,+      res_als+    )++--+checkExp (Lambda params body te (Info (RetType ext ret)) loc) =+  bindingParams params $ do+    mapM_ checkSizes te+    -- Throw away the consumption - it can refer only to the parameters+    -- anyway.+    ((body', body_als), _body_cons) <- contain $ checkExp body+    checkReturnAlias loc params ret body_als+    als <- closureAliases params body body_als+    let ret' = maybe (inferReturnFreshness params ret body_als) (const ret) te+        ftype = funType params (RetType ext ret') `setAliases` als+    pure+      ( Lambda params body' te (Info (RetType ext ret')) loc,+        ftype+      )++--+checkExp (AppExp (LetWith dst src steps ve body loc) appres) = do+  steps' <- mapM checkStep steps+  (ve', ve_als) <- checkExp ve+  src_als <- observeVar (locOf src) (qualName (identName src)) (unInfo $ identType src)++  let hasIndex = any isIndex steps++  when hasIndex $ do+    overlapCheck (locOf ve) (src, src_als) (ve', ve_als)+    checkUpdatePath (locOf loc) steps src_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 steps ve t loc) = do+  steps' <- mapM checkStep steps+  (ve', ve_als) <- checkExp ve+  (src', src_als) <- checkExp src+  checkIfConsumed (locOf loc) $ aliases ve_als+  let hasIndex = any isIndex steps+  res_als <-+    if hasIndex+      then do+        overlapCheck (locOf ve) (src', src_als) (ve', ve_als)+        checkUpdatePath (locOf loc) steps src_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+  als <- observeVar (locOf loc) v t+  checkIfConsumed (locOf loc) (aliases als)+  pure (Var v (Info t) loc, als)+checkExp (OpSection v (Info t) loc) = do+  als <- observeVar (locOf loc) v t+  checkIfConsumed (locOf loc) (aliases als)+  pure (OpSection v (Info t) loc, als)+checkExp (OpSectionLeft op ftype arg arginfo retinfo loc) = do+  let (Info (_, arg_t, _), Info (pn, pt2)) = arginfo+      (Info ret, _) = retinfo+  als <- observeVar (locOf loc) op (unInfo ftype)+  (arg', arg_als) <- checkSectionArg als arg_t arg+  pure+    ( OpSectionLeft op ftype arg' arginfo retinfo loc,+      Scalar $ Arrow (aliases arg_als <> aliases als) pn (diet pt2) (toStruct pt2) ret+    )+checkExp (OpSectionRight op ftype arg arginfo retinfo loc) = do+  let (Info (pn, pt2), Info (_, arg_t, _)) = arginfo+      Info ret = retinfo+  als <- observeVar (locOf loc) op (unInfo ftype)+  (arg', arg_als) <- checkSectionArg als arg_t arg+  pure+    ( OpSectionRight op ftype arg' arginfo retinfo loc,+      Scalar $ Arrow (aliases arg_als <> aliases als) pn (diet pt2) (toStruct pt2) ret+    )+checkExp (UpdateSection steps t loc) = do+  steps' <- mapM checkStep steps+  pure (UpdateSection steps' t loc, unknownAliases (unInfo t))+  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+  checkSizes te+  pure (Coerce e' te t loc, e_als)+checkExp (Ascript e te loc) = do+  (e', e_als) <- checkExp e+  checkSizes te+  pure (Ascript e' te loc, e_als)+checkExp (AppExp (Index v slice loc) appres) = do+  (v', v_als) <- checkExp v+  slice' <- checkSubExps slice+  checkIfConsumed (locOf loc) $ aliases v_als+  pure+    ( AppExp (Index v' slice' loc) appres,+      appResType (unInfo appres) `setAliases` aliases v_als+    )+checkExp (Assert e1 e2 t loc) = do+  (e1', _) <- checkExp e1+  (e2', e2_als) <- checkExp e2+  pure (Assert e1' e2' t loc, e2_als)+checkExp (Parens e loc) = do+  (e', e_als) <- checkExp e+  pure (Parens e' loc, e_als)+checkExp (QualParens v e loc) = do+  (e', e_als) <- checkExp e+  pure (QualParens v e' loc, e_als)+checkExp (Attr attr e loc) = do+  (e', e_als) <- checkExp e+  pure (Attr attr e' loc, e_als)+checkExp (Project name e t loc) = do+  (e', e_als) <- checkExp e+  pure+    ( Project name e' t loc,+      case e_als of+        Scalar (Record fs)+          | Just name_als <- M.lookup name fs -> name_als+        _ -> error $ "checkExp Project: bad type " <> prettyString e_als+    )+checkExp (TupLit es loc) = do+  (es', es_als) <- mapAndUnzipM checkExp es+  checkIfConsumed (locOf loc) $ foldMap aliases es_als+  pure (TupLit es' loc, Scalar $ tupleRecord es_als)+checkExp (Constr name es t loc) = do+  (es', es_als) <- mapAndUnzipM checkExp es+  checkIfConsumed (locOf loc) $ foldMap aliases es_als+  pure+    ( Constr name es' t loc,+      case unInfo t of+        Scalar (Sum cs) ->+          Scalar . Sum . M.insert name es_als $+            M.map (map (`setAliases` mempty)) cs+        t' -> error $ "checkExp Constr: bad type " <> prettyString t'+    )+checkExp (RecordLit fs loc) = do+  (fs', fs_als) <- mapAndUnzipM checkField fs+  checkIfConsumed (locOf loc) $ foldMap (aliases . snd) fs_als+  pure (RecordLit fs' loc, Scalar $ Record $ M.fromList fs_als)+  where+    checkField (RecordFieldExplicit name e floc) = do+      (e', e_als) <- checkExp e+      pure (RecordFieldExplicit name e' floc, (unLoc name, e_als))+    checkField (RecordFieldImplicit name t floc) = do+      name_als <- observeVar (locOf floc) (qualName (unLoc name)) $ unInfo t+      pure (RecordFieldImplicit name t floc, (baseName (unLoc name), name_als))++-- Cases that create alias-free values.+checkExp e@(AppExp Range {} _) = noAliases e+checkExp e@IntLit {} = noAliases e+checkExp e@FloatLit {} = noAliases e+checkExp e@Literal {} = noAliases e+checkExp e@StringLit {} = noAliases e+checkExp e@ArrayVal {} = noAliases e+checkExp (ArrayLit es t loc) = do+  (es', es_als) <- mapAndUnzipM checkExp es+  checkIfConsumed (locOf loc) $ foldMap aliases es_als+  pure (ArrayLit es' t loc, unknownAliases (unInfo t))+checkExp e@Negate {} = noAliases e+checkExp e@Not {} = noAliases e+checkExp e@Hole {} = noAliases e++-- | Type-check a value definition.  This also infers a new return+-- type that may be fresher than previously.+checkValDef ::+  -- | The type scheme of any global, along with the type parameters it is+  -- polymorphic in.  See Note [Parametric results].+  (QualName VName -> Maybe BoundV) ->+  (VName, [TypeParam], [Pat ParamType], Exp, ResRetType, Maybe (TypeExp Exp VName), SrcLoc) ->+  ((Exp, ResRetType), [TypeError])+checkValDef globals (fname, tparams, params, body, RetType ext ret, retdecl, loc) = runCheckM globals' (locOf loc) $ do+  fmap fst . bindingParams params $ do+    mapM_ checkSizes retdecl+    -- A top-level constant is a name like any other.+    (body', body_als) <-+      if null params then checkBound "Top-level constant" body else checkExp body+    checkReturnAlias loc params ret body_als+    -- If the user did not provide an annotation (meaning the return type is+    -- fully inferred), we infer the freshness. Otherwise, we go with whatever+    -- they wanted. This lets the user define nonfresh return types even if the+    -- body actually has no aliases.+    ret' <- case retdecl of+      Just retdecl' -> do+        when (null params && fresh ret) $+          addError retdecl' mempty "A top-level constant cannot be declared fresh."+        pure $ RetType ext ret+      Nothing ->+        pure $+          RetType ext $+            inferReturnFreshness params ret body_als++    pure+      ( (body', ret'),+        body_als -- Don't matter.+      )+  where+    -- Recursion is monomorphic, so a recursive call is at the type parameters+    -- of the definition itself.+    globals' qn+      | qualLeaf qn == fname = Just $ BoundV tparams $ funType params (RetType ext ret)+      | otherwise = globals qn+{-# NOINLINE checkValDef #-}++-- Note [Parametric results]+--+-- Parametricity tells us three things about the result of applying a global+-- function, all read from its *declared* type scheme, which 'envGlobal' looks+-- up: whether the application may have manufactured a value with internal+-- aliasing, whether the result must be fresh because it is the result of an+-- argument that constructs its results freshly, and whether the result may+-- alias a global.+--+-- ## Internal aliasing+--+-- The type system cannot talk about a value that aliases *itself*. For example,+-- a value that is, behind an abstraction boundary, a pair of arrays that are+-- really the same array. Such a value can never be consumed, nor given a fresh+-- type. 'AliasSelf' stands for that possibility. It is not an alias of any+-- variable ('aliasVar' is 'Nothing' for it), so it must never be mistaken for+-- one; ask "might these two values share memory?" through 'overlaps' rather+-- than by comparing alias sets directly. We can think that when 'AliasSelf' is+-- part of an aliasing set then we have "imprecise aliases", and otherwise we+-- have "precise aliases" (but do not take these terms literally; aliasing is+-- almost always an over-approximation).+--+-- Parametricity is what tells us whether such a value can have been+-- manufactured by a given function application.+--+-- The crude answer - a value has internal aliasing whenever it is produced by+-- applying a function whose result type is a nonfresh abstract type - is+-- sound but far too coarse.  It refuses+--+--   module pm (M: {type t}) = {+--     def f (x: *M.t) : *M.t = id x+--   }+--+-- because @id@ is instantiated at @M.t -> M.t@. But @id@ manufactures nothing:+-- its declared type @a -> a@ means, by parametricity, that what it returns *is*+-- its argument, whose aliases we know precisely.+--+-- So we perform a more sophisticated reasonong: a function can only manufacture+-- an abstract value if its result mentions an abstract type that is not one of+-- its own type parameters ('manufacturesAbstract'). This is not the same as+-- "the abstract type also occurs in a parameter": a monomorphic @f: M.t -> M.t@+-- inside a module might well be @\_ -> M.mk 5@, so its type tells us nothing+-- (tests/uniqueness/uniqueness-error75.fut). Only genuine polymorphism does.+--+-- Consumption checking sees only instantiated types, so the declared type is+-- looked up when a name is mentioned ('envGlobal', consulted by 'observeVar')+-- and the answer recorded in the type as an 'AliasSelf' on each function+-- component ('addSelfAliases').  From there ordinary alias propagation carries+-- it: through binding, so @let my_mk = M.mk in my_mk n@ still manufactures;+-- through 'returnType', so partial application does not lose it, and neither+-- does passing the function as an argument, so @n |> M.mk@ manufactures even+-- though @|>@ itself does not.  No arity bookkeeping is needed, because+-- 'AliasSelf' means the same thing at every arity: on a function, "applying+-- this may yield an internally-aliased value", and on a value, "this may have+-- internal aliasing".  'returnType' moves between the two readings for free as+-- the result stops being an arrow.+--+-- This is a conservative over-approximation we use whenever we have no better+-- information available. Hence 'unknownAliases', used for parameters+-- ('selfAliasType') and for any type we build out of thin air, and hence+-- 'closureAliases' keeping the 'AliasSelf' that a function defined here picked+-- up from its own body. Alias sets are combined by union, and a union of "may"+-- is again a "may"; the join of branches in Note [Locations] drops aliases, but+-- never 'AliasSelf'. In some sense, 'AliasSelf' behaves a bit like the top+-- element of a lattice.+--+-- ## Freshness+--+-- Futhark does not have "freshness polymorphism", but we can infer it in some+-- cases by parametricity. Consider+--+--   def (|>) 'a '^b (x: a) (f: a -> b) : b = f x+--+-- The only way for a function to obtain a value of one of its type parameters+-- is to be handed one. Here @b@ occurs among the parameters only as the result+-- of @f@, so the result of @|>@ is necessarily the result of calling @f@. When+-- @f@ in addition constructs its result freshly - as @copy: t -> *t@ does - so+-- does the application.+--+-- In general, a *source* of a type parameter @b@ is a component of a parameter+-- (reached through records) that is a function @t -> b@ observing its argument+-- ('callSources'). The result of an application is fresh when+-- ('resultSources'):+--+-- - every component of the result is either primitive or a type parameter,+--   and each type parameter occurs in it once;+--+-- - each of these type parameters has a source, and occurs at no negative+--   position among the parameters other than its sources; and+--+-- - the argument given for each source constructs its result freshly.+--+-- A negative occurrence that is not a source, such as a parameter of type @b@+-- or @[]b@, or @b@ in the parameter of a source, is a way for the function to+-- be handed values of @b@ other than by calling a source, and the result may+-- then be one of those. An occurrence in the argument of an abstract type+-- counts, as we cannot see where it ends up. A source must also take a single+-- argument and observe it. We know of no program that goes wrong without this+-- restriction, but the argument above has not been made for curried or+-- consuming functions, so they are not sources. The single occurrence is needed+-- because the function may return the result of one call twice:+--+--   def dup 'a 'b (f: a -> b) (x: a) : (b, b) = let r = f x in (r, r)+--+-- Each component of @dup mk_new x@ is fresh on its own, but they are the same+-- array (tests/uniqueness/uniqueness-error118.fut).+--+-- This is a property of the application, not of @|>@ or of its instantiation:+-- @xs |> copy@ is fresh and @xs |> id@ is not, at the very same instantiation.+-- Recall that the instantiation from Terms.hs does not have freshness+-- propagated, so the result in the type is nonfresh, as specified in the type+-- scheme. However, we here update the _instantiated_ type of @|>@ at the+-- application ('parametricFreshness'), which becomes+--+--   (x: []i32) -> (f: []i32 -> *[]i32) -> *[]i32+--+-- From there the ordinary rule for applying a function with a fresh return+-- type does the rest, and later passes get it for free: the monomorphiser keys+-- instances on the type, so @xs |> copy@ and @xs |> id@ become distinct+-- instances, and 'freshenFromInst' in Futhark.Internalise.Monomorphise carries+-- the freshness into the generated definition. Only the result is marked. The+-- body of that definition is @f x@, with @f@ still declared to return a+-- nonfresh value, but nothing checks the one against the other:+-- defunctionalisation replaces @f@ by the function it is applied to, and the+-- call then has the return type of that function.+--+-- A core restriction is that only an application that supplies every parameter+-- of the function's *type* is refined. A partial application may already have+-- evaluated part of the function's body, and the closure it produces may then+-- hold what that part computed. Consider+--+--   def trap 'a 'b 'c (f: a -> b) (x: a) : c -> b =+--     let r = f x in \(_: c) -> r+--+-- Each call @trap mk_new x u@ computes its own @r@, so its result is fresh. But+-- @k = trap mk_new x@ computes @r@ once, and every call of @k@ returns that+-- same @r@ (tests/higher-order-functions/trap.fut). Read plainly, the result+-- of calling @k@ aliases @k@, which is what makes consuming it safe. The type+-- does not say how much of it a partial application evaluates, so no partial+-- application is refined - an operator section included.+--+-- Which parameter a type variable came from is a fact about the declared type,+-- which the instantiated type does not record, so the applied expression must+-- be a direct mention of a named global. Semantically equal programs are+-- therefore treated differently -+--+--   xs |> copy      -- fresh+--   (|>) xs copy    -- not fresh+--+-- - and the refinement is lost by anything that obscures the head, including+-- parentheses and @let@. This is never *wrong*, only conservative: a spelling+-- we do not recognise yields the plain reading.+--+-- ## Globals+--+-- A use of a global aliases that global, and globals cannot be consumed. When+-- applying a global function returning a nonfresh result, the result thereby+-- aliases the global, and hence cannot be consumed.+--+-- Parametricity keeps polymorphic functions such as @transpose@ precise+-- ('globalAliases'). An edge case is polymorphic "values", which arise solely+-- (I think) for arrays, as an empty array literal can have any element type. To+-- address this, our semantics for polymorphic values is that they are+-- implicitly functions; re-computed on every access to the global. The+-- monomorphiser ensures that by compiling a polymorphic value as a function of+-- @()@, so that each use computes it anew, just as a size-polymorphic value is+-- a function of its sizes. Hence:+--+-- - A component that is not a function, and whose declared type contains one of+--   the global's type parameters, does not alias the global. So @empty 'a :+--   []a@ aliases nothing, while the first component of @pv 'a : ([]i32, []a)@+--   aliases @pv@. An array such as @[](a, i32)@ also counts: it has elements+--   only if it was handed some, and the only way of pairing them with other+--   data, @zip@, constructs its result freshly.+--+-- - A type parameter that is an argument to an abstract type does not count.+--   The module defining @M.t@ may well have @type t 'a = i32@, and so a value+--   of type @M.t a@ or @[](M.t a)@ may be a global.+--+-- - A function aliases the global exactly when some nonfresh component of its+--   (curried) result is not of that kind. So @transpose@, @reverse@ and @|>@+--   alias nothing, and their results alias only their arguments, while the+--   results of @tail : []i32 -> []i32@ alias @tail@ and cannot be consumed. A+--   function has a single alias set, so in a result such as @([]i32, a)@ the+--   second component is also taken to alias the function.+--+-- Size parameters do not count: as far as types can tell, @zeros [n] : [n]i32@+-- might be (a slice of) a global, so it aliases @zeros@.+--+-- This reasoning needs the type parameters, which monomorphisation removes.+-- Hence, monomorphising a Futhark program results in a program that may no+-- longer be correct as far as (this) alias analysis is concerned.++-- Note [Locations]+--+-- Compound types (records and sums) do not have identity. Instead, we track+-- aliasing and consumption at the level of their components ("leaves"). A+-- "path" is a reference to the component of a compound type.+--+-- A location is a variable together with a path ('Location'); every 'Alias'+-- except 'AliasSelf' denotes one. The consumed set holds locations, and a+-- location is dead if a location on the same variable has been consumed whose+-- path is a prefix of its own, or of which its own is a prefix ('deadIn').+-- Consuming @p.a@ kills @p.a@, everything under it, and @p@ itself; consuming+-- @p@ kills all of @p@.+--+-- The payload of a constructor is treated exactly as a tuple, nested under the+-- constructor name: the payload of @#foo xs ys@ has the paths @[foo, 0]@ and+-- @[foo, 1]@.  The components of a sum are therefore separate parts, so+-- @#foo u u@ is self-aliasing just like @(u, u)@, and its payload can be taken+-- apart by pattern matching just like a tuple.+--+-- Using a variable reads all of it: its alias set has a location for each of+-- its leaves, and observing it requires them all to be alive.  Projection+-- happens afterwards.  So to consume one component of a tuple and keep using+-- another, take the tuple apart first:+--+--   let (a, b) = p in let a[0] = 1 in b      -- accepted+--   let a = p.0 in let a[0] = 1 in p.1       -- rejected: p.1 reads p+--+-- Components that may coincide have overlapping alias sets, which is what+-- 'separated' and 'unfreshness' look for.  Building a value preserves this, as+-- each component aliases what it was built from, and so does applying a+-- function or running a loop, as every nonfresh component of the result aliases+-- the same internal name.  The exceptions are an observed parameter, whose+-- components the caller may have made coincide, and a component with+-- 'AliasSelf'.  Neither can be consumed, and the locations of an observed+-- parameter never die.+--+-- The join of the branches of an @if@ or @match@ ('joinBranches') keeps an alias of the combined branch+-- results if it is 'AliasSelf', or if its location and every location in its+-- alias set ('aliasOf') are alive after the branches; the other aliases are+-- consumed.  Filtering by liveness in this way, rather than subtracting the+-- consumed set, is closed under aliasing: if an alias survives, so does+-- everything it aliases.  This is the only place where aliases are dropped, and+-- it may drop the evidence that two components coincide.  Consider+--+--   let (r0, r1) = if c then (u, u) else (let z = u with [0] = 5 in (a, b))+--+-- The else branch consumes @u@, so the filter alone would leave the aliases+-- @({a}, {b})@, claiming that the components of the result are separate, which+-- is false when @c@ holds.  So when the components of some branch's result+-- overlap, the join adds an alias of a fresh name to every component of the+-- combined result.  Being fresh, it is alive after the branches, and as it is+-- consumed along with any component, consuming @r0@ kills @r1@.+--+-- Futhark is not in A-normal form, but an expression that builds a value from+-- operands behaves as if it were: it evaluates all of its operands, and then+-- uses their values. This covers tuples, records, constructors and arrays,+-- indexing, operator sections, and function application (which evaluates its+-- arguments from right to left, and then the function). So the value of an+-- operand must not alias anything that a later operand consumes. A function+-- application then consumes what its parameters consume. A consumed component+-- of an argument must not share a location with any other component of that+-- argument ('noSelfAliases'), and must not overlap the function being applied+-- or any other argument ('passArgs').  The diet of a function parameter is the+-- same for all of its components, but that of a loop parameter is not.+--+-- A loop is checked as a recursive call whose arguments are what its body+-- returns ('checkLoopResult').  The value returned for a consumed loop+-- parameter is consumed in the next iteration, so it must be fresh in exactly+-- the sense below, with the loop parameters as the parameters.  The diets of+-- the loop parameters are inferred first: a parameter is consumed if the body+-- consumes it or the value returned for a consumed parameter aliases it+-- ('convergeLoopParam').+--+-- A component of a function's result may be fresh exactly when every in-scope+-- location it aliases lies within a consumed part of a parameter, none of its+-- locations occurs in another component, and it is not 'selfAliased'.  The one+-- predicate ('unfreshness') both infers fresh return types and checks declared+-- ones, so declared freshness never exceeds what would be inferred.
src/Language/Futhark/TypeChecker/Modules.hs view
@@ -156,9 +156,9 @@         substituteInTypeParam (TypeParamType l p loc) =           TypeParamType l (substitute p) loc -        substituteInScalarType :: ScalarTypeBase Size u -> ScalarTypeBase Size u-        substituteInScalarType (TypeVar u v targs) =-          TypeVar u (substituteInQualName v) $ map substituteInTypeArg targs+        substituteInScalarType :: ScalarTypeBase Size o -> ScalarTypeBase Size o+        substituteInScalarType (TypeVar o v targs) =+          TypeVar o (substituteInQualName v) $ map substituteInTypeArg targs         substituteInScalarType (Prim t) =           Prim t         substituteInScalarType (Record ts) =@@ -168,14 +168,14 @@         substituteInScalarType (Arrow als v d1 t1 (RetType dims t2)) =           Arrow als v d1 (substituteInType t1) $ RetType dims $ substituteInType t2 -        substituteInRetType :: RetTypeBase Size u -> RetTypeBase Size u+        substituteInRetType :: RetTypeBase Size o -> RetTypeBase Size o         substituteInRetType (RetType ext t) =           RetType (map substitute ext) $ substituteInType t -        substituteInType :: TypeBase Size u -> TypeBase Size u+        substituteInType :: TypeBase Size o -> TypeBase Size o         substituteInType (Scalar t) = Scalar $ substituteInScalarType t-        substituteInType (Array u shape t) =-          Array u (substituteInShape shape) $ substituteInScalarType t+        substituteInType (Array o shape t) =+          Array o (substituteInShape shape) $ substituteInScalarType t          substituteInShape (Shape ds) = Shape $ map substituteInExp ds
src/Language/Futhark/TypeChecker/Monad.hs view
@@ -263,13 +263,15 @@ getTySet = gets stateTySet  -- | Run type checking command while accumulating (and returning) all new--- abstract types, then reset to known abstract types afterwards.+-- abstract types.  Abstract types are uniquely named and their liftedness+-- never changes, so the set of known abstract types only ever grows; an+-- abstract type created inside a module expression is still nameable+-- afterwards (as @m.t@), and so must remain known. collectTySet :: TypeM a -> TypeM (a, TySet) collectTySet m = do   old <- gets stateTySet   x <- m   new <- gets stateTySet-  modify $ \s -> s {stateTySet = old}   pure (x, new `M.difference` old)  -- | Look up the liftedness of an abstract type.@@ -497,8 +499,8 @@   Env ->   [VName] ->   [VName] ->-  TypeBase Size as ->-  TypeBase Size as+  TypeBase Size o ->+  TypeBase Size o qualifyTypeVars = qualifyTypeVarsWith onDim   where     onDim qual except e = runIdentity $ onDimM except e@@ -510,30 +512,30 @@ -- sizes, which are handled by the given function (that is passed the -- qualification function and the set of names not to qualify). qualifyTypeVarsWith ::-  forall dim as.+  forall dim o.   ((S.Set VName -> QualName VName -> QualName VName) -> S.Set VName -> dim -> dim) ->   Env ->   [VName] ->   [VName] ->-  TypeBase dim as ->-  TypeBase dim as+  TypeBase dim o ->+  TypeBase dim o qualifyTypeVarsWith onDim outer_env orig_except ref_qs   | null ref_qs = id   | otherwise = onType (S.fromList orig_except)   where     onType ::-      forall as'.+      forall o'.       S.Set VName ->-      TypeBase dim as' ->-      TypeBase dim as'-    onType except (Array u shape et) =-      Array u (fmap (onDim qual except) shape) (onScalar except et)+      TypeBase dim o' ->+      TypeBase dim o'+    onType except (Array o shape et) =+      Array o (fmap (onDim qual except) shape) (onScalar except et)     onType except (Scalar t) =       Scalar $ onScalar except t      onScalar _ (Prim t) = Prim t-    onScalar except (TypeVar u qn targs) =-      TypeVar u (qual except qn) (map (onTypeArg except) targs)+    onScalar except (TypeVar o qn targs) =+      TypeVar o (qual except qn) (map (onTypeArg except) targs)     onScalar except (Record m) =       Record $ M.map (onType except) m     onScalar except (Sum m) =@@ -646,3 +648,5 @@   pure $ AttrAtom (AtomName v) loc checkAttr (AttrAtom (AtomInt x) loc) =   pure $ AttrAtom (AtomInt x) loc+checkAttr (AttrAtom (AtomVar v) loc) =+  pure $ AttrAtom (AtomVar v) loc
src/Language/Futhark/TypeChecker/Names.hs view
@@ -62,7 +62,7 @@       check seen t1 >> check seen t2     check seen (TETuple ts _) = mapM_ (check seen) ts     check seen (TERecord fs _) = mapM_ (check seen . snd) fs-    check seen (TEUnique t _) = check seen t+    check seen (TEStar t _) = check seen t     check seen (TESum cs _) = mapM_ (mapM (check seen) . snd) cs     check seen (TEApply t1 (TypeArgExpType t2) _) =       check seen t1 >> check seen t2@@ -127,13 +127,14 @@ resolveName :: Name -> SrcLoc -> TypeM VName resolveName v loc = qualLeaf <$> resolveQualName (qualName v) loc -resolveAttrAtom :: AttrAtom Name -> TypeM (AttrAtom VName)-resolveAttrAtom (AtomName v) = pure $ AtomName v-resolveAttrAtom (AtomInt x) = pure $ AtomInt x+resolveAttrAtom :: AttrAtom Name -> SrcLoc -> TypeM (AttrAtom VName)+resolveAttrAtom (AtomName v) _ = pure $ AtomName v+resolveAttrAtom (AtomInt x) _ = pure $ AtomInt x+resolveAttrAtom (AtomVar v) loc = AtomVar <$> resolveName v loc  resolveAttrInfo :: AttrInfo Name -> TypeM (AttrInfo VName) resolveAttrInfo (AttrAtom atom loc) =-  AttrAtom <$> resolveAttrAtom atom <*> pure loc+  AttrAtom <$> resolveAttrAtom atom loc <*> pure loc resolveAttrInfo (AttrComp name infos loc) =   AttrComp name <$> mapM resolveAttrInfo infos <*> pure loc @@ -155,8 +156,8 @@       TETuple <$> mapM f tes <*> pure loc     f (TERecord fs loc) =       TERecord <$> mapM (traverse f) fs <*> pure loc-    f (TEUnique te loc) =-      TEUnique <$> f te <*> pure loc+    f (TEStar te loc) =+      TEStar <$> f te <*> pure loc     f (TEApply te1 args loc) =       TEApply <$> f te1 <*> onArg args <*> pure loc       where
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -1,10 +1,10 @@ -- | Facilities for type-checking Futhark terms.  Checking a term--- requires a little more context to track uniqueness and such.+-- requires a little more context to track consumption and such. -- -- Type inference is implemented through a variation of -- Hindley-Milner.  The main complication is supporting the rich--- number of built-in language constructs, as well as uniqueness--- types.  This is mostly done in an ad hoc way, and many programs+-- number of built-in language constructs, as well as consumption+-- and freshness.  This is mostly done in an ad hoc way, and many programs -- will require the programmer to fall back on type annotations. -- -- The strategy is to split type checking into sveral (main) passes:@@ -18,8 +18,8 @@ -- full unsized type of everything. This is done using a syntax-driven -- approach, similar to Algorithm W. ----- 3) The program is then checked for violation of uniqueness--- properties, which is implemented in+-- 3) The program is then checked for violation of the consumption+-- and freshness rules, which is implemented in -- "Language.Futhark.TypeChecker.Consumption". module Language.Futhark.TypeChecker.Terms   ( checkOneExp,@@ -74,7 +74,7 @@  --- Basic checking --- | Determine if the two types are identical, ignoring uniqueness.+-- | Determine if the two types are identical, ignoring annotations. -- Mismatched dimensions are turned into fresh rigid type variables. -- Causes a 'TypeError' if they fail to match, and otherwise returns -- one of them.@@ -92,13 +92,13 @@ sliceShape ::   Maybe (SrcLoc, Rigidity) ->   [DimIndex] ->-  TypeBase Size as ->-  TermTypeM (TypeBase Size as, [VName])-sliceShape r slice t@(Array u (Shape orig_dims) et) =+  TypeBase Size o ->+  TermTypeM (TypeBase Size o, [VName])+sliceShape r slice t@(Array o (Shape orig_dims) et) =   runStateT (setDims <$> adjustDims slice orig_dims) []   where     setDims [] = stripArray (length orig_dims) t-    setDims dims' = Array u (Shape dims') et+    setDims dims' = Array o (Shape dims') et      -- If the result is supposed to be a nonrigid size variable, then     -- don't bother trying to create non-existential sizes.  This is@@ -243,7 +243,7 @@           pure $ sizeFromName (qualName v) (srclocOf d)  -- Expressions witnessed by type, topologically sorted.-topWit :: TypeBase Exp u -> [Exp]+topWit :: TypeBase Exp o -> [Exp] topWit = topologicalSort depends . witnessedExps   where     witnessedExps t = execState (traverseDims onDim t) mempty@@ -256,8 +256,8 @@   (MonadUnify m) =>   SrcLoc ->   (Exp -> Maybe VName) ->-  TypeBase Size u ->-  m (TypeBase Size u, [VName])+  TypeBase Size o ->+  m (TypeBase Size o, [VName]) sizeFree tloc expKiller orig_t = do   runReaderT (toBeReplaced orig_t $ onType orig_t) mempty `runStateT` mempty   where@@ -294,8 +294,8 @@       rl <- state $ L.partition (`notElem` old_bound)       let dims' = dims <> rl       pure $ Arrow as pn d argT' (RetType dims' retT')-    onScalar (TypeVar u v args) =-      TypeVar u v <$> mapM onTypeArg args+    onScalar (TypeVar o v args) =+      TypeVar o v <$> mapM onTypeArg args       where         onTypeArg (TypeArgDim d) = TypeArgDim <$> replacing d         onTypeArg (TypeArgType ty) = TypeArgType <$> onType ty@@ -303,10 +303,10 @@      onType ::       (MonadUnify m) =>-      TypeBase Size u ->-      ReaderT [(Exp, Exp)] (StateT [VName] m) (TypeBase Size u)-    onType (Array u shape scalar) =-      Array u <$> traverse replacing shape <*> onScalar scalar+      TypeBase Size o ->+      ReaderT [(Exp, Exp)] (StateT [VName] m) (TypeBase Size o)+    onType (Array o shape scalar) =+      Array o <$> traverse replacing shape <*> onScalar scalar     onType (Scalar ty) =       Scalar <$> onScalar ty @@ -316,8 +316,8 @@ -- into '[z]t', where 'z' is a fresh unknown, which is then by -- let-generalisation turned into '?[z].[z]t'. unscopeUnknown ::-  TypeBase Size u ->-  TermTypeM (TypeBase Size u)+  TypeBase Size o ->+  TermTypeM (TypeBase Size o) unscopeUnknown t = do   constraints <- getConstraints   -- The killer only ever fires on an unknown-size variable, so if none occurs@@ -340,8 +340,8 @@ unscopeType ::   SrcLoc ->   [VName] ->-  TypeBase Size as ->-  TermTypeM (TypeBase Size as, [VName])+  TypeBase Size o ->+  TermTypeM (TypeBase Size o, [VName]) unscopeType tloc unscoped t   -- Fast-path for common case where 't' has no free variables in unscoped.   | not (any (`elem` unscoped) (fvVars (freeInType t))) = pure (t, [])@@ -687,7 +687,7 @@       rettype_st <-         inferReturnSizes params'' =<< case rettype_checked of           Just (_, ret, _) -> normTypeFully ret-          Nothing -> pure $ toRes Nonunique body_t+          Nothing -> pure $ toRes Nonfresh body_t        pure (params'', body', (\(te, _, _) -> te) <$> rettype_checked, rettype_st) @@ -755,7 +755,7 @@         checkApply           loc           (Just op, 1)-          (Scalar $ Arrow mempty m2 d2 t2 $ RetType [] $ Scalar $ Arrow Nonunique m1 d1 t1 $ RetType dims2 ret)+          (Scalar $ Arrow mempty m2 d2 t2 $ RetType [] $ Scalar $ Arrow Nonfresh m1 d1 t1 $ RetType dims2 ret)           e'       case arrow' of         Scalar (Arrow _ _ _ t1' (RetType dims2' ret')) ->@@ -780,7 +780,7 @@     Scalar (Arrow _ _ _ pt _) -> replaceTyVars loc pt     _ -> error $ "checkExp UpdateSection: " <> prettyString ft   (steps', b, retext) <- checkSectionSteps a steps-  let ft' = Scalar $ Arrow mempty Unnamed Observe a $ RetType retext $ toRes Nonunique b+  let ft' = Scalar $ Arrow mempty Unnamed Observe a $ RetType retext $ toRes Nonfresh b   pure $ UpdateSection steps' (Info ft') loc   where     checkSectionSteps t [] =@@ -949,7 +949,7 @@ type ApplyOp = (Maybe (QualName VName), Int)  -- | Extract all those names that are bound inside the type.-boundInsideType :: TypeBase Size as -> S.Set VName+boundInsideType :: TypeBase Size o -> S.Set VName boundInsideType (Array _ _ t) = boundInsideType (Scalar t) boundInsideType (Scalar Prim {}) = mempty boundInsideType (Scalar (TypeVar _ _ targs)) = foldMap f targs@@ -967,7 +967,7 @@  -- Returns the sizes of the immediate type produced, -- the sizes of parameter types, and the sizes of return types.-dimUses :: TypeBase Size u -> (Names, Names)+dimUses :: TypeBase Size o -> (Names, Names) dimUses = flip execState mempty . traverseDims f   where     f bound pos e =@@ -1065,7 +1065,7 @@       e'' <- checkExp e'       let t = typeOf e''       (tparams, _, _) <--        letGeneralise (nameFromString "<exp>") (srclocOf e) generalised [] $ toRes Nonunique t+        letGeneralise (nameFromString "<exp>") (srclocOf e) generalised [] $ toRes Nonfresh t       detectAmbiguousSizes       e''' <- bindExistentialInsts =<< normTypeFully e''       localChecks tparams e'''@@ -1233,7 +1233,7 @@         "Refutable pattern not allowed here.\nUnmatched cases:"           </> indent 2 (stack (map pretty ps')) -supportsEquality :: TypeBase dim u -> Bool+supportsEquality :: TypeBase dim o -> Bool supportsEquality (Array _ _ t) = supportsEquality $ Scalar t supportsEquality (Scalar Prim {}) = True supportsEquality (Scalar TypeVar {}) = False@@ -1527,9 +1527,9 @@       relevant v = pending v || v `M.member` reps        onType ::-        (Substitutable (TypeBase Size u)) =>-        TypeBase Size u ->-        TermTypeM (TypeBase Size u, [VName])+        (Substitutable (TypeBase Size o)) =>+        TypeBase Size o ->+        TermTypeM (TypeBase Size o, [VName])       onType t         -- Fast path: this type mentions no pending or copied         -- instantiated size, so 'applySubst'/'sizeFree' would be@@ -1539,9 +1539,9 @@             sizeFree mempty (find pending . fvVars . freeInExp) $ applySubst repOf t        onStruct ::-        (Substitutable (TypeBase Size u)) =>-        TypeBase Size u ->-        TermTypeM (TypeBase Size u)+        (Substitutable (TypeBase Size o)) =>+        TypeBase Size o ->+        TermTypeM (TypeBase Size o)       onStruct t = do         (t', ext) <- onType t         -- Existential sizes at the top level of a type have nowhere to@@ -1643,8 +1643,8 @@  -- | Rename the sizes bound by a type (parameter names and existential -- quantifiers) to fresh names.-renameTypeBinders :: (Monoid u) => TypeBase Size u -> TermTypeM (TypeBase Size u)-renameTypeBinders (Scalar (Arrow u pn d pt (RetType dims rt))) = do+renameTypeBinders :: (Monoid o) => TypeBase Size o -> TermTypeM (TypeBase Size o)+renameTypeBinders (Scalar (Arrow o pn d pt (RetType dims rt))) = do   pt' <- renameTypeBinders pt   (pn', pn_subst) <- case pn of     Named v -> do@@ -1655,7 +1655,7 @@   let subst = pn_subst <> M.fromList (zip dims dims')       toSize v = ExpSubst $ sizeFromName (qualName v) mempty   rt' <- renameTypeBinders $ applySubst (fmap toSize . (`M.lookup` subst)) rt-  pure $ Scalar $ Arrow u pn' d pt' $ RetType dims' rt'+  pure $ Scalar $ Arrow o pn' d pt' $ RetType dims' rt' renameTypeBinders (Scalar (Record fs)) =   Scalar . Record <$> traverse renameTypeBinders fs renameTypeBinders (Scalar (Sum cs)) =@@ -1704,7 +1704,7 @@         ret' <- normTypeFully ret         pure (Just retdecl', ret')       Nothing ->-        pure (Nothing, toRes Nonunique body_t)+        pure (Nothing, toRes Nonfresh body_t)      verifyFunctionParams (Just fname) params'' @@ -1728,10 +1728,10 @@  -- | Extract all the shape names that occur in positive position -- (roughly, left side of an arrow) in a given type.-sizeNamesPos :: TypeBase Size als -> S.Set VName+sizeNamesPos :: TypeBase Size o -> S.Set VName sizeNamesPos (Scalar (Arrow _ _ _ t1 (RetType _ t2))) = onParam t1 <> sizeNamesPos t2   where-    onParam :: TypeBase Size als -> S.Set VName+    onParam :: TypeBase Size o -> S.Set VName     onParam (Scalar Arrow {}) = mempty     onParam (Scalar (Record fs)) = mconcat $ map onParam $ M.elems fs     onParam (Scalar (TypeVar _ _ targs)) = mconcat $ map onTypeArg targs@@ -1789,20 +1789,20 @@ -- @ -- bool -> ?[n].[n]bool -- @-injectExt :: [VName] -> TypeBase Size u -> RetTypeBase Size u+injectExt :: [VName] -> TypeBase Size o -> RetTypeBase Size o injectExt [] ret = RetType [] ret injectExt ext ret = RetType ext_here $ deeper ret   where     (immediate, _) = dimUses ret     (ext_here, ext_there) = partition (`S.member` immediate) ext-    deeper :: TypeBase Size u -> TypeBase Size u+    deeper :: TypeBase Size o -> TypeBase Size o     deeper (Scalar (Prim t)) = Scalar $ Prim t     deeper (Scalar (Record fs)) = Scalar $ Record $ M.map deeper fs     deeper (Scalar (Sum cs)) = Scalar $ Sum $ M.map (map deeper) cs     deeper (Scalar (Arrow als p d1 t1 (RetType t2_ext t2))) =       Scalar $ Arrow als p d1 t1 $ injectExt (nubOrd (ext_there <> t2_ext)) t2-    deeper (Scalar (TypeVar u tn targs)) =-      Scalar $ TypeVar u tn $ map deeperArg targs+    deeper (Scalar (TypeVar o tn targs)) =+      Scalar $ TypeVar o tn $ map deeperArg targs     deeper t@Array {} = t      deeperArg (TypeArgType t) = TypeArgType $ deeper t@@ -2003,9 +2003,12 @@             localChecks tparams' body'''             recursionCheck tparams' fname params''' rettype'' loc body''' +            globals <- typeSchemes             let ((body'''', updated_ret), errors) =                   Consumption.checkValDef+                    globals                     ( fname,+                      tparams',                       params''',                       body''',                       RetType dims rettype'',
src/Language/Futhark/TypeChecker/Terms/Loop.hs view
@@ -46,11 +46,11 @@   SrcLoc ->   Name ->   [VName] ->-  TypeBase Size als ->-  TermTypeM (TypeBase Size als)-someDimsFreshInType loc desc fresh t = do+  TypeBase Size o ->+  TermTypeM (TypeBase Size o)+someDimsFreshInType loc desc dims t = do   areSameSize <- getAreSame-  let freshen v = any (areSameSize v) fresh+  let freshen v = any (areSameSize v) dims   bitraverse (onDim freshen) pure t   where     onDim freshen (Var d _ _)@@ -66,14 +66,14 @@   Rigidity ->   Name ->   [VName] ->-  TypeBase Size u ->-  TermTypeM (TypeBase Size u, [VName])-freshDimsInType usage r desc fresh t = do+  TypeBase Size o ->+  TermTypeM (TypeBase Size o, [VName])+freshDimsInType usage r desc dims t = do   areSameSize <- getAreSame   second (map snd) <$> runStateT (bitraverse (onDim areSameSize) pure t) mempty   where     onDim areSameSize (Var (QualName _ d) _ _)-      | any (areSameSize d) fresh = do+      | any (areSameSize d) dims = do           prev_subst <- gets $ L.find (areSameSize d . fst)           case prev_subst of             Just (_, d') -> pure $ sizeFromName (qualName d') $ srclocOf usage@@ -88,7 +88,7 @@ -- [Loop size inference]. data DimClass   = -- | A genuinely new size: this position is variant.-    Fresh+    New   | -- | The body produces this position's initial size (the size the fresh     -- variable replaced). Either it produces that size directly (@Nothing@), or     -- it copies the /current/ size of another parameter @u@ that started at the@@ -235,7 +235,7 @@                       Just u <- sharesInitial e' d ->                         modify $ M.insert v $ Reproduces (Just u)                     | not $ v `S.member` known_before ->-                        modify $ M.insert v Fresh+                        modify $ M.insert v New                     | otherwise ->                         pure ()                   Nothing ->@@ -246,10 +246,10 @@          let classified =               execState (matchDims onDims loop_t' loopbody_t') mempty-            -- The variant sizes are the least set containing every 'Fresh'+            -- The variant sizes are the least set containing every 'New'             -- position and closed under the copies-from dependency.  See Note             -- [Loop size inference].-            seeds = S.fromList [v | (v, Fresh) <- M.toList classified]+            seeds = S.fromList [v | (v, New) <- M.toList classified]             grow vs =               vs                 <> S.fromList@@ -405,12 +405,12 @@ --         fixed, but if an array one of them receives has been resized, they --         become variant. -----       * If @d@ is a genuinely new size, then @v@ is variant (@Fresh@).+--       * If @d@ is a genuinely new size, then @v@ is variant (@New@). -- --     Variance can be mutual (in @loop (a,b) = ... in (b,a)@ each of @a@,@b@ --     copies the other's size), so we take the variant set to be the least set---     that contains every @Fresh@ position and is closed under the copies-from---     dependency. Parameters that only copy from one another, with no @Fresh@+--     that contains every @New@ position and is closed under the copies-from+--     dependency. Parameters that only copy from one another, with no @New@ --     seed feeding the cycle, are therefore never made variant -- a plain swap --     of two @[n]@ arrays keeps its precise size, while resizing one of them --     makes both existential. The variant new_dims become the loop's size
src/Language/Futhark/TypeChecker/Terms/Monad.hs view
@@ -34,6 +34,7 @@     checkTypeExpNonrigid,     lookupVar,     lookupMod,+    typeSchemes,     lookupAbsTy,      -- * Sizes@@ -176,7 +177,7 @@     termCheckExp :: ExpBase Info VName -> TermTypeM Exp,     termOuterEnv :: Env,     termTySet :: TySet,-    termTyVars :: M.Map TyVar (TypeBase () NoUniqueness),+    termTyVars :: M.Map TyVar (TypeBase () NoMode),     termImportName :: ImportName   } @@ -306,7 +307,7 @@ -- by linking instantiated sizes to them (the connection between a binder and -- its uses is erased by the unsized pass). See Note [Size Inference] in -- Language.Futhark.TypeChecker.Terms.-registerBinders :: Loc -> TypeBase Size u -> TermTypeM ()+registerBinders :: Loc -> TypeBase Size o -> TermTypeM () registerBinders loc (Scalar (Arrow _ pn _ ta (RetType _ tr))) = do   case pn of     Named pv -> constrain pv $ ParamSize loc@@ -329,35 +330,35 @@ -- with their solutions, instantiating their sizes with fresh -- (non-absorbable) size variables. See Note [Size Inference] in -- Language.Futhark.TypeChecker.Terms.-replaceTyVars :: SrcLoc -> TypeBase Size u -> TermTypeM (TypeBase Size u)+replaceTyVars :: SrcLoc -> TypeBase Size o -> TermTypeM (TypeBase Size o) replaceTyVars = replaceTyVarsWith False  -- | Like 'replaceTyVars', but the fresh sizes may be determined to -- be existential by unification, like instantiated sizes. This is -- used for holes, which adopt whatever type the context provides. -- See Note [Size Inference] in Language.Futhark.TypeChecker.Terms.-replaceTyVarsAbsorbable :: SrcLoc -> TypeBase Size u -> TermTypeM (TypeBase Size u)+replaceTyVarsAbsorbable :: SrcLoc -> TypeBase Size o -> TermTypeM (TypeBase Size o) replaceTyVarsAbsorbable = replaceTyVarsWith True -replaceTyVarsWith :: Bool -> SrcLoc -> TypeBase Size u -> TermTypeM (TypeBase Size u)+replaceTyVarsWith :: Bool -> SrcLoc -> TypeBase Size o -> TermTypeM (TypeBase Size o) replaceTyVarsWith absorbable loc orig_t = do   tyvars <- asks termTyVars   let f ::-        TypeBase Size u ->-        StateT (M.Map VName (TypeBase Size NoUniqueness)) TermTypeM (TypeBase Size u)+        TypeBase Size o ->+        StateT (M.Map VName (TypeBase Size NoMode)) TermTypeM (TypeBase Size o)       f (Scalar (Prim t)) = pure $ Scalar $ Prim t       f-        (Scalar (TypeVar u (QualName [] v) []))+        (Scalar (TypeVar o (QualName [] v) []))           | Just t <- M.lookup v tyvars = do               -- Multiple occurrences of the same type variable must               -- be given the same sizes.               seen <- get               case M.lookup v seen of-                Just t' -> pure $ second (const u) t'+                Just t' -> pure $ second (const o) t'                 Nothing -> do                   let usage = mkUsage loc "replaceTyVars"                   (t', drepl) <--                    lift $ allDimsFreshInType usage Nonrigid "dv" (second (const u) t)+                    lift $ allDimsFreshInType usage Nonrigid "dv" (second (const o) t)                   -- The sizes are instantiated sizes: 'Unlifted' unless                   -- absorbable, so they can be linked to binders of the                   -- type itself (reconstructing dependent function@@ -366,12 +367,12 @@                   lift . forM_ (M.keys drepl) $ \d ->                     constrain d $ InstSize (if absorbable then Lifted else Unlifted) usage                   lift $ registerBinders (locOf loc) t'-                  modify $ M.insert v $ second (const NoUniqueness) t'+                  modify $ M.insert v $ second (const NoMode) t'                   pure t'           | otherwise =-              pure $ Scalar (TypeVar u (QualName [] v) [])-      f (Scalar (TypeVar u qn targs)) =-        Scalar . TypeVar u qn <$> mapM onTyArg targs+              pure $ Scalar (TypeVar o (QualName [] v) [])+      f (Scalar (TypeVar o qn targs)) =+        Scalar . TypeVar o qn <$> mapM onTyArg targs         where           onTyArg (TypeArgDim e) = pure $ TypeArgDim e           onTyArg (TypeArgType t) = TypeArgType <$> f t@@ -379,12 +380,12 @@         Scalar . Record <$> traverse f fs       f (Scalar (Sum fs)) =         Scalar . Sum <$> traverse (mapM f) fs-      f (Scalar (Arrow u pname d ta (RetType ext tr))) = do+      f (Scalar (Arrow o pname d ta (RetType ext tr))) = do         ta' <- f ta         tr' <- f tr-        pure $ Scalar $ Arrow u pname d ta' $ RetType ext tr'-      f (Array u shape t) =-        arrayOfWithAliases u shape <$> f (Scalar t)+        pure $ Scalar $ Arrow o pname d ta' $ RetType ext tr'+      f (Array o shape t) =+        arrayOfWithAliases o shape <$> f (Scalar t)    evalStateT (f orig_t) mempty @@ -393,51 +394,51 @@ -- their sizes. See Note [Size Inference] in -- Language.Futhark.TypeChecker.Terms. instTyVars ::-  (Substitutable (TypeBase Size u)) =>+  (Substitutable (TypeBase Size o)) =>   SrcLoc ->   -- | The type parameters being instantiated, along with their   -- liftedness.   M.Map VName Liftedness ->-  TypeBase () u ->-  TypeBase Size u ->-  TermTypeM (TypeBase Size u)+  TypeBase () o ->+  TypeBase Size o ->+  TermTypeM (TypeBase Size o) instTyVars loc names orig_t1 orig_t2 = do   tyvars <- asks termTyVars   let f ::-        TypeBase d u ->-        TypeBase Size u ->-        StateT (M.Map VName (TypeBase Size NoUniqueness)) TermTypeM (TypeBase Size u)+        TypeBase d o ->+        TypeBase Size o ->+        StateT (M.Map VName (TypeBase Size NoMode)) TermTypeM (TypeBase Size o)       f-        (Scalar (TypeVar u (QualName [] v1) []))+        (Scalar (TypeVar o (QualName [] v1) []))         t2           | Just t <- M.lookup v1 tyvars =-              f (second (const u) t) t2+              f (second (const o) t) t2       f (Scalar (Record fs1)) (Scalar (Record fs2)) =         Scalar . Record <$> sequence (M.intersectionWith f fs1 fs2)       f (Scalar (Sum fs1)) (Scalar (Sum fs2)) =         Scalar . Sum <$> sequence (M.intersectionWith (zipWithM f) fs1 fs2)-      -- Note: uniqueness annotations are always taken from the-      -- second type, as the first (inferred) type comes from the-      -- unsized type checker, which does not track uniqueness.+      -- Note: annotations are always taken from the second type, as+      -- the first (inferred) type comes from the unsized type+      -- checker, which does not track them.       f         (Scalar (Arrow _ _ _ t1a (RetType _ t1r)))-        (Scalar (Arrow u pname d t2a (RetType ext t2r))) = do+        (Scalar (Arrow o pname d t2a (RetType ext t2r))) = do           ta <- f t1a t2a           tr <- f t1r t2r-          pure $ Scalar $ Arrow u pname d ta $ RetType ext tr+          pure $ Scalar $ Arrow o pname d ta $ RetType ext tr       f         (Array _ (Shape (_ : ds1)) t1)-        (Array u (Shape (d : ds2)) t2) =-          arrayOfWithAliases u (Shape [d])+        (Array o (Shape (d : ds2)) t2) =+          arrayOfWithAliases o (Shape [d])             <$> f (arrayOf (Shape ds1) (Scalar t1)) (arrayOf (Shape ds2) (Scalar t2))       f         (Scalar (TypeVar _ v1 targs1))-        (Scalar (TypeVar u v2 targs2))+        (Scalar (TypeVar o v2 targs2))           -- If v2 is a type parameter being instantiated, it must be           -- handled by the general case below.           | qualLeaf v2 `M.notMember` names,             length targs1 == length targs2 =-              Scalar . TypeVar u v1 <$> zipWithM g targs1 targs2+              Scalar . TypeVar o v1 <$> zipWithM g targs1 targs2           where             g (TypeArgType t1) (TypeArgType t2) =               TypeArgType <$> f t1 t2@@ -446,7 +447,7 @@         let usage = mkUsage loc "instantiation"             mkNew = fst <$> lift (allDimsFreshInType usage Nonrigid "dv" t1)         case t2 of-          Scalar (TypeVar u (QualName [] v2) [])+          Scalar (TypeVar o (QualName [] v2) [])             | Just l <- M.lookup v2 names -> do                 seen <- get                 case M.lookup v2 seen of@@ -461,7 +462,7 @@                     -- can reconstruct dependent function types by linking                     -- instantiated sizes to them.                     unless (null drepl) $ lift $ registerBinders (locOf loc) t-                    modify $ M.insert v2 $ second (const NoUniqueness) t+                    modify $ M.insert v2 $ second (const NoMode) t                     pure t                   Just t -> do                     -- Another occurrence of an already instantiated@@ -475,7 +476,7 @@                           lift $ constrain d $ CopySize c occ usage                           pure $ Var (qualName d) info dloc                         onDim d = pure d-                    second (const u) <$> bitraverse onDim pure t+                    second (const o) <$> bitraverse onDim pure t           _ -> mkNew    (t, seen) <- runStateT (f orig_t1 orig_t2) mempty@@ -495,7 +496,7 @@   SrcLoc ->   [TypeParam] ->   StructType ->-  TypeBase () NoUniqueness ->+  TypeBase () NoMode ->   TermTypeM ([VName], StructType) instTypeScheme qn loc tparams scheme_t inferred = do   (names, substs) <- fmap (unzip . catMaybes) . forM tparams $ \tparam -> do@@ -592,9 +593,43 @@       replaceTyVars loc inst_t     -- See Note [Checking recursive functions] in     -- Language.Futhark.TypeChecker.Terms.-    Just RecursiveV ->-      replaceTyVars loc inst_t+    Just RecursiveV -> do+      (ext, t) <- existentialResult <$> replaceTyVars loc inst_t+      -- The sizes are now bound by the type, so they are not size variables+      -- to be solved.+      modifyConstraints (`M.withoutKeys` S.fromList ext)+      pure t +-- | Make the sizes of the final result of a function type existential, unless+-- a parameter mentions them, and return them. Each application of the function+-- may then return a different size, as each call of a recursive function may.+existentialResult :: TypeBase Size o -> ([VName], TypeBase Size o)+existentialResult = go mempty+  where+    go :: S.Set VName -> TypeBase Size u -> ([VName], TypeBase Size u)+    go bound (Scalar (Arrow o pn d ta (RetType ext tr))) =+      let bound' = bound <> fvVars (freeInType ta)+       in case tr of+            Scalar Arrow {} ->+              Scalar . Arrow o pn d ta . RetType ext <$> go bound' tr+            _ ->+              let new = filter (`S.notMember` bound') $ S.toList $ fvVars $ freeInType tr+               in (new, Scalar $ Arrow o pn d ta $ RetType (ext <> new) tr)+    go _ t = ([], t)++-- | A pure function for looking up the type scheme of a global name. Used by+-- consumption checking to exploit parametricity; see Note [Parametric results]+-- in "Language.Futhark.TypeChecker.Consumption".+typeSchemes :: TermTypeM (QualName VName -> Maybe TypeM.BoundV)+typeSchemes = do+  scope <- asks termScope+  outer_env <- asks termOuterEnv+  pure $ \qn@(QualName _ name) ->+    case (M.lookup name . scopeVtable =<< Scope.lookupQualNameEnvMaybe id scope qn)+      `mplus` Scope.lookupOuterVal id outer_env name of+      Just (BoundV tparams t) -> Just (TypeM.BoundV tparams t)+      _ -> Nothing+ -- | Look up the liftedness of an abstract type. lookupAbsTy :: QualName VName -> TermTypeM Liftedness lookupAbsTy v | isIntrinsic (qualLeaf v) = pure Unlifted@@ -695,7 +730,7 @@ initialTermScope :: TermScope Size initialTermScope = Scope.initialTermScope id -runTermTypeM :: (ExpBase Info VName -> TermTypeM Exp) -> M.Map TyVar (TypeBase () NoUniqueness) -> TermTypeM a -> TypeM a+runTermTypeM :: (ExpBase Info VName -> TermTypeM Exp) -> M.Map TyVar (TypeBase () NoMode) -> TermTypeM a -> TypeM a runTermTypeM checker tyvars (TermTypeM m) = do   initial_scope <- (initialTermScope <>) . Scope.envToTermScopeNoVals <$> askEnv   name <- askImportName
src/Language/Futhark/TypeChecker/Terms/Pat.hs view
@@ -224,7 +224,7 @@ -- | Check and bind a @let@-pattern. bindingPat ::   [SizeBinder VName] ->-  Pat (TypeBase Size u) ->+  Pat (TypeBase Size o) ->   StructType ->   (Pat ParamType -> TermTypeM a) ->   TermTypeM a
src/Language/Futhark/TypeChecker/Terms/Scope.hs view
@@ -14,6 +14,7 @@     lookupOuterVal,     initialTermScope,     lookupQualNameEnv,+    lookupQualNameEnvMaybe,     typeParamIdent,   ) where@@ -27,7 +28,7 @@ -- | What a bound value stands for. Note that although modules are in the same -- name space, they are not value bindings. data ValBinding dim-  = BoundV [TypeParam] (TypeBase dim NoUniqueness)+  = BoundV [TypeParam] (TypeBase dim NoMode)   | OverloadedF [PrimType] [Maybe PrimType] (Maybe PrimType)   | EqualityF   | -- | A recursive function with no declared return type, currently being@@ -64,7 +65,7 @@  -- | Create a scope from a module-level environment. envToTermScope ::-  (StructType -> TypeBase dim NoUniqueness) ->+  (StructType -> TypeBase dim NoMode) ->   Env ->   TermScope dim envToTermScope onType env =@@ -94,7 +95,7 @@ -- the given size conversion. The fallback for names not found in the -- (value-free) term scope built by 'envToTermScopeNoVals'. lookupOuterVal ::-  (StructType -> TypeBase dim NoUniqueness) ->+  (StructType -> TypeBase dim NoMode) ->   Env ->   VName ->   Maybe (ValBinding dim)@@ -105,7 +106,7 @@  -- | The initial scope, containing the intrinsics. initialTermScope ::-  (StructType -> TypeBase dim NoUniqueness) ->+  (StructType -> TypeBase dim NoMode) ->   TermScope dim initialTermScope onType =   TermScope@@ -141,20 +142,32 @@ -- as this means the program should not have made it through earlier -- checks. lookupQualNameEnv ::-  (StructType -> TypeBase dim NoUniqueness) ->+  (StructType -> TypeBase dim NoMode) ->   TermScope dim ->   QualName VName ->   TermScope dim-lookupQualNameEnv _ scope (QualName [q] _)-  | isIntrinsic q = scope -- Magical intrinsic module.-lookupQualNameEnv onType scope qn@(QualName quals _) = descend scope quals+lookupQualNameEnv onType scope qn =+  fromMaybe (error $ "lookupQualNameEnv " <> show qn) $+    lookupQualNameEnvMaybe onType scope qn++-- | As 'lookupQualNameEnv', but 'Nothing' when the qualifiers do not name a+-- module in this scope. Use this when the name is merely being looked up+-- opportunistically, and so may well be one that has gone out of scope.+lookupQualNameEnvMaybe ::+  (StructType -> TypeBase dim NoMode) ->+  TermScope dim ->+  QualName VName ->+  Maybe (TermScope dim)+lookupQualNameEnvMaybe _ scope (QualName [q] _)+  | isIntrinsic q = Just scope -- Magical intrinsic module.+lookupQualNameEnvMaybe onType scope (QualName quals _) = descend scope quals   where-    descend s [] = s+    descend s [] = Just s     descend s (q : qs)       | Just (ModEnv q_env) <- M.lookup q $ scopeModTable s =           descend (envToTermScope onType q_env) qs       | otherwise =-          error $ "lookupQualNameEnv " <> show qn+          Nothing  -- | An identifier corresponding to a type parameter, for size -- parameters, which also exist as terms.
src/Language/Futhark/TypeChecker/Terms/Unsized.hs view
@@ -56,7 +56,7 @@ -- constraint solver never inspects sizes; see '()' for the shape -- representation this could use if size-aware rank inference were ever -- wired up.)-toType :: TypeBase Size u -> TypeBase () u+toType :: TypeBase Size o -> TypeBase () o toType = first (const ())  -- | Type checking happens with access to this environment.  The@@ -163,8 +163,8 @@   put s {termCounter = termCounter s + 1}   pure $ termCounter s -tyVarType :: u -> TyVar -> TypeBase dim u-tyVarType u v = Scalar $ TypeVar u (qualName v) []+tyVarType :: o -> TyVar -> TypeBase dim o+tyVarType o v = Scalar $ TypeVar o (qualName v) []  newTyVarWith :: Name -> TyVarInfo () -> TermM TyVar newTyVarWith desc info = do@@ -177,33 +177,33 @@ newTyVar :: (Located loc) => loc -> Liftedness -> Name -> TermM TyVar newTyVar loc l desc = newTyVarWith desc $ TyVarFree (locOf loc) l -newType :: (Located loc) => loc -> Liftedness -> Name -> u -> TermM (TypeBase dim u)-newType loc l desc u = tyVarType u <$> newTyVar loc l desc+newType :: (Located loc) => loc -> Liftedness -> Name -> o -> TermM (TypeBase dim o)+newType loc l desc o = tyVarType o <$> newTyVar loc l desc  -- | New type that must be allowed as an array element.-newElemType :: (Located loc) => loc -> Name -> u -> TermM (TypeBase dim u)-newElemType loc desc u = tyVarType u <$> newTyVar loc Unlifted desc+newElemType :: (Located loc) => loc -> Name -> o -> TermM (TypeBase dim o)+newElemType loc desc o = tyVarType o <$> newTyVar loc Unlifted desc  newTypeWithField :: SrcLoc -> Name -> Name -> Type -> TermM Type newTypeWithField loc desc k t =-  tyVarType NoUniqueness+  tyVarType NoMode     <$> newTyVarWith desc (TyVarRecord (locOf loc) $ M.singleton k t) -newTypeWithConstr :: SrcLoc -> Name -> u -> Name -> [TypeBase () u] -> TermM (TypeBase d u)-newTypeWithConstr loc desc u k ts =-  tyVarType u <$> newTyVarWith desc (TyVarSum (locOf loc) $ M.singleton k ts')+newTypeWithConstr :: SrcLoc -> Name -> o -> Name -> [TypeBase () o] -> TermM (TypeBase d o)+newTypeWithConstr loc desc o k ts =+  tyVarType o <$> newTyVarWith desc (TyVarSum (locOf loc) $ M.singleton k ts')   where-    ts' = map (`setUniqueness` NoUniqueness) ts+    ts' = map (`setMode` NoMode) ts -newTypeOverloaded :: SrcLoc -> Name -> [PrimType] -> TermM (TypeBase d NoUniqueness)+newTypeOverloaded :: SrcLoc -> Name -> [PrimType] -> TermM (TypeBase d NoMode) newTypeOverloaded loc name pts =-  tyVarType NoUniqueness <$> newTyVarWith name (TyVarPrim (locOf loc) pts)+  tyVarType NoMode <$> newTyVarWith name (TyVarPrim (locOf loc) pts) -newArtificial :: u -> TypeBase () u -> TermM (TypeBase Size u)-newArtificial u t = do+newArtificial :: o -> TypeBase () o -> TermM (TypeBase Size o)+newArtificial o t = do   v <- newID "artificial"-  let t' = tyVarType u v-  modify $ \s -> s {termArtificial = M.insert v (second (const NoUniqueness) t) $ termArtificial s}+  let t' = tyVarType o v+  modify $ \s -> s {termArtificial = M.insert v (second (const NoMode) t) $ termArtificial s}   pure t'  -- The AST requires annotations to be StructTypes, but the type@@ -215,42 +215,42 @@ -- Equal components (with fully known shapes) of the same annotation -- are given the same artificial variable, so that the sized type -- checker knows that they have the same sizes.-asStructType :: TypeBase () u -> TermM (TypeBase Size u)+asStructType :: TypeBase () o -> TermM (TypeBase Size o) asStructType t = evalStateT (onType t) mempty   where     onType ::-      TypeBase () u' ->-      StateT (M.Map (TypeBase () NoUniqueness) TyVar) TermM (TypeBase Size u')+      TypeBase () o' ->+      StateT (M.Map (TypeBase () NoMode) TyVar) TermM (TypeBase Size o')     onType (Scalar (Prim pt)) = pure $ Scalar $ Prim pt-    onType (Scalar (TypeVar u v [])) = pure $ Scalar $ TypeVar u v []-    onType (Scalar (Arrow u pname d t1 (RetType ext t2))) = do+    onType (Scalar (TypeVar o v [])) = pure $ Scalar $ TypeVar o v []+    onType (Scalar (Arrow o pname d t1 (RetType ext t2))) = do       t1' <- onType t1       t2' <- onType t2-      pure $ Scalar $ Arrow u pname d t1' $ RetType ext t2'+      pure $ Scalar $ Arrow o pname d t1' $ RetType ext t2'     onType (Scalar (Record fs)) =       Scalar . Record <$> traverse onType fs     onType (Scalar (Sum cs)) =       Scalar . Sum <$> traverse (mapM onType) cs-    onType t'@(Scalar (TypeVar u _ _)) = artificial u t'-    onType t'@(Array u _ _) = artificial u t'+    onType t'@(Scalar (TypeVar o _ _)) = artificial o t'+    onType t'@(Array o _ _) = artificial o t' -    artificial u t'-      | anonymousShape t' = lift $ newArtificial u t'+    artificial o t'+      | anonymousShape t' = lift $ newArtificial o t'       | otherwise = do-          let key = second (const NoUniqueness) t'+          let key = second (const NoMode) t'           seen <- get           case M.lookup key seen of-            Just v -> pure $ tyVarType u v+            Just v -> pure $ tyVarType o v             Nothing -> do               v <- lift $ newID "artificial"               lift $ modify $ \s ->                 s {termArtificial = M.insert v key $ termArtificial s}               modify $ M.insert key v-              pure $ tyVarType u v+              pure $ tyVarType o v      anonymousShape = elem () . bifoldMap (: []) (const mempty) -asType :: (Monoid u) => TypeBase Size u -> TermM (TypeBase () u)+asType :: (Monoid o) => TypeBase Size o -> TermM (TypeBase () o) asType t = do   artificial <- gets termArtificial   pure $ substTyVars (`M.lookup` artificial) (toType t)@@ -261,14 +261,14 @@ addCt :: CtTy () -> TermM () addCt ct = modify $ \s -> s {termConstraints = ct : termConstraints s} -ctEq :: Reason (CtType ()) -> TypeBase () u1 -> TypeBase () u2 -> TermM ()+ctEq :: Reason (CtType ()) -> TypeBase () o1 -> TypeBase () o2 -> TermM () ctEq reason t1 t2 =   -- As a minor optimisation, do not add constraint if the types are   -- equal.   unless (t1' == t2') $ addCt $ CtEq reason t1' t2'   where-    t1' = t1 `setUniqueness` NoUniqueness-    t2' = t2 `setUniqueness` NoUniqueness+    t1' = t1 `setMode` NoMode+    t2' = t2 `setMode` NoMode  localScope :: (TermScope () -> TermScope ()) -> TermM a -> TermM a localScope f = local $ \tenv -> tenv {termScope = f $ termScope tenv}@@ -359,7 +359,7 @@           v' <- newTyVar loc l $ nameFromText $ T.takeWhile isAscii $ nameToText $ baseName v           modify $             \s -> s {termTyInsts = TyInst (locOf loc) qn l v' : termTyInsts s}-          pure $ Just (v, (typeParamName tparam, tyVarType NoUniqueness v'))+          pure $ Just (v, (typeParamName tparam, tyVarType NoMode v'))         TypeParamDim {} ->           pure Nothing   let t' = substTyVars (`lookup` substs) t@@ -397,7 +397,7 @@     Just (OverloadedF ts pts rt) -> do       argtype <- newTypeOverloaded loc "t" ts       let (pts', rt') = instOverloaded argtype pts rt-      pure $ foldFunType (map (second $ const Observe) pts') $ RetType [] $ second (const Nonunique) rt'+      pure $ foldFunType (map (second $ const Observe) pts') $ RetType [] $ second (const Nonfresh) rt'     -- The unsized checker binds recursive functions directly (see     -- 'checkRecursive'), so it never produces a 'RecursiveV'.     Just RecursiveV ->@@ -548,7 +548,7 @@   pure $ PatConstr n (Info $ toParam Observe t) ps' loc  checkPat ::-  PatBase NoInfo VName (TypeBase Size u) ->+  PatBase NoInfo VName (TypeBase Size o) ->   (Pat ParamType -> TermM a) ->   TermM a checkPat p m =@@ -564,7 +564,7 @@       Ident (sizeName size) (Info (Scalar (Prim (Signed Int64)))) (srclocOf size)  bindLetPat ::-  PatBase NoInfo VName (TypeBase Size u) ->+  PatBase NoInfo VName (TypeBase Size o) ->   Type ->   (Pat ParamType -> TermM a) ->   TermM a@@ -633,18 +633,18 @@   pure b   where     split (Scalar (Arrow _ _ _ a (RetType _ b))) =-      pure (a, b `setUniqueness` NoUniqueness)+      pure (a, b `setMode` NoMode)     split (Array _u s t) = do       (a, b) <- split $ Scalar t       pure (arrayOf s a, arrayOf s b)     split ftype' = do-      a <- newType loc Lifted "arg" NoUniqueness-      b <- newType loc Lifted "res" Nonunique+      a <- newType loc Lifted "arg" NoMode+      b <- newType loc Lifted "res" Nonfresh       let reason = case arg of             Just arg' -> ReasonApplySplit (locOf loc) fname arg' ftype'             Nothing -> Reason $ locOf loc-      ctEq reason ftype' $ Scalar $ Arrow NoUniqueness Unnamed Observe a $ RetType [] b-      pure (a, b `setUniqueness` NoUniqueness)+      ctEq reason ftype' $ Scalar $ Arrow NoMode Unnamed Observe a $ RetType [] b+      pure (a, b `setMode` NoMode)  checkApply ::   SrcLoc ->@@ -729,20 +729,20 @@   rt :: Type <- newTypeWithField (srclocOf src) "ft" f ve_t   ctEq (Reason (locOf src)) t rt mustHaveSteps src t (UpdateStepField f : steps) ve_t = do-  ft <- newType (locOf src) Lifted "ft" NoUniqueness+  ft <- newType (locOf src) Lifted "ft" NoMode   rt :: Type <- newTypeWithField (srclocOf src) "ft" f ft   ctEq (Reason (locOf src)) t rt   mustHaveSteps src ft steps ve_t mustHaveSteps src t [UpdateStepSlice slice] ve_t = do   let num_slices = length $ filter isSlice slice-  update_elem_t <- newElemType (locOf src) "update_elem" NoUniqueness+  update_elem_t <- newElemType (locOf src) "update_elem" NoMode   ctEq (Reason (locOf src)) t $ arrayOfRank (length slice) update_elem_t   ctEq (Reason (locOf src)) ve_t $ arrayOfRank num_slices update_elem_t mustHaveSteps src t (UpdateStepSlice slice : steps) ve_t = do   let num_slices = length $ filter isSlice slice   index_tv <- newTyVar (locOf src) Unlifted "index"-  index_elem_t <- newElemType (locOf src) "index_elem" NoUniqueness-  ctEq (Reason (locOf src)) (tyVarType NoUniqueness index_tv) $ arrayOfRank num_slices index_elem_t+  index_elem_t <- newElemType (locOf src) "index_elem" NoMode+  ctEq (Reason (locOf src)) (tyVarType NoMode index_tv) $ arrayOfRank num_slices index_elem_t   ctEq (Reason (locOf src)) t $ arrayOfRank (length slice) index_elem_t   mustHaveSteps src (arrayOfRank num_slices index_elem_t) steps ve_t @@ -765,7 +765,7 @@   arg' <- require "logical negation" (Bool : anyIntType) =<< checkExp arg   pure $ Not arg' loc checkExp (Hole NoInfo loc) =-  Hole <$> (Info <$> newType loc Lifted "hole" NoUniqueness) <*> pure loc+  Hole <$> (Info <$> newType loc Lifted "hole" NoMode) <*> pure loc checkExp (Parens e loc) =   Parens <$> checkExp e <*> pure loc checkExp (TupLit es loc) =@@ -799,7 +799,7 @@   -- type variables for pathologically large arrays with   -- type-unsuffixed integers. Add some special case that handles that   -- more efficiently.-  et <- newElemType loc "et" NoUniqueness+  et <- newElemType loc "et" NoMode   es' <- forM es $ \e -> do     e' <- checkExp e     e_t <- expType e'@@ -844,7 +844,7 @@ checkExp (Constr name es NoInfo loc) = do   es' <- mapM checkExp es   es_ts <- mapM expType es'-  t <- newTypeWithConstr loc "t" NoUniqueness name es_ts+  t <- newTypeWithConstr loc "t" NoMode name es_ts   pure $ Constr name es' (Info t) loc -- checkExp (AppExp (Apply fe args loc) NoInfo) = do@@ -889,7 +889,7 @@   optype <- lookupVar loc op   e' <- checkExp e   e_t <- expType e'-  t2 <- newType loc Lifted "t" NoUniqueness+  t2 <- newType loc Lifted "t" NoMode   t2' <- asStructType t2   rt <-     checkApply@@ -909,13 +909,13 @@       ( Info (Unnamed, toParam Observe t1, Nothing),         Info (Unnamed, toParam Observe t2')       )-      (Info (RetType [] (rt' `setUniqueness` Nonunique)), Info [])+      (Info (RetType [] (rt' `setMode` Nonfresh)), Info [])       loc checkExp (OpSectionRight op _ e _ NoInfo loc) = do   optype <- lookupVar loc op   e' <- checkExp e   e_t <- expType e'-  t1 <- newType loc Lifted "t" NoUniqueness+  t1 <- newType loc Lifted "t" NoMode   t1' <- asStructType t1   rt <-     checkApply@@ -936,7 +936,7 @@       ( Info (Unnamed, toParam Observe t1'),         Info (Unnamed, toParam Observe t2, Nothing)       )-      (Info $ RetType [] (rt' `setUniqueness` Nonunique))+      (Info $ RetType [] (rt' `setMode` Nonfresh))       loc -- checkExp e@(UpdateSection steps NoInfo loc) = do@@ -944,14 +944,14 @@   -- Lifted, as a pure field projection works on records with   -- function-typed fields. Any slice steps will constrain the   -- relevant parts to be arrays (of unlifted elements) anyway.-  src_t <- newType loc Lifted "update" NoUniqueness-  ve_t <- newType loc Lifted "update_elem" NoUniqueness+  src_t <- newType loc Lifted "update" NoMode+  ve_t <- newType loc Lifted "update_elem" NoMode   mustHaveSteps e src_t steps' ve_t   ft <-     asStructType $       Scalar $         Arrow mempty Unnamed Observe src_t $-          second (const Nonunique) (RetType [] ve_t)+          second (const Nonfresh) (RetType [] ve_t)   pure $ UpdateSection steps' (Info ft) loc  --@@ -961,7 +961,7 @@      (body_t, retdecl') <- checkRetDecl body' retdecl     body_t' <- asStructType body_t-    let ret = RetType [] $ toRes Nonunique body_t'+    let ret = RetType [] $ toRes Nonfresh body_t'     pure $ Lambda params' body' retdecl' (Info ret) loc -- checkExp (AppExp (LetPat sizes pat e body loc) _) = do@@ -983,7 +983,7 @@     bindParams tparams params $ \params' -> do       e' <- checkExp e       (e_t, retdecl') <- checkRetDecl e' retdecl-      pure (tparams, params', retdecl', fmap (const Nonunique) e_t, e')+      pure (tparams, params', retdecl', fmap (const Nonfresh) e_t, e')    params'' <- mapM (traverse asType) params' @@ -1017,7 +1017,7 @@         pure e'   maybe_step' <- traverse check maybe_step   end' <- traverse check end-  range_t <- newElemType loc "range" NoUniqueness+  range_t <- newElemType loc "range" NoMode   range_t' <- asType range_t   start_t <- expType start'   ctEq (Reason (locOf start')) range_t' (arrayOfRank 1 start_t)@@ -1025,7 +1025,7 @@ -- checkExp (Project k e NoInfo loc) = do   e' <- checkExp e-  kt <- newType loc Lifted "kt" NoUniqueness+  kt <- newType loc Lifted "kt" NoMode   t <- newTypeWithField loc "t" k kt   e_t <- expType e'   ctEq (Reason (locOf e')) e_t t@@ -1048,11 +1048,11 @@   e_t <- expType e'   slice' <- checkSlice slice   index_tv <- newTyVar loc Unlifted "index"-  index_elem_t <- newElemType loc "index_elem" NoUniqueness+  index_elem_t <- newElemType loc "index_elem" NoMode   let num_slices = length $ filter isSlice slice-  ctEq (Reason (locOf loc)) (tyVarType NoUniqueness index_tv) $ arrayOfRank num_slices index_elem_t+  ctEq (Reason (locOf loc)) (tyVarType NoMode index_tv) $ arrayOfRank num_slices index_elem_t   ctEq (Reason (locOf e')) e_t $ arrayOfRank (length slice) index_elem_t-  pure $ AppExp (Index e' slice' loc) (Info $ AppRes (tyVarType NoUniqueness index_tv) [])+  pure $ AppExp (Index e' slice' loc) (Info $ AppRes (tyVarType NoMode index_tv) []) -- checkExp (AppExp (LetWith dest src steps ve body loc) _) = do   src_t <- lookupVar (srclocOf src) $ qualName $ identName src@@ -1076,7 +1076,7 @@   e2_t <- expType e2'   e3' <- checkExp e3   e3_t <- expType e3'-  if_t <- newType loc SizeLifted "if_t" NoUniqueness+  if_t <- newType loc SizeLifted "if_t" NoMode    ctEq (Reason (locOf e1')) e1_t (Scalar (Prim Bool))   ctEq (ReasonBranches (locOf loc) e2_t e3_t) e2_t if_t@@ -1090,7 +1090,7 @@   e_t <- expType e'   (cs', t) <- checkCases e_t cs -  match_t <- newType loc SizeLifted "match_t" NoUniqueness+  match_t <- newType loc SizeLifted "match_t" NoMode   ctEq (Reason (locOf loc)) match_t t    match_t' <- asStructType match_t@@ -1103,7 +1103,7 @@       -- Should have been filled out in Names       error "Unspected LoopInitImplicit"   arg_t <- expType arg'-  loop_t <- newType loc SizeLifted "loop_t" NoUniqueness+  loop_t <- newType loc SizeLifted "loop_t" NoMode   ctEq (Reason (locOf loc)) arg_t loop_t   bindLetPat pat arg_t $ \pat' -> do     (form', body') <-@@ -1122,7 +1122,7 @@           pure (While cond', body')         ForIn elemp arr -> do           arr' <- checkExp arr-          elem_t <- newElemType elemp "elem" NoUniqueness+          elem_t <- newElemType elemp "elem" NoMode           arr_t <- expType arr'           elem_t' <- asType elem_t           ctEq (Reason (locOf arr')) arr_t $ arrayOfRank 1 elem_t'@@ -1154,8 +1154,8 @@ doDefault ::   [VName] ->   VName ->-  Either [PrimType] (TypeBase () NoUniqueness) ->-  TermM (TypeBase () NoUniqueness)+  Either [PrimType] (TypeBase () NoMode) ->+  TermM (TypeBase () NoMode) doDefault tyvars_at_toplevel v (Left pts)   | [pt] <- pts =       pure $ Scalar $ Prim pt@@ -1182,14 +1182,14 @@ -- substitutions on the RHS of the substitutions afterwards. doDefaults ::   [VName] ->-  M.Map TyVar (Either [PrimType] (TypeBase () NoUniqueness)) ->-  TermM (M.Map TyVar (TypeBase () NoUniqueness))+  M.Map TyVar (Either [PrimType] (TypeBase () NoMode)) ->+  TermM (M.Map TyVar (TypeBase () NoMode)) doDefaults tyvars_at_toplevel substs = do   substs' <- M.traverseWithKey (doDefault tyvars_at_toplevel) substs   pure $ M.map (substTyVars (`M.lookup` substs')) substs'  generalise ::-  TypeBase () NoUniqueness ->+  TypeBase () NoMode ->   [UnconTyVar] ->   Solution ->   ([TypeParam], [VName])@@ -1210,8 +1210,8 @@ generaliseAndDefaults ::   [UnconTyVar] ->   Solution ->-  TypeBase () NoUniqueness ->-  TermM ([TypeParam], M.Map VName (TypeBase () NoUniqueness))+  TypeBase () NoMode ->+  TermM ([TypeParam], M.Map VName (TypeBase () NoMode)) generaliseAndDefaults unconstrained solution t = do   let (generalised, unconstrained') =         generalise t unconstrained solution@@ -1278,11 +1278,14 @@           "When instantiating type parameter of" <+> dquotes (pretty qn) <> "."  -- | Check a potentially recursive function body. The function is bound to a--- fresh monomorphic type variable while its body is checked; that variable is--- then constrained to the actual function type, and the constraint solver ties--- the knot. A parameterless binding cannot be recursive (see 'resolveValBind'),--- so it is checked with no self-reference in scope. See Note [Checking recursive--- functions] in Language.Futhark.TypeChecker.Terms.+-- monomorphic type with its actual parameters, which are known, and a fresh+-- type variable as its return type; that variable is then constrained to the+-- type of the body, and the constraint solver ties the knot. The parameters must+-- be known up front, as unification would otherwise give the function the diets+-- of its first recursive application. A parameterless binding cannot be+-- recursive (see 'resolveValBind'), so it is checked with no self-reference in+-- scope. See Note [Checking recursive functions] in+-- Language.Futhark.TypeChecker.Terms. checkRecursive ::   VName ->   SrcLoc ->@@ -1291,24 +1294,21 @@   TermM (ExpBase Info VName) checkRecursive _ _ [] body = checkExp body checkRecursive fname loc params' body = do-  ftype <- newType loc Lifted (baseName fname) NoUniqueness-  let bindF scope =+  ret <- newType loc Lifted (baseName fname) Nonfresh+  let ftype = foldFunType (map (first (const ()) . patternType) params') (RetType [] ret)+      bindF scope =         scope {scopeVtable = M.insert fname (BoundV [] ftype) $ scopeVtable scope}   body' <- localScope bindF $ checkExp body   body_t <- expType body'-  let fun_t =-        foldFunType-          (map (first (const ()) . patternType) params')-          (RetType [] $ bimap (const ()) (const Nonunique) body_t)-  ctEq (Reason (locOf loc)) ftype fun_t+  ctEq (Reason (locOf loc)) (toStruct ret) (bimap (const ()) (const NoMode) body_t)   pure body'  -- | Replace artificial variables with the types they denote, so that no -- artificial variable leaks into the result. onArtificial ::-  M.Map TyVar (TypeBase () NoUniqueness) ->-  M.Map TyVar (TypeBase () NoUniqueness) ->-  M.Map TyVar (TypeBase () NoUniqueness)+  M.Map TyVar (TypeBase () NoMode) ->+  M.Map TyVar (TypeBase () NoMode) ->+  M.Map TyVar (TypeBase () NoMode) onArtificial artificial solution =   M.map (substTyVars (`M.lookup` solution) . first (const ())) artificial     <> solution@@ -1323,7 +1323,7 @@     SrcLoc   ) ->   TypeM-    ( Either TypeError ([TypeParam], M.Map TyVar (TypeBase () NoUniqueness)),+    ( Either TypeError ([TypeParam], M.Map TyVar (TypeBase () NoMode)),       [Pat ParamType],       Maybe (TypeExp Exp VName),       Exp@@ -1353,7 +1353,7 @@       let fun_t =             foldFunType               (map (first (const ()) . patternType) params')-              (RetType [] $ bimap (const ()) (const Nonunique) body_t)+              (RetType [] $ bimap (const ()) (const Nonfresh) body_t)       generaliseAndDefaults unconstrained solution fun_t  -- | Type check a single expression, which may have a polymorphic@@ -1361,7 +1361,7 @@ checkSingleExp ::   ExpBase NoInfo VName ->   TypeM-    ( Either TypeError ([TypeParam], M.Map TyVar (TypeBase () NoUniqueness)),+    ( Either TypeError ([TypeParam], M.Map TyVar (TypeBase () NoMode)),       Exp     ) checkSingleExp e = runTermM $ do@@ -1386,7 +1386,7 @@ checkSizeExp ::   ExpBase NoInfo VName ->   TypeM-    ( Either TypeError ([UnconTyVar], M.Map TyVar (TypeBase () NoUniqueness)),+    ( Either TypeError ([UnconTyVar], M.Map TyVar (TypeBase () NoMode)),       Exp     ) checkSizeExp e = runTermM $ do
src/Language/Futhark/TypeChecker/TySolve.hs view
@@ -24,7 +24,7 @@ import Language.Futhark.TypeChecker.UnionFind  -- | The type representation used by the constraint solver. Agnostic--- to sizes and uniqueness.+-- to sizes and freshness. type Type = CtType ()  type UF s = M.Map TyVar (TyVarNode s)@@ -39,7 +39,7 @@ -- | A solution maps a type variable to its substitution. This -- substitution is complete, in the sense there are no right-hand -- sides that contain a type variable.-type Solution = M.Map TyVar (Either [PrimType] (TypeBase () NoUniqueness))+type Solution = M.Map TyVar (Either [PrimType] (TypeBase () NoMode))  -- | An unconstrained type variable comprises a name and (ironically) -- a constraint on how it can be instantiated.@@ -73,7 +73,7 @@ typeError loc notes msg =   throwError $ TypeError loc notes msg -typeVar :: (Monoid u) => VName -> TypeBase dim u+typeVar :: (Monoid o) => VName -> TypeBase dim o typeVar v = Scalar $ TypeVar mempty (qualName v) []  cannotUnify ::@@ -179,8 +179,8 @@       filter (`notElem` M.keys cs1) (M.keys cs2)         ++ filter (`notElem` M.keys cs2) (M.keys cs1) -substTyVars :: (Monoid u) => TypeBase () u -> SolveM s (TypeBase () u)-substTyVars (Scalar (TypeVar u qn args)) = do+substTyVars :: (Monoid o) => TypeBase () o -> SolveM s (TypeBase () o)+substTyVars (Scalar (TypeVar o qn args)) = do   mb_node <- maybeLookupUF $ qualLeaf qn   case mb_node of     Just node -> do@@ -195,7 +195,7 @@   where     makeTyVar qn' = do       args' <- mapM onArg args-      pure $ Scalar $ TypeVar u qn' args'+      pure $ Scalar $ TypeVar o qn' args'     onArg (TypeArgType t) = TypeArgType <$> substTyVars t     onArg d@(TypeArgDim _) = pure d substTyVars p@(Scalar (Prim _)) = pure p@@ -203,17 +203,17 @@   Scalar . Record <$> traverse substTyVars fs substTyVars (Scalar (Sum cs)) =   Scalar . Sum <$> traverse (mapM substTyVars) cs-substTyVars (Scalar (Arrow u pname d t1 (RetType ext t2))) = do+substTyVars (Scalar (Arrow o pname d t1 (RetType ext t2))) = do   t1' <- substTyVars t1   t2' <- substTyVars t2   pure $     Scalar $-      Arrow u pname d t1' $+      Arrow o pname d t1' $         RetType ext $-          t2' `setUniqueness` uniqueness t2-substTyVars (Array u shape elemt) = do+          t2' `setMode` freshness t2+substTyVars (Array o shape elemt) = do   elemt' <- substTyVars $ Scalar elemt-  pure $ arrayOfWithAliases u shape elemt'+  pure $ arrayOfWithAliases o shape elemt'  occursCheck :: Reason Type -> VName -> VName -> Type -> SolveM s () occursCheck reason v k tp = do@@ -314,7 +314,7 @@             _ -> Nothing         Nothing -> pure Nothing -    normalize :: TypeBase () NoUniqueness -> SolveM s (TypeBase () NoUniqueness)+    normalize :: TypeBase () NoMode -> SolveM s (TypeBase () NoMode)     normalize t@(Scalar (TypeVar _ (QualName [] v) [])) = do       uf <- asks solverTyVars       case M.lookup v uf of@@ -382,8 +382,8 @@   (Scalar (Arrow _ _ _ t2a (RetType _ t2r))) =     Right [(mempty, (t1a, t2a)), (mempty, (t1r', t2r'))]     where-      t1r' = t1r `setUniqueness` NoUniqueness-      t2r' = t2r `setUniqueness` NoUniqueness+      t1r' = t1r `setMode` NoMode+      t2r' = t2r `setMode` NoMode unify (Scalar (Record fs1)) (Scalar (Record fs2))   | M.keys fs1 == M.keys fs2 =       Right $@@ -736,7 +736,7 @@     resolve ::       TyVar ->       TyVarNode s ->-      SolveM s (Either [PrimType] (TypeBase () NoUniqueness), Maybe Liftedness)+      SolveM s (Either [PrimType] (TypeBase () NoMode), Maybe Liftedness)     resolve tv node = do       sol <- getSol' node       case sol of@@ -757,7 +757,7 @@      unconstr ::       TyVar ->-      (Either [PrimType] (TypeBase () NoUniqueness), Maybe Liftedness) ->+      (Either [PrimType] (TypeBase () NoMode), Maybe Liftedness) ->       [UnconTyVar] ->       [UnconTyVar]     unconstr tv (_, Just l) acc = (tv, l) : acc@@ -765,8 +765,8 @@      mkSubst ::       TyVar ->-      (Either [PrimType] (TypeBase () NoUniqueness), Maybe Liftedness) ->-      Maybe (Either [PrimType] (TypeBase () NoUniqueness))+      (Either [PrimType] (TypeBase () NoMode), Maybe Liftedness) ->+      Maybe (Either [PrimType] (TypeBase () NoMode))     mkSubst _ (_, Just _) = Nothing     mkSubst tv (s@(Right (Scalar (TypeVar _ (QualName [] tv') _))), _) =       if tv /= tv' then Just s else Nothing
src/Language/Futhark/TypeChecker/Types.hs view
@@ -91,7 +91,7 @@   m (TypeExp Exp VName, [VName], ResRetType, Liftedness) evalTypeExp _ (TEVar name loc) = do   (ps, t, l) <- lookupType name-  t' <- renameRetType $ toResRet Nonunique t+  t' <- renameRetType $ toResRet Nonfresh t   case ps of     [] -> pure (TEVar name loc, [], t', l)     _ ->@@ -137,7 +137,7 @@ evalTypeExp df (TEArray d t loc) = do   (d_svars, d', d'') <- checkSizeExp d   (t', svars, RetType dims st, l) <- evalTypeExp df t-  case (l, arrayOfWithAliases Nonunique (Shape [d'']) st) of+  case (l, arrayOfWithAliases Nonfresh (Shape [d'']) st) of     (Unlifted, st') ->       pure         ( TEArray d' t' loc,@@ -163,12 +163,12 @@       e' <- df e       pure ([], SizeExp e' dloc, e') ---evalTypeExp df (TEUnique t loc) = do+evalTypeExp df (TEStar t loc) = do   (t', svars, RetType dims st, l) <- evalTypeExp df t   unless (mayContainArray st) $     warn loc $-      "Declaring" <+> dquotes (pretty st) <+> "as unique has no effect."-  pure (TEUnique t' loc, svars, RetType dims $ st `setUniqueness` Unique, l)+      "The star in" <+> dquotes (pretty st) <+> "has no effect."+  pure (TEStar t' loc, svars, RetType dims $ st `setMode` Fresh, l)   where     mayContainArray (Scalar Prim {}) = False     mayContainArray Array {} = True@@ -184,7 +184,7 @@     pure       ( TEArrow (Just v) t1' t2' loc,         svars1 ++ dims1 ++ svars2,-        RetType [] $ Scalar $ Arrow Nonunique (Named v) (diet $ resToParam st1) (toStruct st1) (RetType dims2 st2),+        RetType [] $ Scalar $ Arrow Nonfresh (Named v) (diet $ resToParam st1) (toStruct st1) (RetType dims2 st2),         Lifted       ) --@@ -195,7 +195,7 @@     ( TEArrow Nothing t1' t2' loc,       svars1 ++ dims1 ++ svars2,       RetType [] . Scalar $-        Arrow Nonunique Unnamed (diet $ resToParam st1) (toStruct st1) $+        Arrow Nonfresh Unnamed (diet $ resToParam st1) (toStruct st1) $           RetType dims2 st2,       Lifted     )@@ -248,7 +248,7 @@ evalTypeExp df ote@TEApply {} = do   (tname, tname_loc, targs) <- rootAndArgs ote   (ps, tname_t, l) <- lookupType tname-  RetType t_dims t <- renameRetType $ toResRet Nonunique tname_t+  RetType t_dims t <- renameRetType $ toResRet Nonfresh tname_t   if length ps /= length targs     then       typeError tloc mempty $@@ -363,14 +363,14 @@ class Substitutable a where   applySubst :: TypeSubs -> a -> a -instance Substitutable (RetTypeBase Size Uniqueness) where+instance Substitutable (RetTypeBase Size Freshness) where   applySubst f (RetType dims t) =     let RetType more_dims t' = substTypesRet f' t      in RetType (dims ++ more_dims) t'     where       f' = fmap (fmap (second (const mempty))) . f -instance Substitutable (RetTypeBase Size NoUniqueness) where+instance Substitutable (RetTypeBase Size NoMode) where   applySubst f (RetType dims t) =     let RetType more_dims t' = substTypesRet f t      in RetType (dims ++ more_dims) t'@@ -381,8 +381,8 @@ instance Substitutable ParamType where   applySubst f = substTypesAny $ fmap (fmap $ second $ const Observe) . f -instance Substitutable (TypeBase Size Uniqueness) where-  applySubst f = substTypesAny $ fmap (fmap $ second $ const Nonunique) . f+instance Substitutable (TypeBase Size Freshness) where+  applySubst f = substTypesAny $ fmap (fmap $ second $ const Nonfresh) . f  instance Substitutable Exp where   applySubst f = runIdentity . mapOnExp@@ -428,11 +428,11 @@           }  applyType ::-  (Monoid u) =>+  (Monoid o) =>   [TypeParam] ->-  TypeBase Size u ->+  TypeBase Size o ->   [StructTypeArg] ->-  TypeBase Size u+  TypeBase Size o applyType ps t args = substTypesAny (`M.lookup` substs) t   where     substs = M.fromList $ zipWith mkSubst ps args@@ -454,9 +454,9 @@ -- outermost non-null existential sizes is done only when type -- checking modules and monomorphising. freshDims ::-  (Monoid as) =>-  RetTypeBase Size as ->-  State [VName] (RetTypeBase Size as)+  (Monoid o) =>+  RetTypeBase Size o ->+  State [VName] (RetTypeBase Size o) freshDims (RetType [] t) = pure $ RetType [] t freshDims (RetType ext t) = do   seen_ext <- get@@ -471,10 +471,10 @@       pure $ RetType ext' t'  substTypesRet ::-  (Monoid u) =>-  (VName -> Maybe (Subst (RetTypeBase Size u))) ->-  TypeBase Size u ->-  RetTypeBase Size u+  (Monoid o) =>+  (VName -> Maybe (Subst (RetTypeBase Size o))) ->+  TypeBase Size o ->+  RetTypeBase Size o substTypesRet lookupSubst ot =   let (t', dims) = runState (onType ot) []    in RetType dims (fromMaybe ot t')@@ -484,45 +484,45 @@     -- rather than reconstructed. 'fromMaybe' at each level splices in     -- the original subterm for unchanged children.     onType ::-      forall as.-      (Monoid as) =>-      TypeBase Size as ->-      State [VName] (Maybe (TypeBase Size as))+      forall o.+      (Monoid o) =>+      TypeBase Size o ->+      State [VName] (Maybe (TypeBase Size o)) -    onType (Array u shape et) = do+    onType (Array o shape et) = do       et' <- onType (Scalar et)       let shape' = onShape shape       pure $ case (shape', et') of         (Nothing, Nothing) -> Nothing         _ ->           Just $-            arrayOfWithAliases u (fromMaybe shape shape') (fromMaybe (Scalar et) et')+            arrayOfWithAliases o (fromMaybe shape shape') (fromMaybe (Scalar et) et')     onType (Scalar (Prim _)) = pure Nothing-    onType (Scalar (TypeVar u v targs)) = do+    onType (Scalar (TypeVar o v targs)) = do       targs' <- mapM subsTypeArg targs       case lookupSubst $ qualLeaf v of         Just (Subst ps rt) -> do           RetType ext t <- freshDims rt           modify (ext ++)           let targs'' = zipWith fromMaybe targs targs'-          pure $ Just $ second (<> u) $ applyType ps (second (const u) t) targs''+          pure $ Just $ second (<> o) $ applyType ps (second (const o) t) targs''         _ ->           pure $             if all isNothing targs'               then Nothing-              else Just $ Scalar $ TypeVar u v (zipWith fromMaybe targs targs')+              else Just $ Scalar $ TypeVar o v (zipWith fromMaybe targs targs')     onType (Scalar (Record ts)) = do       ts' <- traverse onType ts       pure $         if all isNothing ts'           then Nothing           else Just $ Scalar $ Record $ M.intersectionWith fromMaybe ts ts'-    onType (Scalar (Arrow u v d t1 t2)) = do+    onType (Scalar (Arrow o v d t1 t2)) = do       t1' <- onType t1       t2' <- onRetType t2       pure $ case (t1', t2') of         (Nothing, Nothing) -> Nothing-        _ -> Just $ Scalar $ Arrow u v d (fromMaybe t1 t1') (fromMaybe t2 t2')+        _ -> Just $ Scalar $ Arrow o v d (fromMaybe t1 t1') (fromMaybe t2 t2')     onType (Scalar (Sum ts)) = do       ts' <- traverse (traverse onType) ts       pure $@@ -566,15 +566,15 @@     onSize (Var {}) = Nothing     onSize e = Just $ applySubst lookupSubst' e -    lookupSubst' = fmap (fmap $ second (const NoUniqueness)) . lookupSubst+    lookupSubst' = fmap (fmap $ second (const NoMode)) . lookupSubst  -- | Perform substitutions, from type names to types, on a type. Works--- regardless of what shape and uniqueness information is attached to the type.+-- regardless of what shape and freshness information is attached to the type. substTypesAny ::-  (Monoid u) =>-  (VName -> Maybe (Subst (RetTypeBase Size u))) ->-  TypeBase Size u ->-  TypeBase Size u+  (Monoid o) =>+  (VName -> Maybe (Subst (RetTypeBase Size o))) ->+  TypeBase Size o ->+  TypeBase Size o substTypesAny lookupSubst ot =   case substTypesRet lookupSubst ot of     RetType [] ot' -> ot'@@ -590,24 +590,24 @@        in first toAny ot'  -- | Substitution without caring about sizes.-substTyVars :: (Monoid u) => (VName -> Maybe (TypeBase d NoUniqueness)) -> TypeBase d u -> TypeBase d u-substTyVars f (Scalar (TypeVar u qn args)) =+substTyVars :: (Monoid o) => (VName -> Maybe (TypeBase d NoMode)) -> TypeBase d o -> TypeBase d o+substTyVars f (Scalar (TypeVar o qn args)) =   case f $ qualLeaf qn of     Just t' -> second (const mempty) $ substTyVars f t'-    Nothing -> Scalar (TypeVar u qn (map onArg args))+    Nothing -> Scalar (TypeVar o qn (map onArg args))       where         onArg (TypeArgType t) = TypeArgType $ substTyVars f t         onArg (TypeArgDim e) = TypeArgDim e substTyVars _ (Scalar (Prim pt)) = Scalar $ Prim pt substTyVars f (Scalar (Record fs)) = Scalar $ Record $ M.map (substTyVars f) fs substTyVars f (Scalar (Sum cs)) = Scalar $ Sum $ M.map (map $ substTyVars f) cs-substTyVars f (Scalar (Arrow u pname d t1 (RetType ext t2))) =+substTyVars f (Scalar (Arrow o pname d t1 (RetType ext t2))) =   Scalar $-    Arrow u pname d (substTyVars f t1) $+    Arrow o pname d (substTyVars f t1) $       RetType ext $-        substTyVars f t2 `setUniqueness` uniqueness t2-substTyVars f (Array u shape elemt) =-  arrayOfWithAliases u shape $ substTyVars f $ Scalar elemt+        substTyVars f t2 `setMode` freshness t2+substTyVars f (Array o shape elemt) =+  arrayOfWithAliases o shape $ substTyVars f $ Scalar elemt  -- Note [AnySize] --
src/Language/Futhark/TypeChecker/Unify.hs view
@@ -324,7 +324,7 @@        -- The types are structurally identical, as this has already       -- been verified by the unsized type checker - we are here only-      -- to unify their sizes (and check consumption and uniqueness+      -- to unify their sizes (and check consumption and freshness       -- for functions). The 'failure' cases can be reached when the       -- types contain distinct abstract types that the unsized       -- checking could not distinguish, and serve as a backstop for@@ -362,13 +362,13 @@                     </> "and"                     </> indent 2 (pretty d2 <> pretty a2)                     </> "are incompatible regarding consuming their arguments."-            | uncurry (<) $ swap ord (uniqueness b2) (uniqueness b1) -> do+            | uncurry (<) $ swap ord (freshness b2) (freshness b1) -> do                 unifyError usage mempty bcs $                   "Return types"                     </> indent 2 (pretty b1)                     </> "and"                     </> indent 2 (pretty b2)-                    </> "have incompatible uniqueness."+                    </> "have incompatible freshness."             | otherwise -> do                 -- Introduce the existentials as size variables so they                 -- are subject to unification.  We will remove them again@@ -744,8 +744,8 @@   Usage ->   Rigidity ->   Name ->-  TypeBase d als ->-  m (TypeBase Size als, M.Map VName d)+  TypeBase d o ->+  m (TypeBase Size o, M.Map VName d) allDimsFreshInType usage r desc t =   runStateT (bitraverse onDim pure t) mempty   where