futhark 0.25.23 → 0.25.24

raw patch · 68 files changed

+2518/−924 lines, 68 filesdep +asyncdep ~futhark-serverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async

Dependency ranges changed: futhark-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−0
• docs/conf.py +7/−0
• docs/index.rst +1/−0
• docs/man/futhark-fmt.rst +39/−0
• docs/man/futhark-ispc.rst +9/−0
• docs/man/futhark-profile.rst +4/−1
• futhark.cabal +6/−3
• prelude/ad.fut +96/−7
• prelude/array.fut +28/−28
• prelude/functional.fut +1/−2
• prelude/math.fut +299/−268
• prelude/soacs.fut +27/−26
• prelude/zip.fut +17/−18
• src/Futhark/AD/Derivatives.hs +4/−1
• src/Futhark/Analysis/PrimExp.hs +2/−2
• src/Futhark/CLI/Bench.hs +12/−6
• src/Futhark/CLI/Dev.hs +3/−1
• src/Futhark/CLI/Doc.hs +51/−52
• src/Futhark/CLI/Fmt.hs +29/−0
• src/Futhark/CLI/Main.hs +3/−1
• src/Futhark/CLI/Profile.hs +20/−18
• src/Futhark/CLI/REPL.hs +16/−4
• src/Futhark/CLI/Test.hs +15/−8
• src/Futhark/CodeGen/Backends/GenericC/Code.hs +6/−3
• src/Futhark/CodeGen/Backends/GenericC/Pretty.hs +8/−5
• src/Futhark/CodeGen/Backends/GenericPython.hs +2/−1
• src/Futhark/CodeGen/Backends/MulticoreISPC.hs +4/−2
• src/Futhark/CodeGen/ImpGen.hs +0/−1
• src/Futhark/Doc/Generator.hs +202/−173
• src/Futhark/Fmt/Monad.hs +481/−0
• src/Futhark/Fmt/Printer.hs +619/−0
• src/Futhark/IR/Prop/Aliases.hs +14/−4
• src/Futhark/IR/Syntax.hs +3/−1
• src/Futhark/Internalise.hs +4/−4
• src/Futhark/Internalise/Bindings.hs +1/−1
• src/Futhark/Internalise/Defunctionalise.hs +14/−11
• src/Futhark/Internalise/Entry.hs +4/−3
• src/Futhark/Internalise/Exps.hs +27/−32
• src/Futhark/Internalise/FullNormalise.hs +4/−4
• src/Futhark/Internalise/LiftLambdas.hs +2/−2
• src/Futhark/Internalise/Monomorphise.hs +5/−5
• src/Futhark/Internalise/ReplaceRecords.hs +111/−45
• src/Futhark/Optimise/ArrayLayout/Layout.hs +1/−1
• src/Futhark/Optimise/InliningDeadFun.hs +1/−1
• src/Futhark/Optimise/Simplify/Engine.hs +2/−2
• src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +1/−1
• src/Futhark/Optimise/Simplify/Rules/Index.hs +2/−0
• src/Futhark/Optimise/Simplify/Rules/Match.hs +2/−2
• src/Futhark/Optimise/Simplify/Rules/Simple.hs +7/−7
• src/Futhark/Test/Spec.hs +20/−16
• src/Futhark/Util/Pretty.hs +6/−4
• src/Language/Futhark/Core.hs +3/−0
• src/Language/Futhark/FreeVars.hs +2/−2
• src/Language/Futhark/Interpreter.hs +27/−21
• src/Language/Futhark/Parser/Monad.hs +0/−14
• src/Language/Futhark/Parser/Parser.y +39/−30
• src/Language/Futhark/Pretty.hs +9/−5
• src/Language/Futhark/Primitive.hs +20/−7
• src/Language/Futhark/Prop.hs +16/−7
• src/Language/Futhark/Syntax.hs +38/−9
• src/Language/Futhark/Traversals.hs +16/−6
• src/Language/Futhark/TypeChecker/Consumption.hs +19/−11
• src/Language/Futhark/TypeChecker/Match.hs +2/−1
• src/Language/Futhark/TypeChecker/Names.hs +24/−4
• src/Language/Futhark/TypeChecker/Terms.hs +10/−10
• src/Language/Futhark/TypeChecker/Terms/Loop.hs +13/−9
• src/Language/Futhark/TypeChecker/Terms/Pat.hs +11/−10
• src/Language/Futhark/TypeChecker/Types.hs +3/−1

@@ -5,6 +5,30 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [0.25.24]++### Added++* `futhark doc` now produces better (and stable) anchor IDs.++* `futhark profile` now supports multiple JSON files.++* `futhark fmt`, by William Due and Therese Lyngby.++* Lambdas can now be passed as the last argument to a function application.++### Fixed++* Negation of floating-point positive zero now produces a negative+  zero.++* Necessary inlining of functions used inside AD constructs.++* A compile time regression for programs that used higher order+  functions very aggressively.++* Uniqueness bug related to slice simplification.+ ## [0.25.23]  ### Added

@@ -510,6 +510,13 @@         [],         1,     ),+    (+        "man/futhark-fmt",+        "futhark-fmt",+        "format Futhark programs",+        [],+        1,+    ),     ("man/futhark-pkg", "futhark-pkg", "manage Futhark packages", [], 1),     (         "man/futhark-literate",

@@ -51,6 +51,7 @@    man/futhark-cuda.rst    man/futhark-dataset.rst    man/futhark-doc.rst+   man/futhark-fmt.rst    man/futhark-hip.rst    man/futhark-ispc.rst    man/futhark-literate.rst

@@ -0,0 +1,39 @@+.. role:: ref(emphasis)++.. _futhark-fmt(1):++===========+futhark-fmt+===========++SYNOPSIS+========++futhark fmt [FILES]++DESCRIPTION+===========++Reformat the given Futhark programs. If no files are provided, read+Futhark program on stdin and produce formatted output on stdout. If+stdout is a terminal, the output will be syntax highlighted.++In contrast to many other automatic formatters, the formatting is+somewhat sensitive to the formatting of the input program. In+particular, single-line expressions will usually be kept on a single+line, even if they are very long. To force ``futhark fmt`` to break+these, insert a linebreak at an arbitrary location.++OPTIONS+=======++-h+  Print help text to standard output and exit.++-V+  Print version information on standard output and exit.++SEE ALSO+========++:ref:`futhark-doc(1)`

@@ -49,6 +49,15 @@ Generated executables accept the same options as those generated by :ref:`futhark-multicore(1)`. +LIBRARY USAGE+=============++When compiling a program ``foo.fut`` with ``futhark ispc --library``,+a ``foo.kernels.ispc`` file is produced that must be compiled with+``ispc`` and linked with the final program. For example::++  $ ispc -o foo.kernels.o foo.kernels.ispc --addressing=64 --pic --woff -O3+ BUGS ==== 

@@ -9,7 +9,7 @@ SYNOPSIS ======== -futhark profile JSONFILE+futhark profile JSONFILES  DESCRIPTION ===========@@ -39,6 +39,9 @@ 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).++You can pass multiple JSON files to ``futhark profile``. Each will+produce a distinct top level directory.  Files produced --------------

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:           futhark-version:        0.25.23+version:        0.25.24 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -156,6 +156,7 @@       Futhark.CLI.Dev       Futhark.CLI.Doc       Futhark.CLI.Eval+      Futhark.CLI.Fmt       Futhark.CLI.HIP       Futhark.CLI.Literate       Futhark.CLI.LSP@@ -243,6 +244,8 @@       Futhark.Construct       Futhark.Doc.Generator       Futhark.Error+      Futhark.Fmt.Printer+      Futhark.Fmt.Monad       Futhark.FreshNames       Futhark.Format       Futhark.IR@@ -440,6 +443,7 @@       aeson >=2.0.0.0     , ansi-terminal >=0.6.3.1     , array >=0.4+    , async >=2.0     , base >=4.15 && <5     , base16-bytestring     , binary >=0.8.3@@ -460,7 +464,7 @@     , filepath >=1.4.1.1     , free >=5.1.10     , futhark-data >= 1.1.1.0-    , futhark-server >= 1.2.2.1+    , futhark-server >= 1.2.3.0     , futhark-manifest >= 1.5.0.0     , githash >=0.1.6.1     , half >= 0.3@@ -533,7 +537,6 @@       Language.Futhark.SyntaxTests       Language.Futhark.TypeChecker.TypesTests       Language.Futhark.TypeCheckerTests-      Paths_futhark   build-depends:       QuickCheck >=2.8       , mtl >=2.2.1

@@ -1,23 +1,112 @@ -- | Definitions related to automatic differentiation. ----- **Warning:** This is an experimental feature.  It has several known--- bugs.  Documentation is very sparse.  You probably don't want to--- use this unless you have the soul of a hero.+-- Futhark supports a fairly complete facility for computing+-- derivatives of functions through automatic differentiation (AD).+-- The following does not constitute a full introduction to AD, which+-- is a substantial topic by itself, but rather introduces enough+-- concepts to describe Futhark's functional AD interface. AD is a+-- program transformation that is implemented in the compiler itself,+-- but the user interface is a handful of fairly simple functions.+--+-- AD is useful when optimising cost functions, and for any other+-- purpose where you might need derivatives, such as for example+-- computing surface normals for signed distance functions.+--+-- ## Jacobians+--+-- For a differentiable function *f* whose input comprise *n* scalars+-- and whose output comprises *m* scalars, the+-- [Jacobian](https://en.wikipedia.org/wiki/Jacobian_matrix_and_determinant)+-- for a given input point is an *m* by *n* matrix of scalars that+-- each represent a [partial+-- derivatives](https://en.wikipedia.org/wiki/Partial_derivative).+-- Intuitively, position *(i,j)* of the Jacobian describes how+-- sensitive output *i* is to input *j*. The notion of Jacobian+-- generalises to functions that accept or produce compound structures+-- such as arrays, records, sums, and so on, simply by "flattening+-- out" the values and considering only their constituent scalars.+--+-- Computing the full Jacobian is usually costly and sometimes not+-- necessary, and it is not part of the AD facility provided by+-- Futhark. Instead it is possible to parts of the Jacobian.+--+-- We can take the product of an an *m* by *n* Jacobian with an+-- *n*-element *tangent vector* to produce an *m*-element vector+-- (*Jacobian-vector product*). Such a product can be computed in a+-- single (augmented) execution of the function *f*, and by choosing+-- the tangent vector appropriately we can use this to compute the+-- full Jacobian. This is provided by the function `jvp`.+--+-- We can also take the product of an *m*-element vector *cotangent+-- vector* with the *m* by *n* Jacobian to produce an *n*-element+-- vector (*Vector-Jacobian product*). This too can be computed in a+-- single execution of *f*, with `vjp`.+--+-- We can use the `jvp` function to produce a *column* of the full+-- Jacobian, and `vjp` to produce a *row*. Which is superior for a+-- given situation depends on whether the function has more inputs or+-- outputs.+--+-- You can freely nest `vjp` and `jvp` to compute higher-order+-- derivatives.+--+-- ## Efficiency+--+-- Both `jvp` and `vjp` work by transforming the program to carry+-- along extra information associated with each scalar value.+--+-- In the case of `vjp`, this extra information takes the form of an+-- additional scalar representing the tangent, which is then+-- propagated in each scalar computation using essentially the [chain+-- rule](https://en.wikipedia.org/wiki/Chain_rule). Therefore, `jvp`+-- has a memory overhead of approximately *2x*, and a computational+-- overhead of slightly more, but usually less than *4x*.+--+-- In the case of `jvp`, since our starting point is a *cotangent*,+-- the function is essentially first run forward, then backwards (the+-- *return sweep*) to propagate the cotangent. During the return+-- sweep, all intermediate results computed during the forward sweep+-- must still be available, and must therefore be stored in memory+-- during the forward sweep. This means that the memory usage of `jvp`+-- is essentially proportional to the number of sequential steps of+-- the original function (essentially turning *time* into *space*).+-- The compiler does a nontrivial amount of optimisation to ameliorate+-- this overhead (see [AD for an Array Language with Nested+-- Parallelism](https://futhark-lang.org/publications/sc22-ad.pdf)),+-- but it can still be substantial for programs with deep sequential+-- loops.+--+-- ## Differentiable functions+--+-- AD only gives meaningful results for differentiable functions. The+-- Futhark type system does not distinguish differentiable or+-- non-differentiable operations. As a rule of thumb, a function is+-- differentiable if its results are computed using a composition of+-- primitive floating-point operations, without ever converting to or+-- from integers.+--+-- ## Limitations+--+-- `jvp` is expected to work in all cases. `vjp` has limitations when+-- using the GPU backends similar to those for irregular flattening.+-- Specifically, you should avoid structures with variant sizes, such+-- as loops that carry an array that changes size through the+-- execution of the loop.  -- | Jacobian-Vector Product ("forward mode"), producing also the -- primal result as the first element of the result tuple.-let 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.-let 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-Vector Product ("forward mode").-let 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").-let 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

@@ -25,31 +25,31 @@ -- -- **Complexity:** O(1). #[inline]-def last [n] 't (x: [n]t) = x[n-1]+def last [n] 't (x: [n]t) = x[n - 1]  -- | Everything but the first element of the array. -- -- **Complexity:** O(1). #[inline]-def tail [n] 't (x: [n]t): [n-1]t = x[1:]+def tail [n] 't (x: [n]t) : [n - 1]t = x[1:]  -- | Everything but the last element of the array. -- -- **Complexity:** O(1). #[inline]-def init [n] 't (x: [n]t): [n-1]t = x[0:n-1]+def init [n] 't (x: [n]t) : [n - 1]t = x[0:n - 1]  -- | Take some number of elements from the head of the array. -- -- **Complexity:** O(1). #[inline]-def take [n] 't (i: i64) (x: [n]t): [i]t = x[0:i]+def take [n] 't (i: i64) (x: [n]t) : [i]t = x[0:i]  -- | Remove some number of elements from the head of the array. -- -- **Complexity:** O(1). #[inline]-def drop [n] 't (i: i64) (x: [n]t): [n-i]t = x[i:]+def drop [n] 't (i: i64) (x: [n]t) : [n - i]t = x[i:]  -- | Statically change the size of an array.  Fail at runtime if the -- imposed size does not match the actual size.  Essentially syntactic@@ -61,14 +61,14 @@ -- -- **Complexity:** O(1). #[inline]-def split [n][m] 't (xs: [n+m]t): ([n]t, [m]t) =-  (xs[0:n], xs[n:n+m] :> [m]t)+def split [n] [m] 't (xs: [n + m]t) : ([n]t, [m]t) =+  (xs[0:n], xs[n:n + m] :> [m]t)  -- | Return the elements of the array in reverse order. -- -- **Complexity:** O(1). #[inline]-def reverse [n] 't (x: [n]t): [n]t = x[::-1]+def reverse [n] 't (x: [n]t) : [n]t = x[::-1]  -- | Concatenate two arrays.  Warning: never try to perform a reduction -- with this operator; it will not work.@@ -77,11 +77,11 @@ -- -- **Span:** O(1). #[inline]-def (++) [n] [m] 't (xs: [n]t) (ys: [m]t): *[n+m]t = intrinsics.concat xs ys+def (++) [n] [m] 't (xs: [n]t) (ys: [m]t) : *[n + m]t = intrinsics.concat xs ys  -- | An old-fashioned way of saying `++`. #[inline]-def concat [n] [m] 't (xs: [n]t) (ys: [m]t): *[n+m]t = xs ++ ys+def concat [n] [m] 't (xs: [n]t) (ys: [m]t) : *[n + m]t = xs ++ ys  -- | Construct an array of consecutive integers of the given length, -- starting at 0.@@ -90,7 +90,7 @@ -- -- **Span:** O(1). #[inline]-def iota (n: i64): *[n]i64 =+def iota (n: i64) : *[n]i64 =   0..1..<n  -- | Construct an array comprising valid indexes into some other@@ -116,7 +116,7 @@ -- operations such as `map`, in which case it is free. #[inline] def rotate [n] 't (r: i64) (a: [n]t) =-  map (\i -> #[unsafe] a[(i+r)%n]) (iota n)+  map (\i -> #[unsafe] a[(i + r) % n]) (iota n)  -- | Construct an array of the given length containing the given -- value.@@ -125,7 +125,7 @@ -- -- **Span:** O(1). #[inline]-def replicate 't (n: i64) (x: t): *[n]t =+def replicate 't (n: i64) (x: t) : *[n]t =   map (const x) (iota n)  -- | Construct an array of an inferred length containing the given@@ -135,7 +135,7 @@ -- -- **Span:** O(1). #[inline]-def rep 't [n] (x: t): *[n]t =+def rep 't [n] (x: t) : *[n]t =   replicate n x  -- | Copy a value.  The result will not alias anything.@@ -144,7 +144,7 @@ -- -- **Span:** O(1). #[inline]-def copy 't (a: t): *t =+def copy 't (a: t) : *t =   ([a])[0]  -- | Copy a value. The result will not alias anything. Additionally,@@ -156,48 +156,48 @@ -- -- **Span:** O(1). #[inline]-def manifest 't (a: t): *t =+def manifest 't (a: t) : *t =   intrinsics.manifest a  -- | Combines the outer two dimensions of an array. -- -- **Complexity:** O(1). #[inline]-def flatten [n][m] 't (xs: [n][m]t): [n*m]t =+def flatten [n] [m] 't (xs: [n][m]t) : [n * m]t =   intrinsics.flatten xs  -- | Like `flatten`, but on the outer three dimensions of an array. #[inline]-def flatten_3d [n][m][l] 't (xs: [n][m][l]t): [n*m*l]t =+def flatten_3d [n] [m] [l] 't (xs: [n][m][l]t) : [n * m * l]t =   flatten (flatten xs)  -- | Like `flatten`, but on the outer four dimensions of an array. #[inline]-def flatten_4d [n][m][l][k] 't (xs: [n][m][l][k]t): [n*m*l*k]t =+def flatten_4d [n] [m] [l] [k] 't (xs: [n][m][l][k]t) : [n * m * l * k]t =   flatten (flatten_3d xs)  -- | Splits the outer dimension of an array in two. -- -- **Complexity:** O(1). #[inline]-def unflatten 't [n][m] (xs: [n*m]t): [n][m]t =+def unflatten 't [n] [m] (xs: [n * m]t) : [n][m]t =   intrinsics.unflatten n m xs  -- | Like `unflatten`, but produces three dimensions. #[inline]-def unflatten_3d 't [n][m][l] (xs: [n*m*l]t): [n][m][l]t =+def unflatten_3d 't [n] [m] [l] (xs: [n * m * l]t) : [n][m][l]t =   unflatten (unflatten xs)  -- | Like `unflatten`, but produces four dimensions. #[inline]-def unflatten_4d 't [n][m][l][k] (xs: [n*m*l*k]t): [n][m][l][k]t =+def unflatten_4d 't [n] [m] [l] [k] (xs: [n * m * l * k]t) : [n][m][l][k]t =   unflatten (unflatten_3d xs)  -- | Transpose an array. -- -- **Complexity:** O(1). #[inline]-def transpose [n] [m] 't (a: [n][m]t): [m][n]t =+def transpose [n] [m] 't (a: [n][m]t) : [m][n]t =   intrinsics.transpose a  -- | True if all of the input elements are true.  Produces true on an@@ -221,7 +221,7 @@ -- **Work:** O(n ✕ W(f))). -- -- **Span:** O(n ✕ S(f)).-def foldl [n] 'a 'b (f: a -> b -> a) (acc: a) (bs: [n]b): a =+def foldl [n] 'a 'b (f: a -> b -> a) (acc: a) (bs: [n]b) : a =   loop acc for b in bs do f acc b  -- | Perform a *sequential* right-fold of an array.@@ -229,7 +229,7 @@ -- **Work:** O(n ✕ W(f))). -- -- **Span:** O(n ✕ S(f)).-def foldr [n] 'a 'b (f: b -> a -> a) (acc: a) (bs: [n]b): a =+def foldr [n] 'a 'b (f: b -> a -> a) (acc: a) (bs: [n]b) : a =   foldl (flip f) acc (reverse bs)  -- | Create a value for each point in a one-dimensional index space.@@ -237,7 +237,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(S(f))*-def tabulate 'a (n: i64) (f: i64 -> a): *[n]a =+def tabulate 'a (n: i64) (f: i64 -> a) : *[n]a =   map1 f (iota n)  -- | Create a value for each point in a two-dimensional index space.@@ -245,7 +245,7 @@ -- **Work:** *O(n ✕ m ✕ W(f))* -- -- **Span:** *O(S(f))*-def tabulate_2d 'a (n: i64) (m: i64) (f: i64 -> i64 -> a): *[n][m]a =+def tabulate_2d 'a (n: i64) (m: i64) (f: i64 -> i64 -> a) : *[n][m]a =   map1 (f >-> tabulate m) (iota n)  -- | Create a value for each point in a three-dimensional index space.@@ -253,5 +253,5 @@ -- **Work:** *O(n ✕ m ✕ o ✕ W(f))* -- -- **Span:** *O(S(f))*-def tabulate_3d 'a (n: i64) (m: i64) (o: i64) (f: i64 -> i64 -> i64 -> a): *[n][m][o]a =+def tabulate_3d 'a (n: i64) (m: i64) (o: i64) (f: i64 -> i64 -> i64 -> a) : *[n][m][o]a =   map1 (f >-> tabulate_2d m o) (iota n)

@@ -23,7 +23,6 @@ -- ``` -- filter (>0) [-1,0,1] |> length -- ```- def (<|) '^a '^b (f: a -> b) (x: a) = f x  -- | Function composition, with values flowing from left to right.@@ -76,7 +75,7 @@ -- | Keep applying `f` until `p` returns true for the input value. -- May apply zero times.  *Note*: may not terminate. def iterate_until 'a (p: a -> bool) (f: a -> a) (x: a) =-  loop x while ! (p x) do f x+  loop x while !(p x) do f x  -- | Keep applying `f` while `p` returns true for the input value. -- May apply zero times.  *Note*: may not terminate.

@@ -71,6 +71,7 @@    -- | Returns `lowest` on empty input.   val maximum [n]: [n]t -> t+   -- | Returns `highest` on empty input.   val minimum [n]: [n]t -> t }@@ -83,14 +84,17 @@   -- | Like `/`@term, but rounds towards zero.  This only matters when   -- one of the operands is negative.  May be more efficient.   val //: t -> t -> t+   -- | Like `%`@term, but rounds towards zero.  This only matters when   -- one of the operands is negative.  May be more efficient.   val %%: t -> t -> t    -- | Bitwise and.   val &: t -> t -> t+   -- | Bitwise or.   val |: t -> t -> t+   -- | Bitwise xor.   val ^: t -> t -> t @@ -99,8 +103,10 @@    -- | Left shift; inserting zeroes.   val <<: t -> t -> t+   -- | Arithmetic right shift, using sign extension for the leftmost bits.   val >>: t -> t -> t+   -- | Logical right shift, inserting zeroes for the leftmost bits.   val >>>: t -> t -> t @@ -143,6 +149,7 @@    -- | Square root.   val sqrt: t -> t+   -- | Cube root.   val cbrt: t -> t   val exp: t -> t@@ -175,13 +182,15 @@    -- | The true Gamma function.   val gamma: t -> t+   -- | The natural logarithm of the absolute value of `gamma`@term.   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.@@ -189,33 +198,39 @@    -- | Natural logarithm.   val log: t -> t+   -- | Base-2 logarithm.   val log2: t -> t+   -- | Base-10 logarithm.   val log10: t -> t+   -- | Compute `log (1 + x)` accurately even when `x` is very small.   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`@term.-  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@@ -253,13 +268,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@@ -267,12 +282,12 @@ module bool: from_prim with t = bool = {   type t = bool -  def i8  = intrinsics.itob_i8_bool+  def i8 = intrinsics.itob_i8_bool   def i16 = intrinsics.itob_i16_bool   def i32 = intrinsics.itob_i32_bool   def i64 = intrinsics.itob_i64_bool -  def u8  (x: u8)  = intrinsics.itob_i8_bool (intrinsics.sign_i8 x)+  def u8 (x: u8) = intrinsics.itob_i8_bool (intrinsics.sign_i8 x)   def u16 (x: u16) = intrinsics.itob_i16_bool (intrinsics.sign_i16 x)   def u32 (x: u32) = intrinsics.itob_i32_bool (intrinsics.sign_i32 x)   def u64 (x: u64) = intrinsics.itob_i64_bool (intrinsics.sign_i64 x)@@ -287,30 +302,30 @@ module i8: (integral with t = i8) = {   type t = i8 -  def (x: i8) + (y: i8) = intrinsics.add8 (x, y)-  def (x: i8) - (y: i8) = intrinsics.sub8 (x, y)-  def (x: i8) * (y: i8) = intrinsics.mul8 (x, y)-  def (x: i8) / (y: i8) = intrinsics.sdiv8 (x, y)-  def (x: i8) ** (y: i8) = intrinsics.pow8 (x, y)-  def (x: i8) % (y: i8) = intrinsics.smod8 (x, y)-  def (x: i8) // (y: i8) = intrinsics.squot8 (x, y)-  def (x: i8) %% (y: i8) = intrinsics.srem8 (x, y)+  def (+) (x: i8) (y: i8) = intrinsics.add8 (x, y)+  def (-) (x: i8) (y: i8) = intrinsics.sub8 (x, y)+  def (*) (x: i8) (y: i8) = intrinsics.mul8 (x, y)+  def (/) (x: i8) (y: i8) = intrinsics.sdiv8 (x, y)+  def (**) (x: i8) (y: i8) = intrinsics.pow8 (x, y)+  def (%) (x: i8) (y: i8) = intrinsics.smod8 (x, y)+  def (//) (x: i8) (y: i8) = intrinsics.squot8 (x, y)+  def (%%) (x: i8) (y: i8) = intrinsics.srem8 (x, y) -  def (x: i8) & (y: i8) = intrinsics.and8 (x, y)-  def (x: i8) | (y: i8) = intrinsics.or8 (x, y)-  def (x: i8) ^ (y: i8) = intrinsics.xor8 (x, y)+  def (&) (x: i8) (y: i8) = intrinsics.and8 (x, y)+  def (|) (x: i8) (y: i8) = intrinsics.or8 (x, y)+  def (^) (x: i8) (y: i8) = intrinsics.xor8 (x, y)   def not (x: i8) = intrinsics.complement8 x -  def (x: i8) << (y: i8) = intrinsics.shl8 (x, y)-  def (x: i8) >> (y: i8) = intrinsics.ashr8 (x, y)-  def (x: i8) >>> (y: i8) = intrinsics.lshr8 (x, y)+  def (<<) (x: i8) (y: i8) = intrinsics.shl8 (x, y)+  def (>>) (x: i8) (y: i8) = intrinsics.ashr8 (x, y)+  def (>>>) (x: i8) (y: i8) = intrinsics.lshr8 (x, y) -  def i8  (x: i8)  = intrinsics.sext_i8_i8 x+  def i8 (x: i8) = intrinsics.sext_i8_i8 x   def i16 (x: i16) = intrinsics.sext_i16_i8 x   def i32 (x: i32) = intrinsics.sext_i32_i8 x   def i64 (x: i64) = intrinsics.sext_i64_i8 x -  def u8  (x: u8)  = intrinsics.zext_i8_i8 (intrinsics.sign_i8 x)+  def u8 (x: u8) = intrinsics.zext_i8_i8 (intrinsics.sign_i8 x)   def u16 (x: u16) = intrinsics.zext_i16_i8 (intrinsics.sign_i16 x)   def u32 (x: u32) = intrinsics.zext_i32_i8 (intrinsics.sign_i32 x)   def u64 (x: u64) = intrinsics.zext_i64_i8 (intrinsics.sign_i64 x)@@ -321,15 +336,15 @@    def bool = intrinsics.btoi_bool_i8 -  def to_i32(x: i8) = intrinsics.sext_i8_i32 x-  def to_i64(x: i8) = intrinsics.sext_i8_i64 x+  def to_i32 (x: i8) = intrinsics.sext_i8_i32 x+  def to_i64 (x: i8) = intrinsics.sext_i8_i64 x -  def (x: i8) == (y: i8) = intrinsics.eq_i8 (x, y)-  def (x: i8) < (y: i8) = intrinsics.slt8 (x, y)-  def (x: i8) > (y: i8) = intrinsics.slt8 (y, x)-  def (x: i8) <= (y: i8) = intrinsics.sle8 (x, y)-  def (x: i8) >= (y: i8) = intrinsics.sle8 (y, x)-  def (x: i8) != (y: i8) = !(x == y)+  def (==) (x: i8) (y: i8) = intrinsics.eq_i8 (x, y)+  def (<) (x: i8) (y: i8) = intrinsics.slt8 (x, y)+  def (>) (x: i8) (y: i8) = intrinsics.slt8 (y, x)+  def (<=) (x: i8) (y: i8) = intrinsics.sle8 (x, y)+  def (>=) (x: i8) (y: i8) = intrinsics.sle8 (y, x)+  def (!=) (x: i8) (y: i8) = !(x == y)    def sgn (x: i8) = intrinsics.ssignum8 x   def abs (x: i8) = intrinsics.abs8 x@@ -343,8 +358,10 @@    def num_bits = 8i32   def get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+   def set_bit (bit: i32) (x: t) (b: i32) =     ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+   def popc = intrinsics.popc8   def mul_hi a b = intrinsics.smul_hi8 (i8 a, i8 b)   def mad_hi a b c = intrinsics.smad_hi8 (i8 a, i8 b, i8 c)@@ -360,30 +377,30 @@ module i16: (integral with t = i16) = {   type t = i16 -  def (x: i16) + (y: i16) = intrinsics.add16 (x, y)-  def (x: i16) - (y: i16) = intrinsics.sub16 (x, y)-  def (x: i16) * (y: i16) = intrinsics.mul16 (x, y)-  def (x: i16) / (y: i16) = intrinsics.sdiv16 (x, y)-  def (x: i16) ** (y: i16) = intrinsics.pow16 (x, y)-  def (x: i16) % (y: i16) = intrinsics.smod16 (x, y)-  def (x: i16) // (y: i16) = intrinsics.squot16 (x, y)-  def (x: i16) %% (y: i16) = intrinsics.srem16 (x, y)+  def (+) (x: i16) (y: i16) = intrinsics.add16 (x, y)+  def (-) (x: i16) (y: i16) = intrinsics.sub16 (x, y)+  def (*) (x: i16) (y: i16) = intrinsics.mul16 (x, y)+  def (/) (x: i16) (y: i16) = intrinsics.sdiv16 (x, y)+  def (**) (x: i16) (y: i16) = intrinsics.pow16 (x, y)+  def (%) (x: i16) (y: i16) = intrinsics.smod16 (x, y)+  def (//) (x: i16) (y: i16) = intrinsics.squot16 (x, y)+  def (%%) (x: i16) (y: i16) = intrinsics.srem16 (x, y) -  def (x: i16) & (y: i16) = intrinsics.and16 (x, y)-  def (x: i16) | (y: i16) = intrinsics.or16 (x, y)-  def (x: i16) ^ (y: i16) = intrinsics.xor16 (x, y)+  def (&) (x: i16) (y: i16) = intrinsics.and16 (x, y)+  def (|) (x: i16) (y: i16) = intrinsics.or16 (x, y)+  def (^) (x: i16) (y: i16) = intrinsics.xor16 (x, y)   def not (x: i16) = intrinsics.complement16 x -  def (x: i16) << (y: i16) = intrinsics.shl16 (x, y)-  def (x: i16) >> (y: i16) = intrinsics.ashr16 (x, y)-  def (x: i16) >>> (y: i16) = intrinsics.lshr16 (x, y)+  def (<<) (x: i16) (y: i16) = intrinsics.shl16 (x, y)+  def (>>) (x: i16) (y: i16) = intrinsics.ashr16 (x, y)+  def (>>>) (x: i16) (y: i16) = intrinsics.lshr16 (x, y) -  def i8  (x: i8)  = intrinsics.sext_i8_i16 x+  def i8 (x: i8) = intrinsics.sext_i8_i16 x   def i16 (x: i16) = intrinsics.sext_i16_i16 x   def i32 (x: i32) = intrinsics.sext_i32_i16 x   def i64 (x: i64) = intrinsics.sext_i64_i16 x -  def u8  (x: u8)  = intrinsics.zext_i8_i16 (intrinsics.sign_i8 x)+  def u8 (x: u8) = intrinsics.zext_i8_i16 (intrinsics.sign_i8 x)   def u16 (x: u16) = intrinsics.zext_i16_i16 (intrinsics.sign_i16 x)   def u32 (x: u32) = intrinsics.zext_i32_i16 (intrinsics.sign_i32 x)   def u64 (x: u64) = intrinsics.zext_i64_i16 (intrinsics.sign_i64 x)@@ -394,15 +411,15 @@    def bool = intrinsics.btoi_bool_i16 -  def to_i32(x: i16) = intrinsics.sext_i16_i32 x-  def to_i64(x: i16) = intrinsics.sext_i16_i64 x+  def to_i32 (x: i16) = intrinsics.sext_i16_i32 x+  def to_i64 (x: i16) = intrinsics.sext_i16_i64 x -  def (x: i16) == (y: i16) = intrinsics.eq_i16 (x, y)-  def (x: i16) < (y: i16) = intrinsics.slt16 (x, y)-  def (x: i16) > (y: i16) = intrinsics.slt16 (y, x)-  def (x: i16) <= (y: i16) = intrinsics.sle16 (x, y)-  def (x: i16) >= (y: i16) = intrinsics.sle16 (y, x)-  def (x: i16) != (y: i16) = !(x == y)+  def (==) (x: i16) (y: i16) = intrinsics.eq_i16 (x, y)+  def (<) (x: i16) (y: i16) = intrinsics.slt16 (x, y)+  def (>) (x: i16) (y: i16) = intrinsics.slt16 (y, x)+  def (<=) (x: i16) (y: i16) = intrinsics.sle16 (x, y)+  def (>=) (x: i16) (y: i16) = intrinsics.sle16 (y, x)+  def (!=) (x: i16) (y: i16) = !(x == y)    def sgn (x: i16) = intrinsics.ssignum16 x   def abs (x: i16) = intrinsics.abs16 x@@ -416,8 +433,10 @@    def num_bits = 16i32   def get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+   def set_bit (bit: i32) (x: t) (b: i32) =     ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+   def popc = intrinsics.popc16   def mul_hi a b = intrinsics.smul_hi16 (i16 a, i16 b)   def mad_hi a b c = intrinsics.smad_hi16 (i16 a, i16 b, i16 c)@@ -436,30 +455,30 @@   def sign (x: u32) = intrinsics.sign_i32 x   def unsign (x: i32) = intrinsics.unsign_i32 x -  def (x: i32) + (y: i32) = intrinsics.add32 (x, y)-  def (x: i32) - (y: i32) = intrinsics.sub32 (x, y)-  def (x: i32) * (y: i32) = intrinsics.mul32 (x, y)-  def (x: i32) / (y: i32) = intrinsics.sdiv32 (x, y)-  def (x: i32) ** (y: i32) = intrinsics.pow32 (x, y)-  def (x: i32) % (y: i32) = intrinsics.smod32 (x, y)-  def (x: i32) // (y: i32) = intrinsics.squot32 (x, y)-  def (x: i32) %% (y: i32) = intrinsics.srem32 (x, y)+  def (+) (x: i32) (y: i32) = intrinsics.add32 (x, y)+  def (-) (x: i32) (y: i32) = intrinsics.sub32 (x, y)+  def (*) (x: i32) (y: i32) = intrinsics.mul32 (x, y)+  def (/) (x: i32) (y: i32) = intrinsics.sdiv32 (x, y)+  def (**) (x: i32) (y: i32) = intrinsics.pow32 (x, y)+  def (%) (x: i32) (y: i32) = intrinsics.smod32 (x, y)+  def (//) (x: i32) (y: i32) = intrinsics.squot32 (x, y)+  def (%%) (x: i32) (y: i32) = intrinsics.srem32 (x, y) -  def (x: i32) & (y: i32) = intrinsics.and32 (x, y)-  def (x: i32) | (y: i32) = intrinsics.or32 (x, y)-  def (x: i32) ^ (y: i32) = intrinsics.xor32 (x, y)+  def (&) (x: i32) (y: i32) = intrinsics.and32 (x, y)+  def (|) (x: i32) (y: i32) = intrinsics.or32 (x, y)+  def (^) (x: i32) (y: i32) = intrinsics.xor32 (x, y)   def not (x: i32) = intrinsics.complement32 x -  def (x: i32) << (y: i32) = intrinsics.shl32 (x, y)-  def (x: i32) >> (y: i32) = intrinsics.ashr32 (x, y)-  def (x: i32) >>> (y: i32) = intrinsics.lshr32 (x, y)+  def (<<) (x: i32) (y: i32) = intrinsics.shl32 (x, y)+  def (>>) (x: i32) (y: i32) = intrinsics.ashr32 (x, y)+  def (>>>) (x: i32) (y: i32) = intrinsics.lshr32 (x, y) -  def i8  (x: i8)  = intrinsics.sext_i8_i32 x+  def i8 (x: i8) = intrinsics.sext_i8_i32 x   def i16 (x: i16) = intrinsics.sext_i16_i32 x   def i32 (x: i32) = intrinsics.sext_i32_i32 x   def i64 (x: i64) = intrinsics.sext_i64_i32 x -  def u8  (x: u8)  = intrinsics.zext_i8_i32 (intrinsics.sign_i8 x)+  def u8 (x: u8) = intrinsics.zext_i8_i32 (intrinsics.sign_i8 x)   def u16 (x: u16) = intrinsics.zext_i16_i32 (intrinsics.sign_i16 x)   def u32 (x: u32) = intrinsics.zext_i32_i32 (intrinsics.sign_i32 x)   def u64 (x: u64) = intrinsics.zext_i64_i32 (intrinsics.sign_i64 x)@@ -470,15 +489,15 @@    def bool = intrinsics.btoi_bool_i32 -  def to_i32(x: i32) = intrinsics.sext_i32_i32 x-  def to_i64(x: i32) = intrinsics.sext_i32_i64 x+  def to_i32 (x: i32) = intrinsics.sext_i32_i32 x+  def to_i64 (x: i32) = intrinsics.sext_i32_i64 x -  def (x: i32) == (y: i32) = intrinsics.eq_i32 (x, y)-  def (x: i32) < (y: i32) = intrinsics.slt32 (x, y)-  def (x: i32) > (y: i32) = intrinsics.slt32 (y, x)-  def (x: i32) <= (y: i32) = intrinsics.sle32 (x, y)-  def (x: i32) >= (y: i32) = intrinsics.sle32 (y, x)-  def (x: i32) != (y: i32) = !(x == y)+  def (==) (x: i32) (y: i32) = intrinsics.eq_i32 (x, y)+  def (<) (x: i32) (y: i32) = intrinsics.slt32 (x, y)+  def (>) (x: i32) (y: i32) = intrinsics.slt32 (y, x)+  def (<=) (x: i32) (y: i32) = intrinsics.sle32 (x, y)+  def (>=) (x: i32) (y: i32) = intrinsics.sle32 (y, x)+  def (!=) (x: i32) (y: i32) = !(x == y)    def sgn (x: i32) = intrinsics.ssignum32 x   def abs (x: i32) = intrinsics.abs32 x@@ -492,8 +511,10 @@    def num_bits = 32i32   def get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+   def set_bit (bit: i32) (x: t) (b: i32) =     ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+   def popc = intrinsics.popc32   def mul_hi a b = intrinsics.smul_hi32 (i32 a, i32 b)   def mad_hi a b c = intrinsics.smad_hi32 (i32 a, i32 b, i32 c)@@ -512,30 +533,30 @@   def sign (x: u64) = intrinsics.sign_i64 x   def unsign (x: i64) = intrinsics.unsign_i64 x -  def (x: i64) + (y: i64) = intrinsics.add64 (x, y)-  def (x: i64) - (y: i64) = intrinsics.sub64 (x, y)-  def (x: i64) * (y: i64) = intrinsics.mul64 (x, y)-  def (x: i64) / (y: i64) = intrinsics.sdiv64 (x, y)-  def (x: i64) ** (y: i64) = intrinsics.pow64 (x, y)-  def (x: i64) % (y: i64) = intrinsics.smod64 (x, y)-  def (x: i64) // (y: i64) = intrinsics.squot64 (x, y)-  def (x: i64) %% (y: i64) = intrinsics.srem64 (x, y)+  def (+) (x: i64) (y: i64) = intrinsics.add64 (x, y)+  def (-) (x: i64) (y: i64) = intrinsics.sub64 (x, y)+  def (*) (x: i64) (y: i64) = intrinsics.mul64 (x, y)+  def (/) (x: i64) (y: i64) = intrinsics.sdiv64 (x, y)+  def (**) (x: i64) (y: i64) = intrinsics.pow64 (x, y)+  def (%) (x: i64) (y: i64) = intrinsics.smod64 (x, y)+  def (//) (x: i64) (y: i64) = intrinsics.squot64 (x, y)+  def (%%) (x: i64) (y: i64) = intrinsics.srem64 (x, y) -  def (x: i64) & (y: i64) = intrinsics.and64 (x, y)-  def (x: i64) | (y: i64) = intrinsics.or64 (x, y)-  def (x: i64) ^ (y: i64) = intrinsics.xor64 (x, y)+  def (&) (x: i64) (y: i64) = intrinsics.and64 (x, y)+  def (|) (x: i64) (y: i64) = intrinsics.or64 (x, y)+  def (^) (x: i64) (y: i64) = intrinsics.xor64 (x, y)   def not (x: i64) = intrinsics.complement64 x -  def (x: i64) << (y: i64) = intrinsics.shl64 (x, y)-  def (x: i64) >> (y: i64) = intrinsics.ashr64 (x, y)-  def (x: i64) >>> (y: i64) = intrinsics.lshr64 (x, y)+  def (<<) (x: i64) (y: i64) = intrinsics.shl64 (x, y)+  def (>>) (x: i64) (y: i64) = intrinsics.ashr64 (x, y)+  def (>>>) (x: i64) (y: i64) = intrinsics.lshr64 (x, y) -  def i8  (x: i8)  = intrinsics.sext_i8_i64 x+  def i8 (x: i8) = intrinsics.sext_i8_i64 x   def i16 (x: i16) = intrinsics.sext_i16_i64 x   def i32 (x: i32) = intrinsics.sext_i32_i64 x   def i64 (x: i64) = intrinsics.sext_i64_i64 x -  def u8  (x: u8)  = intrinsics.zext_i8_i64 (intrinsics.sign_i8 x)+  def u8 (x: u8) = intrinsics.zext_i8_i64 (intrinsics.sign_i8 x)   def u16 (x: u16) = intrinsics.zext_i16_i64 (intrinsics.sign_i16 x)   def u32 (x: u32) = intrinsics.zext_i32_i64 (intrinsics.sign_i32 x)   def u64 (x: u64) = intrinsics.zext_i64_i64 (intrinsics.sign_i64 x)@@ -546,15 +567,15 @@    def bool = intrinsics.btoi_bool_i64 -  def to_i32(x: i64) = intrinsics.sext_i64_i32 x-  def to_i64(x: i64) = intrinsics.sext_i64_i64 x+  def to_i32 (x: i64) = intrinsics.sext_i64_i32 x+  def to_i64 (x: i64) = intrinsics.sext_i64_i64 x -  def (x: i64) == (y: i64) = intrinsics.eq_i64 (x, y)-  def (x: i64) < (y: i64) = intrinsics.slt64 (x, y)-  def (x: i64) > (y: i64) = intrinsics.slt64 (y, x)-  def (x: i64) <= (y: i64) = intrinsics.sle64 (x, y)-  def (x: i64) >= (y: i64) = intrinsics.sle64 (y, x)-  def (x: i64) != (y: i64) = !(x == y)+  def (==) (x: i64) (y: i64) = intrinsics.eq_i64 (x, y)+  def (<) (x: i64) (y: i64) = intrinsics.slt64 (x, y)+  def (>) (x: i64) (y: i64) = intrinsics.slt64 (y, x)+  def (<=) (x: i64) (y: i64) = intrinsics.sle64 (x, y)+  def (>=) (x: i64) (y: i64) = intrinsics.sle64 (y, x)+  def (!=) (x: i64) (y: i64) = !(x == y)    def sgn (x: i64) = intrinsics.ssignum64 x   def abs (x: i64) = intrinsics.abs64 x@@ -568,8 +589,10 @@    def num_bits = 64i32   def get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+   def set_bit (bit: i32) (x: t) (b: i32) =     ((x & i32 (!(1 intrinsics.<< bit))) | intrinsics.zext_i32_i64 (b intrinsics.<< bit))+   def popc = intrinsics.popc64   def mul_hi a b = intrinsics.smul_hi64 (i64 a, i64 b)   def mad_hi a b c = intrinsics.smad_hi64 (i64 a, i64 b, i64 c)@@ -588,30 +611,30 @@   def sign (x: u8) = intrinsics.sign_i8 x   def unsign (x: i8) = intrinsics.unsign_i8 x -  def (x: u8) + (y: u8) = unsign (intrinsics.add8 (sign x, sign y))-  def (x: u8) - (y: u8) = unsign (intrinsics.sub8 (sign x, sign y))-  def (x: u8) * (y: u8) = unsign (intrinsics.mul8 (sign x, sign y))-  def (x: u8) / (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))-  def (x: u8) ** (y: u8) = unsign (intrinsics.pow8 (sign x, sign y))-  def (x: u8) % (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))-  def (x: u8) // (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))-  def (x: u8) %% (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))+  def (+) (x: u8) (y: u8) = unsign (intrinsics.add8 (sign x, sign y))+  def (-) (x: u8) (y: u8) = unsign (intrinsics.sub8 (sign x, sign y))+  def (*) (x: u8) (y: u8) = unsign (intrinsics.mul8 (sign x, sign y))+  def (/) (x: u8) (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))+  def (**) (x: u8) (y: u8) = unsign (intrinsics.pow8 (sign x, sign y))+  def (%) (x: u8) (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))+  def (//) (x: u8) (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))+  def (%%) (x: u8) (y: u8) = unsign (intrinsics.umod8 (sign x, sign y)) -  def (x: u8) & (y: u8) = unsign (intrinsics.and8 (sign x, sign y))-  def (x: u8) | (y: u8) = unsign (intrinsics.or8 (sign x, sign y))-  def (x: u8) ^ (y: u8) = unsign (intrinsics.xor8 (sign x, sign y))+  def (&) (x: u8) (y: u8) = unsign (intrinsics.and8 (sign x, sign y))+  def (|) (x: u8) (y: u8) = unsign (intrinsics.or8 (sign x, sign y))+  def (^) (x: u8) (y: u8) = unsign (intrinsics.xor8 (sign x, sign y))   def not (x: u8) = unsign (intrinsics.complement8 (sign x)) -  def (x: u8) << (y: u8) = unsign (intrinsics.shl8 (sign x, sign y))-  def (x: u8) >> (y: u8) = unsign (intrinsics.ashr8 (sign x, sign y))-  def (x: u8) >>> (y: u8) = unsign (intrinsics.lshr8 (sign x, sign y))+  def (<<) (x: u8) (y: u8) = unsign (intrinsics.shl8 (sign x, sign y))+  def (>>) (x: u8) (y: u8) = unsign (intrinsics.ashr8 (sign x, sign y))+  def (>>>) (x: u8) (y: u8) = unsign (intrinsics.lshr8 (sign x, sign y)) -  def u8  (x: u8)  = unsign (i8.u8 x)+  def u8 (x: u8) = unsign (i8.u8 x)   def u16 (x: u16) = unsign (i8.u16 x)   def u32 (x: u32) = unsign (i8.u32 x)   def u64 (x: u64) = unsign (i8.u64 x) -  def i8  (x: i8)  = unsign (intrinsics.zext_i8_i8 x)+  def i8 (x: i8) = unsign (intrinsics.zext_i8_i8 x)   def i16 (x: i16) = unsign (intrinsics.zext_i16_i8 x)   def i32 (x: i32) = unsign (intrinsics.zext_i32_i8 x)   def i64 (x: i64) = unsign (intrinsics.zext_i64_i8 x)@@ -622,15 +645,15 @@    def bool x = unsign (intrinsics.btoi_bool_i8 x) -  def to_i32(x: u8) = intrinsics.zext_i8_i32 (sign x)-  def to_i64(x: u8) = intrinsics.zext_i8_i64 (sign x)+  def to_i32 (x: u8) = intrinsics.zext_i8_i32 (sign x)+  def to_i64 (x: u8) = intrinsics.zext_i8_i64 (sign x) -  def (x: u8) == (y: u8) = intrinsics.eq_i8 (sign x, sign y)-  def (x: u8) < (y: u8) = intrinsics.ult8 (sign x, sign y)-  def (x: u8) > (y: u8) = intrinsics.ult8 (sign y, sign x)-  def (x: u8) <= (y: u8) = intrinsics.ule8 (sign x, sign y)-  def (x: u8) >= (y: u8) = intrinsics.ule8 (sign y, sign x)-  def (x: u8) != (y: u8) = !(x == y)+  def (==) (x: u8) (y: u8) = intrinsics.eq_i8 (sign x, sign y)+  def (<) (x: u8) (y: u8) = intrinsics.ult8 (sign x, sign y)+  def (>) (x: u8) (y: u8) = intrinsics.ult8 (sign y, sign x)+  def (<=) (x: u8) (y: u8) = intrinsics.ule8 (sign x, sign y)+  def (>=) (x: u8) (y: u8) = intrinsics.ule8 (sign y, sign x)+  def (!=) (x: u8) (y: u8) = !(x == y)    def sgn (x: u8) = unsign (intrinsics.usignum8 (sign x))   def abs (x: u8) = x@@ -644,8 +667,10 @@    def num_bits = 8i32   def get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+   def set_bit (bit: i32) (x: t) (b: i32) =     ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+   def popc x = intrinsics.popc8 (sign x)   def mul_hi a b = unsign (intrinsics.umul_hi8 (sign a, sign b))   def mad_hi a b c = unsign (intrinsics.umad_hi8 (sign a, sign b, sign c))@@ -664,30 +689,30 @@   def sign (x: u16) = intrinsics.sign_i16 x   def unsign (x: i16) = intrinsics.unsign_i16 x -  def (x: u16) + (y: u16) = unsign (intrinsics.add16 (sign x, sign y))-  def (x: u16) - (y: u16) = unsign (intrinsics.sub16 (sign x, sign y))-  def (x: u16) * (y: u16) = unsign (intrinsics.mul16 (sign x, sign y))-  def (x: u16) / (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))-  def (x: u16) ** (y: u16) = unsign (intrinsics.pow16 (sign x, sign y))-  def (x: u16) % (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))-  def (x: u16) // (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))-  def (x: u16) %% (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))+  def (+) (x: u16) (y: u16) = unsign (intrinsics.add16 (sign x, sign y))+  def (-) (x: u16) (y: u16) = unsign (intrinsics.sub16 (sign x, sign y))+  def (*) (x: u16) (y: u16) = unsign (intrinsics.mul16 (sign x, sign y))+  def (/) (x: u16) (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))+  def (**) (x: u16) (y: u16) = unsign (intrinsics.pow16 (sign x, sign y))+  def (%) (x: u16) (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))+  def (//) (x: u16) (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))+  def (%%) (x: u16) (y: u16) = unsign (intrinsics.umod16 (sign x, sign y)) -  def (x: u16) & (y: u16) = unsign (intrinsics.and16 (sign x, sign y))-  def (x: u16) | (y: u16) = unsign (intrinsics.or16 (sign x, sign y))-  def (x: u16) ^ (y: u16) = unsign (intrinsics.xor16 (sign x, sign y))+  def (&) (x: u16) (y: u16) = unsign (intrinsics.and16 (sign x, sign y))+  def (|) (x: u16) (y: u16) = unsign (intrinsics.or16 (sign x, sign y))+  def (^) (x: u16) (y: u16) = unsign (intrinsics.xor16 (sign x, sign y))   def not (x: u16) = unsign (intrinsics.complement16 (sign x)) -  def (x: u16) << (y: u16) = unsign (intrinsics.shl16 (sign x, sign y))-  def (x: u16) >> (y: u16) = unsign (intrinsics.ashr16 (sign x, sign y))-  def (x: u16) >>> (y: u16) = unsign (intrinsics.lshr16 (sign x, sign y))+  def (<<) (x: u16) (y: u16) = unsign (intrinsics.shl16 (sign x, sign y))+  def (>>) (x: u16) (y: u16) = unsign (intrinsics.ashr16 (sign x, sign y))+  def (>>>) (x: u16) (y: u16) = unsign (intrinsics.lshr16 (sign x, sign y)) -  def u8  (x: u8)  = unsign (i16.u8 x)+  def u8 (x: u8) = unsign (i16.u8 x)   def u16 (x: u16) = unsign (i16.u16 x)   def u32 (x: u32) = unsign (i16.u32 x)   def u64 (x: u64) = unsign (i16.u64 x) -  def i8  (x: i8)  = unsign (intrinsics.zext_i8_i16 x)+  def i8 (x: i8) = unsign (intrinsics.zext_i8_i16 x)   def i16 (x: i16) = unsign (intrinsics.zext_i16_i16 x)   def i32 (x: i32) = unsign (intrinsics.zext_i32_i16 x)   def i64 (x: i64) = unsign (intrinsics.zext_i64_i16 x)@@ -698,15 +723,15 @@    def bool x = unsign (intrinsics.btoi_bool_i16 x) -  def to_i32(x: u16) = intrinsics.zext_i16_i32 (sign x)-  def to_i64(x: u16) = intrinsics.zext_i16_i64 (sign x)+  def to_i32 (x: u16) = intrinsics.zext_i16_i32 (sign x)+  def to_i64 (x: u16) = intrinsics.zext_i16_i64 (sign x) -  def (x: u16) == (y: u16) = intrinsics.eq_i16 (sign x, sign y)-  def (x: u16) < (y: u16) = intrinsics.ult16 (sign x, sign y)-  def (x: u16) > (y: u16) = intrinsics.ult16 (sign y, sign x)-  def (x: u16) <= (y: u16) = intrinsics.ule16 (sign x, sign y)-  def (x: u16) >= (y: u16) = intrinsics.ule16 (sign y, sign x)-  def (x: u16) != (y: u16) = !(x == y)+  def (==) (x: u16) (y: u16) = intrinsics.eq_i16 (sign x, sign y)+  def (<) (x: u16) (y: u16) = intrinsics.ult16 (sign x, sign y)+  def (>) (x: u16) (y: u16) = intrinsics.ult16 (sign y, sign x)+  def (<=) (x: u16) (y: u16) = intrinsics.ule16 (sign x, sign y)+  def (>=) (x: u16) (y: u16) = intrinsics.ule16 (sign y, sign x)+  def (!=) (x: u16) (y: u16) = !(x == y)    def sgn (x: u16) = unsign (intrinsics.usignum16 (sign x))   def abs (x: u16) = x@@ -720,8 +745,10 @@    def num_bits = 16i32   def get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+   def set_bit (bit: i32) (x: t) (b: i32) =     ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+   def popc x = intrinsics.popc16 (sign x)   def mul_hi a b = unsign (intrinsics.umul_hi16 (sign a, sign b))   def mad_hi a b c = unsign (intrinsics.umad_hi16 (sign a, sign b, sign c))@@ -740,30 +767,30 @@   def sign (x: u32) = intrinsics.sign_i32 x   def unsign (x: i32) = intrinsics.unsign_i32 x -  def (x: u32) + (y: u32) = unsign (intrinsics.add32 (sign x, sign y))-  def (x: u32) - (y: u32) = unsign (intrinsics.sub32 (sign x, sign y))-  def (x: u32) * (y: u32) = unsign (intrinsics.mul32 (sign x, sign y))-  def (x: u32) / (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))-  def (x: u32) ** (y: u32) = unsign (intrinsics.pow32 (sign x, sign y))-  def (x: u32) % (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))-  def (x: u32) // (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))-  def (x: u32) %% (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))+  def (+) (x: u32) (y: u32) = unsign (intrinsics.add32 (sign x, sign y))+  def (-) (x: u32) (y: u32) = unsign (intrinsics.sub32 (sign x, sign y))+  def (*) (x: u32) (y: u32) = unsign (intrinsics.mul32 (sign x, sign y))+  def (/) (x: u32) (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))+  def (**) (x: u32) (y: u32) = unsign (intrinsics.pow32 (sign x, sign y))+  def (%) (x: u32) (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))+  def (//) (x: u32) (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))+  def (%%) (x: u32) (y: u32) = unsign (intrinsics.umod32 (sign x, sign y)) -  def (x: u32) & (y: u32) = unsign (intrinsics.and32 (sign x, sign y))-  def (x: u32) | (y: u32) = unsign (intrinsics.or32 (sign x, sign y))-  def (x: u32) ^ (y: u32) = unsign (intrinsics.xor32 (sign x, sign y))+  def (&) (x: u32) (y: u32) = unsign (intrinsics.and32 (sign x, sign y))+  def (|) (x: u32) (y: u32) = unsign (intrinsics.or32 (sign x, sign y))+  def (^) (x: u32) (y: u32) = unsign (intrinsics.xor32 (sign x, sign y))   def not (x: u32) = unsign (intrinsics.complement32 (sign x)) -  def (x: u32) << (y: u32) = unsign (intrinsics.shl32 (sign x, sign y))-  def (x: u32) >> (y: u32) = unsign (intrinsics.ashr32 (sign x, sign y))-  def (x: u32) >>> (y: u32) = unsign (intrinsics.lshr32 (sign x, sign y))+  def (<<) (x: u32) (y: u32) = unsign (intrinsics.shl32 (sign x, sign y))+  def (>>) (x: u32) (y: u32) = unsign (intrinsics.ashr32 (sign x, sign y))+  def (>>>) (x: u32) (y: u32) = unsign (intrinsics.lshr32 (sign x, sign y)) -  def u8  (x: u8)  = unsign (i32.u8 x)+  def u8 (x: u8) = unsign (i32.u8 x)   def u16 (x: u16) = unsign (i32.u16 x)   def u32 (x: u32) = unsign (i32.u32 x)   def u64 (x: u64) = unsign (i32.u64 x) -  def i8  (x: i8)  = unsign (intrinsics.zext_i8_i32 x)+  def i8 (x: i8) = unsign (intrinsics.zext_i8_i32 x)   def i16 (x: i16) = unsign (intrinsics.zext_i16_i32 x)   def i32 (x: i32) = unsign (intrinsics.zext_i32_i32 x)   def i64 (x: i64) = unsign (intrinsics.zext_i64_i32 x)@@ -774,15 +801,15 @@    def bool x = unsign (intrinsics.btoi_bool_i32 x) -  def to_i32(x: u32) = intrinsics.zext_i32_i32 (sign x)-  def to_i64(x: u32) = intrinsics.zext_i32_i64 (sign x)+  def to_i32 (x: u32) = intrinsics.zext_i32_i32 (sign x)+  def to_i64 (x: u32) = intrinsics.zext_i32_i64 (sign x) -  def (x: u32) == (y: u32) = intrinsics.eq_i32 (sign x, sign y)-  def (x: u32) < (y: u32) = intrinsics.ult32 (sign x, sign y)-  def (x: u32) > (y: u32) = intrinsics.ult32 (sign y, sign x)-  def (x: u32) <= (y: u32) = intrinsics.ule32 (sign x, sign y)-  def (x: u32) >= (y: u32) = intrinsics.ule32 (sign y, sign x)-  def (x: u32) != (y: u32) = !(x == y)+  def (==) (x: u32) (y: u32) = intrinsics.eq_i32 (sign x, sign y)+  def (<) (x: u32) (y: u32) = intrinsics.ult32 (sign x, sign y)+  def (>) (x: u32) (y: u32) = intrinsics.ult32 (sign y, sign x)+  def (<=) (x: u32) (y: u32) = intrinsics.ule32 (sign x, sign y)+  def (>=) (x: u32) (y: u32) = intrinsics.ule32 (sign y, sign x)+  def (!=) (x: u32) (y: u32) = !(x == y)    def sgn (x: u32) = unsign (intrinsics.usignum32 (sign x))   def abs (x: u32) = x@@ -796,8 +823,10 @@    def num_bits = 32i32   def get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+   def set_bit (bit: i32) (x: t) (b: i32) =     ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+   def popc x = intrinsics.popc32 (sign x)   def mul_hi a b = unsign (intrinsics.umul_hi32 (sign a, sign b))   def mad_hi a b c = unsign (intrinsics.umad_hi32 (sign a, sign b, sign c))@@ -816,30 +845,30 @@   def sign (x: u64) = intrinsics.sign_i64 x   def unsign (x: i64) = intrinsics.unsign_i64 x -  def (x: u64) + (y: u64) = unsign (intrinsics.add64 (sign x, sign y))-  def (x: u64) - (y: u64) = unsign (intrinsics.sub64 (sign x, sign y))-  def (x: u64) * (y: u64) = unsign (intrinsics.mul64 (sign x, sign y))-  def (x: u64) / (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))-  def (x: u64) ** (y: u64) = unsign (intrinsics.pow64 (sign x, sign y))-  def (x: u64) % (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))-  def (x: u64) // (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))-  def (x: u64) %% (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))+  def (+) (x: u64) (y: u64) = unsign (intrinsics.add64 (sign x, sign y))+  def (-) (x: u64) (y: u64) = unsign (intrinsics.sub64 (sign x, sign y))+  def (*) (x: u64) (y: u64) = unsign (intrinsics.mul64 (sign x, sign y))+  def (/) (x: u64) (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))+  def (**) (x: u64) (y: u64) = unsign (intrinsics.pow64 (sign x, sign y))+  def (%) (x: u64) (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))+  def (//) (x: u64) (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))+  def (%%) (x: u64) (y: u64) = unsign (intrinsics.umod64 (sign x, sign y)) -  def (x: u64) & (y: u64) = unsign (intrinsics.and64 (sign x, sign y))-  def (x: u64) | (y: u64) = unsign (intrinsics.or64 (sign x, sign y))-  def (x: u64) ^ (y: u64) = unsign (intrinsics.xor64 (sign x, sign y))+  def (&) (x: u64) (y: u64) = unsign (intrinsics.and64 (sign x, sign y))+  def (|) (x: u64) (y: u64) = unsign (intrinsics.or64 (sign x, sign y))+  def (^) (x: u64) (y: u64) = unsign (intrinsics.xor64 (sign x, sign y))   def not (x: u64) = unsign (intrinsics.complement64 (sign x)) -  def (x: u64) << (y: u64) = unsign (intrinsics.shl64 (sign x, sign y))-  def (x: u64) >> (y: u64) = unsign (intrinsics.ashr64 (sign x, sign y))-  def (x: u64) >>> (y: u64) = unsign (intrinsics.lshr64 (sign x, sign y))+  def (<<) (x: u64) (y: u64) = unsign (intrinsics.shl64 (sign x, sign y))+  def (>>) (x: u64) (y: u64) = unsign (intrinsics.ashr64 (sign x, sign y))+  def (>>>) (x: u64) (y: u64) = unsign (intrinsics.lshr64 (sign x, sign y)) -  def u8  (x: u8)  = unsign (i64.u8 x)+  def u8 (x: u8) = unsign (i64.u8 x)   def u16 (x: u16) = unsign (i64.u16 x)   def u32 (x: u32) = unsign (i64.u32 x)   def u64 (x: u64) = unsign (i64.u64 x) -  def i8 (x: i8)   = unsign (intrinsics.zext_i8_i64 x)+  def i8 (x: i8) = unsign (intrinsics.zext_i8_i64 x)   def i16 (x: i16) = unsign (intrinsics.zext_i16_i64 x)   def i32 (x: i32) = unsign (intrinsics.zext_i32_i64 x)   def i64 (x: i64) = unsign (intrinsics.zext_i64_i64 x)@@ -850,15 +879,15 @@    def bool x = unsign (intrinsics.btoi_bool_i64 x) -  def to_i32(x: u64) = intrinsics.zext_i64_i32 (sign x)-  def to_i64(x: u64) = intrinsics.zext_i64_i64 (sign x)+  def to_i32 (x: u64) = intrinsics.zext_i64_i32 (sign x)+  def to_i64 (x: u64) = intrinsics.zext_i64_i64 (sign x) -  def (x: u64) == (y: u64) = intrinsics.eq_i64 (sign x, sign y)-  def (x: u64) < (y: u64) = intrinsics.ult64 (sign x, sign y)-  def (x: u64) > (y: u64) = intrinsics.ult64 (sign y, sign x)-  def (x: u64) <= (y: u64) = intrinsics.ule64 (sign x, sign y)-  def (x: u64) >= (y: u64) = intrinsics.ule64 (sign y, sign x)-  def (x: u64) != (y: u64) = !(x == y)+  def (==) (x: u64) (y: u64) = intrinsics.eq_i64 (sign x, sign y)+  def (<) (x: u64) (y: u64) = intrinsics.ult64 (sign x, sign y)+  def (>) (x: u64) (y: u64) = intrinsics.ult64 (sign y, sign x)+  def (<=) (x: u64) (y: u64) = intrinsics.ule64 (sign x, sign y)+  def (>=) (x: u64) (y: u64) = intrinsics.ule64 (sign y, sign x)+  def (!=) (x: u64) (y: u64) = !(x == y)    def sgn (x: u64) = unsign (intrinsics.usignum64 (sign x))   def abs (x: u64) = x@@ -872,8 +901,10 @@    def num_bits = 64i32   def get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)+   def set_bit (bit: i32) (x: t) (b: i32) =     ((x & i32 (!(1 intrinsics.<< bit))) | i32 (b intrinsics.<< bit))+   def popc x = intrinsics.popc64 (sign x)   def mul_hi a b = unsign (intrinsics.umul_hi64 (sign a, sign b))   def mad_hi a b c = unsign (intrinsics.umad_hi64 (sign a, sign b, sign c))@@ -893,14 +924,14 @@   module i64m = i64   module u64m = u64 -  def (x: f64) + (y: f64) = intrinsics.fadd64 (x, y)-  def (x: f64) - (y: f64) = intrinsics.fsub64 (x, y)-  def (x: f64) * (y: f64) = intrinsics.fmul64 (x, y)-  def (x: f64) / (y: f64) = intrinsics.fdiv64 (x, y)-  def (x: f64) % (y: f64) = intrinsics.fmod64 (x, y)-  def (x: f64) ** (y: f64) = intrinsics.fpow64 (x, y)+  def (+) (x: f64) (y: f64) = intrinsics.fadd64 (x, y)+  def (-) (x: f64) (y: f64) = intrinsics.fsub64 (x, y)+  def (*) (x: f64) (y: f64) = intrinsics.fmul64 (x, y)+  def (/) (x: f64) (y: f64) = intrinsics.fdiv64 (x, y)+  def (%) (x: f64) (y: f64) = intrinsics.fmod64 (x, y)+  def (**) (x: f64) (y: f64) = intrinsics.fpow64 (x, y) -  def u8  (x: u8)  = intrinsics.uitofp_i8_f64  (i8.u8 x)+  def u8 (x: u8) = intrinsics.uitofp_i8_f64 (i8.u8 x)   def u16 (x: u16) = intrinsics.uitofp_i16_f64 (i16.u16 x)   def u32 (x: u32) = intrinsics.uitofp_i32_f64 (i32.u32 x)   def u64 (x: u64) = intrinsics.uitofp_i64_f64 (i64.u64 x)@@ -920,15 +951,15 @@   def to_i64 (x: f64) = intrinsics.fptosi_f64_i64 x   def to_f64 (x: f64) = x -  def (x: f64) == (y: f64) = intrinsics.eq_f64 (x, y)-  def (x: f64) < (y: f64) = intrinsics.lt64 (x, y)-  def (x: f64) > (y: f64) = intrinsics.lt64 (y, x)-  def (x: f64) <= (y: f64) = intrinsics.le64 (x, y)-  def (x: f64) >= (y: f64) = intrinsics.le64 (y, x)-  def (x: f64) != (y: f64) = !(x == y)+  def (==) (x: f64) (y: f64) = intrinsics.eq_f64 (x, y)+  def (<) (x: f64) (y: f64) = intrinsics.lt64 (x, y)+  def (>) (x: f64) (y: f64) = intrinsics.lt64 (y, x)+  def (<=) (x: f64) (y: f64) = intrinsics.le64 (x, y)+  def (>=) (x: f64) (y: f64) = intrinsics.le64 (y, x)+  def (!=) (x: f64) (y: f64) = !(x == y)    def neg (x: t) = -x-  def recip (x: t) = 1/x+  def recip (x: t) = 1 / x   def max (x: t) (y: t) = intrinsics.fmax64 (x, y)   def min (x: t) (y: t) = intrinsics.fmin64 (x, y) @@ -962,19 +993,19 @@   def erf = intrinsics.erf64   def erfc = intrinsics.erfc64 -  def lerp v0 v1 t = intrinsics.lerp64 (v0,v1,t)-  def fma a b c = intrinsics.fma64 (a,b,c)-  def mad a b c = intrinsics.mad64 (a,b,c)+  def lerp v0 v1 t = intrinsics.lerp64 (v0, v1, t)+  def fma a b c = intrinsics.fma64 (a, b, c)+  def mad a b c = intrinsics.mad64 (a, b, c)    def ceil = intrinsics.ceil64   def floor = intrinsics.floor64-  def trunc (x: f64) : f64 = i64 (i64m.f64 x)+  def trunc (x: f64): f64 = i64 (i64m.f64 x)    def round = intrinsics.round64 -  def nextafter x y = intrinsics.nextafter64 (x,y)-  def ldexp x y = intrinsics.ldexp64 (x,y)-  def copysign x y = intrinsics.copysign64 (x,y)+  def nextafter x y = intrinsics.nextafter64 (x, y)+  def ldexp x y = intrinsics.ldexp64 (x, y)+  def copysign x y = intrinsics.copysign64 (x, y)    def to_bits (x: f64): u64 = u64m.i64 (intrinsics.to_bits64 x)   def from_bits (x: u64): f64 = intrinsics.from_bits64 (intrinsics.sign_i64 x)@@ -1010,14 +1041,14 @@   module u32m = u32   module f64m = f64 -  def (x: f32) + (y: f32) = intrinsics.fadd32 (x, y)-  def (x: f32) - (y: f32) = intrinsics.fsub32 (x, y)-  def (x: f32) * (y: f32) = intrinsics.fmul32 (x, y)-  def (x: f32) / (y: f32) = intrinsics.fdiv32 (x, y)-  def (x: f32) % (y: f32) = intrinsics.fmod32 (x, y)-  def (x: f32) ** (y: f32) = intrinsics.fpow32 (x, y)+  def (+) (x: f32) (y: f32) = intrinsics.fadd32 (x, y)+  def (-) (x: f32) (y: f32) = intrinsics.fsub32 (x, y)+  def (*) (x: f32) (y: f32) = intrinsics.fmul32 (x, y)+  def (/) (x: f32) (y: f32) = intrinsics.fdiv32 (x, y)+  def (%) (x: f32) (y: f32) = intrinsics.fmod32 (x, y)+  def (**) (x: f32) (y: f32) = intrinsics.fpow32 (x, y) -  def u8  (x: u8)  = intrinsics.uitofp_i8_f32  (i8.u8 x)+  def u8 (x: u8) = intrinsics.uitofp_i8_f32 (i8.u8 x)   def u16 (x: u16) = intrinsics.uitofp_i16_f32 (i16.u16 x)   def u32 (x: u32) = intrinsics.uitofp_i32_f32 (i32.u32 x)   def u64 (x: u64) = intrinsics.uitofp_i64_f32 (i64.u64 x)@@ -1037,15 +1068,15 @@   def to_i64 (x: f32) = intrinsics.fptosi_f32_i64 x   def to_f64 (x: f32) = intrinsics.fpconv_f32_f64 x -  def (x: f32) == (y: f32) = intrinsics.eq_f32 (x, y)-  def (x: f32) < (y: f32) = intrinsics.lt32 (x, y)-  def (x: f32) > (y: f32) = intrinsics.lt32 (y, x)-  def (x: f32) <= (y: f32) = intrinsics.le32 (x, y)-  def (x: f32) >= (y: f32) = intrinsics.le32 (y, x)-  def (x: f32) != (y: f32) = !(x == y)+  def (==) (x: f32) (y: f32) = intrinsics.eq_f32 (x, y)+  def (<) (x: f32) (y: f32) = intrinsics.lt32 (x, y)+  def (>) (x: f32) (y: f32) = intrinsics.lt32 (y, x)+  def (<=) (x: f32) (y: f32) = intrinsics.le32 (x, y)+  def (>=) (x: f32) (y: f32) = intrinsics.le32 (y, x)+  def (!=) (x: f32) (y: f32) = !(x == y)    def neg (x: t) = -x-  def recip (x: t) = 1/x+  def recip (x: t) = 1 / x   def max (x: t) (y: t) = intrinsics.fmax32 (x, y)   def min (x: t) (y: t) = intrinsics.fmin32 (x, y) @@ -1079,19 +1110,19 @@   def erf = intrinsics.erf32   def erfc = intrinsics.erfc32 -  def lerp v0 v1 t = intrinsics.lerp32 (v0,v1,t)-  def fma a b c = intrinsics.fma32 (a,b,c)-  def mad a b c = intrinsics.mad32 (a,b,c)+  def lerp v0 v1 t = intrinsics.lerp32 (v0, v1, t)+  def fma a b c = intrinsics.fma32 (a, b, c)+  def mad a b c = intrinsics.mad32 (a, b, c)    def ceil = intrinsics.ceil32   def floor = intrinsics.floor32-  def trunc (x: f32) : f32 = i32 (i32m.f32 x)+  def trunc (x: f32): f32 = i32 (i32m.f32 x)    def round = intrinsics.round32 -  def nextafter x y = intrinsics.nextafter32 (x,y)-  def ldexp x y = intrinsics.ldexp32 (x,y)-  def copysign x y = intrinsics.copysign32 (x,y)+  def nextafter x y = intrinsics.nextafter32 (x, y)+  def ldexp x y = intrinsics.ldexp32 (x, y)+  def copysign x y = intrinsics.copysign32 (x, y)    def to_bits (x: f32): u32 = u32m.i32 (intrinsics.to_bits32 x)   def from_bits (x: u32): f32 = intrinsics.from_bits32 (intrinsics.sign_i32 x)@@ -1131,14 +1162,14 @@   module u16m = u16   module f64m = f64 -  def (x: f16) + (y: f16) = intrinsics.fadd16 (x, y)-  def (x: f16) - (y: f16) = intrinsics.fsub16 (x, y)-  def (x: f16) * (y: f16) = intrinsics.fmul16 (x, y)-  def (x: f16) / (y: f16) = intrinsics.fdiv16 (x, y)-  def (x: f16) % (y: f16) = intrinsics.fmod16 (x, y)-  def (x: f16) ** (y: f16) = intrinsics.fpow16 (x, y)+  def (+) (x: f16) (y: f16) = intrinsics.fadd16 (x, y)+  def (-) (x: f16) (y: f16) = intrinsics.fsub16 (x, y)+  def (*) (x: f16) (y: f16) = intrinsics.fmul16 (x, y)+  def (/) (x: f16) (y: f16) = intrinsics.fdiv16 (x, y)+  def (%) (x: f16) (y: f16) = intrinsics.fmod16 (x, y)+  def (**) (x: f16) (y: f16) = intrinsics.fpow16 (x, y) -  def u8  (x: u8)  = intrinsics.uitofp_i8_f16  (i8.u8 x)+  def u8 (x: u8) = intrinsics.uitofp_i8_f16 (i8.u8 x)   def u16 (x: u16) = intrinsics.uitofp_i16_f16 (i16.u16 x)   def u32 (x: u32) = intrinsics.uitofp_i32_f16 (i32.u32 x)   def u64 (x: u64) = intrinsics.uitofp_i64_f16 (i64.u64 x)@@ -1158,15 +1189,15 @@   def to_i64 (x: f16) = intrinsics.fptosi_f16_i64 x   def to_f64 (x: f16) = intrinsics.fpconv_f16_f64 x -  def (x: f16) == (y: f16) = intrinsics.eq_f16 (x, y)-  def (x: f16) < (y: f16) = intrinsics.lt16 (x, y)-  def (x: f16) > (y: f16) = intrinsics.lt16 (y, x)-  def (x: f16) <= (y: f16) = intrinsics.le16 (x, y)-  def (x: f16) >= (y: f16) = intrinsics.le16 (y, x)-  def (x: f16) != (y: f16) = !(x == y)+  def (==) (x: f16) (y: f16) = intrinsics.eq_f16 (x, y)+  def (<) (x: f16) (y: f16) = intrinsics.lt16 (x, y)+  def (>) (x: f16) (y: f16) = intrinsics.lt16 (y, x)+  def (<=) (x: f16) (y: f16) = intrinsics.le16 (x, y)+  def (>=) (x: f16) (y: f16) = intrinsics.le16 (y, x)+  def (!=) (x: f16) (y: f16) = !(x == y)    def neg (x: t) = -x-  def recip (x: t) = 1/x+  def recip (x: t) = 1 / x   def max (x: t) (y: t) = intrinsics.fmax16 (x, y)   def min (x: t) (y: t) = intrinsics.fmin16 (x, y) @@ -1200,19 +1231,19 @@   def erf = intrinsics.erf16   def erfc = intrinsics.erfc16 -  def lerp v0 v1 t = intrinsics.lerp16 (v0,v1,t)-  def fma a b c = intrinsics.fma16 (a,b,c)-  def mad a b c = intrinsics.mad16 (a,b,c)+  def lerp v0 v1 t = intrinsics.lerp16 (v0, v1, t)+  def fma a b c = intrinsics.fma16 (a, b, c)+  def mad a b c = intrinsics.mad16 (a, b, c)    def ceil = intrinsics.ceil16   def floor = intrinsics.floor16-  def trunc (x: f16) : f16 = i16 (i16m.f16 x)+  def trunc (x: f16): f16 = i16 (i16m.f16 x)    def round = intrinsics.round16 -  def nextafter x y = intrinsics.nextafter16 (x,y)-  def ldexp x y = intrinsics.ldexp16 (x,y)-  def copysign x y = intrinsics.copysign16 (x,y)+  def nextafter x y = intrinsics.nextafter16 (x, y)+  def ldexp x y = intrinsics.ldexp16 (x, y)+  def copysign x y = intrinsics.copysign16 (x, y)    def to_bits (x: f16): u16 = u16m.i16 (intrinsics.to_bits16 x)   def from_bits (x: u16): f16 = intrinsics.from_bits16 (intrinsics.sign_i16 x)

@@ -47,7 +47,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(S(f))*-def map 'a [n] 'x (f: a -> x) (as: [n]a): *[n]x =+def map 'a [n] 'x (f: a -> x) (as: [n]a) : *[n]x =   intrinsics.map f as  -- | Apply the given function to each element of a single array.@@ -55,7 +55,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(S(f))*-def map1 'a [n] 'x (f: a -> x) (as: [n]a): *[n]x =+def map1 'a [n] 'x (f: a -> x) (as: [n]a) : *[n]x =   map f as  -- | As `map1`@term, but with one more array.@@ -63,7 +63,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(S(f))*-def map2 'a 'b [n] 'x (f: a -> b -> x) (as: [n]a) (bs: [n]b): *[n]x =+def map2 'a 'b [n] 'x (f: a -> b -> x) (as: [n]a) (bs: [n]b) : *[n]x =   map (\(a, b) -> f a b) (zip2 as bs)  -- | As `map2`@term, but with one more array.@@ -71,7 +71,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(S(f))*-def map3 'a 'b 'c [n] 'x (f: a -> b -> c -> x) (as: [n]a) (bs: [n]b) (cs: [n]c): *[n]x =+def map3 'a 'b 'c [n] 'x (f: a -> b -> c -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) : *[n]x =   map (\(a, b, c) -> f a b c) (zip3 as bs cs)  -- | As `map3`@term, but with one more array.@@ -79,7 +79,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(S(f))*-def map4 'a 'b 'c 'd [n] 'x (f: a -> b -> c -> d -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d): *[n]x =+def map4 'a 'b 'c 'd [n] 'x (f: a -> b -> c -> d -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) : *[n]x =   map (\(a, b, c, d) -> f a b c d) (zip4 as bs cs ds)  -- | As `map3`@term, but with one more array.@@ -87,7 +87,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(S(f))*-def map5 'a 'b 'c 'd 'e [n] 'x (f: a -> b -> c -> d -> e -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e): *[n]x =+def map5 'a 'b 'c 'd 'e [n] 'x (f: a -> b -> c -> d -> e -> x) (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e) : *[n]x =   map (\(a, b, c, d, e) -> f a b c d e) (zip5 as bs cs ds es)  -- | Reduce the array `as` with `op`, with `ne` as the neutral@@ -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@@ -142,15 +142,15 @@ -- position), but *O(W(op))* in the best case. -- -- In practice, linear span only occurs if *k* is also very large.-def reduce_by_index 'a [k] [n] (dest : *[k]a) (f : a -> a -> a) (ne : a) (is : [n]i64) (as : [n]a) : *[k]a =+def reduce_by_index 'a [k] [n] (dest: *[k]a) (f: a -> a -> a) (ne: a) (is: [n]i64) (as: [n]a) : *[k]a =   intrinsics.hist_1d 1 dest f ne is as  -- | As `reduce_by_index`, but with two-dimensional indexes.-def reduce_by_index_2d 'a [k] [n] [m] (dest : *[k][m]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64)) (as : [n]a) : *[k][m]a =+def reduce_by_index_2d 'a [k] [n] [m] (dest: *[k][m]a) (f: a -> a -> a) (ne: a) (is: [n](i64, i64)) (as: [n]a) : *[k][m]a =   intrinsics.hist_2d 1 dest f ne is as  -- | As `reduce_by_index`, but with three-dimensional indexes.-def reduce_by_index_3d 'a [k] [n] [m] [l] (dest : *[k][m][l]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64,i64)) (as : [n]a) : *[k][m][l]a =+def reduce_by_index_3d 'a [k] [n] [m] [l] (dest: *[k][m][l]a) (f: a -> a -> a) (ne: a) (is: [n](i64, i64, i64)) (as: [n]a) : *[k][m][l]a =   intrinsics.hist_3d 1 dest f ne is as  -- | Inclusive prefix scan.  Has the same caveats with respect to@@ -159,7 +159,7 @@ -- **Work:** *O(n ✕ W(op))* -- -- **Span:** *O(log(n) ✕ W(op))*-def scan [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a): *[n]a =+def scan [n] 'a (op: a -> a -> a) (ne: a) (as: [n]a) : *[n]a =   intrinsics.scan op ne as  -- | Split an array into those elements that satisfy the given@@ -168,7 +168,7 @@ -- **Work:** *O(n ✕ W(p))* -- -- **Span:** *O(log(n) ✕ W(p))*-def partition [n] 'a (p: a -> bool) (as: [n]a): ?[k].([k]a, [n-k]a) =+def partition [n] 'a (p: a -> bool) (as: [n]a) : ?[k].([k]a, [n - k]a) =   let p' x = if p x then 0 else 1   let (as', is) = intrinsics.partition 2 p' as   in (as'[0:is[0]], as'[is[0]:n])@@ -178,12 +178,13 @@ -- **Work:** *O(n ✕ (W(p1) + W(p2)))* -- -- **Span:** *O(log(n) ✕ (W(p1) + W(p2)))*-def partition2 [n] 'a (p1: a -> bool) (p2: a -> bool) (as: [n]a): ?[k][l].([k]a, [l]a, [n-k-l]a) =+def partition2 [n] 'a (p1: a -> bool) (p2: a -> bool) (as: [n]a) : ?[k][l].([k]a, [l]a, [n - k - l]a) =   let p' x = if p1 x then 0 else if p2 x then 1 else 2   let (as', is) = intrinsics.partition 3 p' as-  in (as'[0:is[0]],-      as'[is[0]:is[0]+is[1]] :> [is[1]]a,-      as'[is[0]+is[1]:n] :> [n-is[0]-is[1]]a)+  in ( as'[0:is[0]]+     , as'[is[0]:is[0] + is[1]] :> [is[1]]a+     , as'[is[0] + is[1]:n] :> [n - is[0] - is[1]]a+     )  -- | Return `true` if the given function returns `true` for all -- elements in the array.@@ -191,7 +192,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(log(n) + S(f))*-def all [n] 'a (f: a -> bool) (as: [n]a): bool =+def all [n] 'a (f: a -> bool) (as: [n]a) : bool =   reduce (&&) true (map f as)  -- | Return `true` if the given function returns `true` for any@@ -200,7 +201,7 @@ -- **Work:** *O(n ✕ W(f))* -- -- **Span:** *O(log(n) + S(f))*-def any [n] 'a (f: a -> bool) (as: [n]a): bool =+def any [n] 'a (f: a -> bool) (as: [n]a) : bool =   reduce (||) false (map f as)  -- | `r = spread k x is vs` produces an array `r` such that `r[i] =@@ -214,7 +215,7 @@ -- **Work:** *O(k + n)* -- -- **Span:** *O(1)*-def spread 't [n] (k: i64) (x: t) (is: [n]i64) (vs: [n]t): *[k]t =+def spread 't [n] (k: i64) (x: t) (is: [n]i64) (vs: [n]t) : *[k]t =   intrinsics.scatter (map (\_ -> x) (0..1..<k)) is vs  -- | Like `spread`, but takes an array indicating the initial values,@@ -223,7 +224,7 @@ -- **Work:** *O(n)* -- -- **Span:** *O(1)*-def scatter 't [k] [n] (dest: *[k]t) (is: [n]i64) (vs: [n]t): *[k]t =+def scatter 't [k] [n] (dest: *[k]t) (is: [n]i64) (vs: [n]t) : *[k]t =   intrinsics.scatter dest is vs  -- | `scatter_2d as is vs` is the equivalent of a `scatter` on a 2-dimensional@@ -232,7 +233,7 @@ -- **Work:** *O(n)* -- -- **Span:** *O(1)*-def scatter_2d 't [k] [n] [l] (dest: *[k][n]t) (is: [l](i64, i64)) (vs: [l]t): *[k][n]t =+def scatter_2d 't [k] [n] [l] (dest: *[k][n]t) (is: [l](i64, i64)) (vs: [l]t) : *[k][n]t =   intrinsics.scatter_2d dest is vs  -- | `scatter_3d as is vs` is the equivalent of a `scatter` on a 3-dimensional@@ -241,7 +242,7 @@ -- **Work:** *O(n)* -- -- **Span:** *O(1)*-def scatter_3d 't [k] [n] [o] [l] (dest: *[k][n][o]t) (is: [l](i64, i64, i64)) (vs: [l]t): *[k][n][o]t =+def scatter_3d 't [k] [n] [o] [l] (dest: *[k][n][o]t) (is: [l](i64, i64, i64)) (vs: [l]t) : *[k][n][o]t =   intrinsics.scatter_3d dest is vs  -- | Remove all those elements of `as` that do not satisfy the@@ -250,10 +251,10 @@ -- **Work:** *O(n ✕ W(p))* -- -- **Span:** *O(log(n) ✕ W(p))*-def filter [n] 'a (p: a -> bool) (as: [n]a): *[]a =+def filter [n] 'a (p: a -> bool) (as: [n]a) : *[]a =   let flags = map (\x -> if p x then 1 else 0) as   let offsets = scan (+) 0 flags-  let m = if n == 0 then 0 else offsets[n-1]+  let m = if n == 0 then 0 else offsets[n - 1]   in scatter (map (\x -> x) as[:m])-             (map2 (\f o -> if f==1 then o-1 else -1) flags offsets)+             (map2 (\f o -> if f == 1 then o - 1 else -1) flags offsets)              as

@@ -6,55 +6,54 @@  -- The main reason this module exists is that we need it to define -- SOACs like `map2`.- -- We need a map to define some of the zip variants, but this file is -- depended upon by soacs.fut.  So we just define a quick-and-dirty -- internal one here that uses the intrinsic version.-local def internal_map 'a [n] 'x (f: a -> x) (as: [n]a): *[n]x =+local def internal_map 'a [n] 'x (f: a -> x) (as: [n]a) : *[n]x =   intrinsics.map f as  -- | Construct an array of pairs from two arrays.-def zip [n] 'a 'b (as: [n]a) (bs: [n]b): *[n](a,b) =+def zip [n] 'a 'b (as: [n]a) (bs: [n]b) : *[n](a, b) =   intrinsics.zip as bs  -- | Construct an array of pairs from two arrays.-def zip2 [n] 'a 'b (as: [n]a) (bs: [n]b): *[n](a,b) =+def zip2 [n] 'a 'b (as: [n]a) (bs: [n]b) : *[n](a, b) =   zip as bs  -- | As `zip2`@term, but with one more array.-def zip3 [n] 'a 'b 'c (as: [n]a) (bs: [n]b) (cs: [n]c): *[n](a,b,c) =-  internal_map (\(a,(b,c)) -> (a,b,c)) (zip as (zip2 bs cs))+def zip3 [n] 'a 'b 'c (as: [n]a) (bs: [n]b) (cs: [n]c) : *[n](a, b, c) =+  internal_map (\(a, (b, c)) -> (a, b, c)) (zip as (zip2 bs cs))  -- | As `zip3`@term, but with one more array.-def zip4 [n] 'a 'b 'c 'd (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d): *[n](a,b,c,d) =-  internal_map (\(a,(b,c,d)) -> (a,b,c,d)) (zip as (zip3 bs cs ds))+def zip4 [n] 'a 'b 'c 'd (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) : *[n](a, b, c, d) =+  internal_map (\(a, (b, c, d)) -> (a, b, c, d)) (zip as (zip3 bs cs ds))  -- | As `zip4`@term, but with one more array.-def zip5 [n] 'a 'b 'c 'd 'e (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e): *[n](a,b,c,d,e) =-  internal_map (\(a,(b,c,d,e)) -> (a,b,c,d,e)) (zip as (zip4 bs cs ds es))+def zip5 [n] 'a 'b 'c 'd 'e (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e) : *[n](a, b, c, d, e) =+  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) =-  let (as, bcs) = unzip (internal_map (\(a,b,c) -> (a,(b,c))) xs)+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) =-  let (as, bs, cds) = unzip3 (internal_map (\(a,b,c,d) -> (a,b,(c,d))) xs)+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) =-  let (as, bs, cs, des) = unzip4 (internal_map (\(a,b,c,d,e) -> (a,b,c,(d,e))) xs)+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)

@@ -26,7 +26,10 @@ pdUnOp :: UnOp -> PrimExp VName -> PrimExp VName pdUnOp (Abs it) a = UnOpExp (SSignum it) a pdUnOp (FAbs ft) a = UnOpExp (FSignum ft) a-pdUnOp Not x = x+pdUnOp (Neg Bool) x = x+pdUnOp (Neg Unit) x = x+pdUnOp (Neg (IntType it)) _ = iConst it (-1)+pdUnOp (Neg (FloatType ft)) _ = fConst ft (-1) pdUnOp (Complement it) x = UnOpExp (Complement it) x pdUnOp (SSignum it) _ = iConst it 0 pdUnOp (USignum it) _ = iConst it 0

@@ -230,7 +230,7 @@   | zeroIshExp y = x constFoldPrimExp (UnOpExp Abs {} x)   | not $ negativeIshExp x = x-constFoldPrimExp (UnOpExp Not {} (ValueExp (BoolValue x))) =+constFoldPrimExp (UnOpExp (Neg _) (ValueExp (BoolValue x))) =   ValueExp $ BoolValue $ not x constFoldPrimExp (BinOpExp UMod {} x y)   | sameIshExp x y,@@ -642,7 +642,7 @@  -- | Boolean negation smart constructor. bNot :: TPrimExp Bool v -> TPrimExp Bool v-bNot = TPrimExp . UnOpExp Not . untyped+bNot = TPrimExp . UnOpExp (Neg Bool) . untyped  -- | SMax on 32-bit integers. sMax32 :: TPrimExp Int32 v -> TPrimExp Int32 v -> TPrimExp Int32 v

@@ -10,7 +10,7 @@ import Data.Either import Data.Function ((&)) import Data.IORef-import Data.List (sortBy)+import Data.List (intersect, sortBy) import Data.Map qualified as M import Data.Maybe import Data.Ord@@ -57,7 +57,7 @@     optJSON :: Maybe FilePath,     optTimeout :: Int,     optSkipCompilation :: Bool,-    optExcludeCase :: [String],+    optExcludeCase :: [T.Text],     optIgnoreFiles :: [Regex],     optEntryPoint :: Maybe String,     optTuning :: Maybe String,@@ -171,8 +171,10 @@   spec <- maybe (pure program_spec) testSpecFromFileOrDie $ optTestSpec opts   case testAction spec of     RunCases cases _ _-      | "nobench" `notElem` testTags spec,-        "disable" `notElem` testTags spec,+      | null $+          optExcludeCase opts+            `intersect` testTags spec+            <> testTags program_spec,         any hasRuns cases ->           if optSkipCompilation opts             then do@@ -533,7 +535,7 @@       ["exclude-case"]       ( ReqArg           ( \s -> Right $ \config ->-              config {optExcludeCase = s : optExcludeCase config}+              config {optExcludeCase = T.pack s : optExcludeCase config}           )           "TAG"       )@@ -636,7 +638,11 @@  excludeBackend :: BenchOptions -> BenchOptions excludeBackend config =-  config {optExcludeCase = "no_" <> optBackend config : optExcludeCase config}+  config+    { optExcludeCase =+        "no_" <> T.pack (optBackend config)+          : optExcludeCase config+    }  -- | Run @futhark bench@. main :: String -> [String] -> IO ()

@@ -801,6 +801,7 @@                 Defunctorise.transformProg imports                   >>= ApplyTypeAbbrs.transformProg                   >>= FullNormalise.transformProg+                  >>= ReplaceRecords.transformProg                   >>= LiftLambdas.transformProg         Monomorphise -> do           (_, imports, src) <- readProgram'@@ -810,6 +811,7 @@                 Defunctorise.transformProg imports                   >>= ApplyTypeAbbrs.transformProg                   >>= FullNormalise.transformProg+                  >>= ReplaceRecords.transformProg                   >>= LiftLambdas.transformProg                   >>= Monomorphise.transformProg         Defunctionalise -> do@@ -820,9 +822,9 @@                 Defunctorise.transformProg imports                   >>= ApplyTypeAbbrs.transformProg                   >>= FullNormalise.transformProg+                  >>= ReplaceRecords.transformProg                   >>= LiftLambdas.transformProg                   >>= Monomorphise.transformProg-                  >>= ReplaceRecords.transformProg                   >>= Defunctionalise.transformProg         Pipeline {} -> do           let (base, ext) = splitExtension file

@@ -24,45 +24,25 @@ import System.IO import Text.Blaze.Html.Renderer.Text --- | Run @futhark doc@.-main :: String -> [String] -> IO ()-main = mainWithOptions initialDocConfig commandLineOptions "options... -o outdir programs..." f-  where-    f [dir] config = Just $ do-      res <- runFutharkM (m config dir) Verbose-      case res of-        Left err -> liftIO $ do-          dumpError newFutharkConfig err-          exitWith $ ExitFailure 2-        Right () ->-          pure ()-    f _ _ = Nothing--    m :: DocConfig -> FilePath -> FutharkM ()-    m config dir =-      case docOutput config of-        Nothing -> liftIO $ do-          hPutStrLn stderr "Must specify output directory with -o."-          exitWith $ ExitFailure 1-        Just outdir -> do-          files <- liftIO $ futFiles dir-          when (docVerbose config) $-            liftIO $ do-              mapM_ (hPutStrLn stderr . ("Found source file " <>)) files-              hPutStrLn stderr "Reading files..."-          (_w, imports, _vns) <- readProgramFiles [] files-          liftIO $ printDecs config outdir files $ nubBy sameImport imports+cssFile :: T.Text+cssFile = $(embedStringFile "rts/futhark-doc/style.css") -    sameImport (x, _) (y, _) = x == y+data DocConfig = DocConfig+  { docOutput :: Maybe FilePath,+    docVerbose :: Bool+  } -futFiles :: FilePath -> IO [FilePath]-futFiles dir = filter isFut <$> directoryContents dir-  where-    isFut = (== ".fut") . takeExtension+initialDocConfig :: DocConfig+initialDocConfig =+  DocConfig+    { docOutput = Nothing,+      docVerbose = False+    }  printDecs :: DocConfig -> FilePath -> [FilePath] -> Imports -> IO () printDecs cfg dir files imports = do-  let direct_imports = map (mkInitialImport . normalise . dropExtension) files+  let direct_imports =+        map (mkInitialImport . normalise . dropExtension) files       (file_htmls, _warnings) =         renderFiles direct_imports $           filter (not . ignored) imports@@ -72,9 +52,7 @@     write :: (FilePath, T.Text) -> IO ()     write (name, content) = do       let file = dir </> makeRelative "/" name-      when (docVerbose cfg) $-        hPutStrLn stderr $-          "Writing " <> file+      when (docVerbose cfg) $ hPutStrLn stderr $ "Writing " <> file       createDirectoryIfMissing True $ takeDirectory file       T.writeFile file content @@ -86,21 +64,6 @@         Just (DocComment s _) -> T.strip s == "ignore"         _ -> False -cssFile :: T.Text-cssFile = $(embedStringFile "rts/futhark-doc/style.css")--data DocConfig = DocConfig-  { docOutput :: Maybe FilePath,-    docVerbose :: Bool-  }--initialDocConfig :: DocConfig-initialDocConfig =-  DocConfig-    { docOutput = Nothing,-      docVerbose = False-    }- type DocOption = OptDescr (Either (IO ()) (DocConfig -> DocConfig))  commandLineOptions :: [DocOption]@@ -119,3 +82,39 @@       (NoArg $ Right $ \config -> config {docVerbose = True})       "Print status messages on stderr."   ]++futFiles :: FilePath -> IO [FilePath]+futFiles dir = filter isFut <$> directoryContents dir+  where+    isFut = (== ".fut") . takeExtension++-- | Run @futhark doc@.+main :: String -> [String] -> IO ()+main = mainWithOptions initialDocConfig commandLineOptions "options... -o outdir programs..." f+  where+    f [dir] config = Just $ do+      res <- runFutharkM (m config dir) Verbose+      case res of+        Left err -> liftIO $ do+          dumpError newFutharkConfig err+          exitWith $ ExitFailure 2+        Right () ->+          pure ()+    f _ _ = Nothing++    m :: DocConfig -> FilePath -> FutharkM ()+    m config dir =+      case docOutput config of+        Nothing -> liftIO $ do+          hPutStrLn stderr "Must specify output directory with -o."+          exitWith $ ExitFailure 1+        Just outdir -> do+          files <- liftIO $ futFiles dir+          when (docVerbose config) $+            liftIO $ do+              mapM_ (hPutStrLn stderr . ("Found source file " <>)) files+              hPutStrLn stderr "Reading files..."+          (_w, imports, _vns) <- readProgramFiles [] files+          liftIO $ printDecs config outdir files $ nubBy sameImport imports++    sameImport (x, _) (y, _) = x == y

@@ -0,0 +1,29 @@+-- | @futhark fmt@+module Futhark.CLI.Fmt (main) where++import Control.Monad (forM_)+import Data.Text.IO qualified as T+import Futhark.Fmt.Printer+import Futhark.Util.Options+import Futhark.Util.Pretty (hPutDoc, putDoc)+import Language.Futhark+import Language.Futhark.Parser (SyntaxError (..))+import System.Exit+import System.IO++-- | Run @futhark fmt@.+main :: String -> [String] -> IO ()+main = mainWithOptions () [] "[FILES" $ \args () ->+  case args of+    [] -> Just $ putDoc =<< onInput =<< T.getContents+    files ->+      Just $ forM_ files $ \file -> do+        doc <- onInput =<< T.readFile file+        withFile file WriteMode $ \h -> hPutDoc h doc+  where+    onInput s = do+      case fmtToDoc "<stdin>" s of+        Left (SyntaxError loc err) -> do+          T.hPutStr stderr $ locText loc <> ":\n" <> prettyText err+          exitFailure+        Right fmt -> pure fmt

@@ -17,6 +17,7 @@ import Futhark.CLI.Dev qualified as Dev import Futhark.CLI.Doc qualified as Doc import Futhark.CLI.Eval qualified as Eval+import Futhark.CLI.Fmt qualified as Fmt import Futhark.CLI.HIP qualified as HIP import Futhark.CLI.LSP qualified as LSP import Futhark.CLI.Literate qualified as Literate@@ -85,7 +86,8 @@       ("thanks", (Misc.mainThanks, "Express gratitude.")),       ("tokens", (Misc.mainTokens, "Print tokens from Futhark file.")),       ("benchcmp", (Benchcmp.main, "Compare two benchmark results.")),-      ("profile", (Profile.main, "Analyse profiling data."))+      ("profile", (Profile.main, "Analyse profiling data.")),+      ("fmt", (Fmt.main, "Reformat Futhark source file."))     ]  msg :: String

@@ -169,24 +169,26 @@   where     couldNotRead e = pure $ Left $ show (e :: IOError) +onFile :: FilePath -> IO ()+onFile json_path = do+  s <- readFileSafely json_path+  case s of+    Left a -> do+      hPutStrLn stderr a+      exitWith $ ExitFailure 2+    Right s' ->+      case decodeBenchResults s' of+        Left _ ->+          case decodeProfilingReport s' of+            Nothing -> do+              hPutStrLn stderr $+                "Cannot recognise " <> json_path <> " as benchmark results or a profiling report."+            Just pr ->+              analyseProfilingReport json_path pr+        Right br -> analyseBenchResults json_path br+ -- | Run @futhark profile@. main :: String -> [String] -> IO ()-main = mainWithOptions () [] "<file>" f+main = mainWithOptions () [] "[files]" f   where-    f [json_path] () = Just $ do-      s <- readFileSafely json_path-      case s of-        Left a -> do-          hPutStrLn stderr a-          exitWith $ ExitFailure 2-        Right s' ->-          case decodeBenchResults s' of-            Left _ ->-              case decodeProfilingReport s' of-                Nothing -> do-                  hPutStrLn stderr $-                    "Cannot recognise " <> json_path <> " as benchmark results or a profiling report."-                Just pr ->-                  analyseProfilingReport json_path pr-            Right br -> analyseBenchResults json_path br-    f _ _ = Nothing+    f files () = Just $ mapM_ onFile files

@@ -9,7 +9,7 @@ import Control.Monad.Free.Church import Control.Monad.State import Data.Char-import Data.List (intersperse)+import Data.List (intersperse, isPrefixOf) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe@@ -55,6 +55,10 @@  data StopReason = EOF | Stop | Exit | Load FilePath | Interrupt +replSettings :: Haskeline.Settings IO+replSettings =+  Haskeline.setComplete replComplete Haskeline.defaultSettings+ repl :: Maybe FilePath -> IO () repl maybe_prog = do   when fancyTerminal $ do@@ -103,7 +107,7 @@           pure s {futharkiLoaded = maybe_prog}     Right s ->       pure s-  Haskeline.runInputT Haskeline.defaultSettings $ toploop s+  Haskeline.runInputT replSettings $ toploop s    putStrLn "Leaving 'futhark repl'." @@ -111,8 +115,7 @@ -- navigating through the stack frames and such. data Breaking = Breaking   { breakingStack :: NE.NonEmpty I.StackFrame,-    -- | Index of the current breakpoint (with-    -- 0 being the outermost).+    -- | Index of the current breakpoint (with 0 being the outermost).     breakingAt :: Int   } @@ -372,6 +375,15 @@         T.putStrLn $           locText w <> ": " <> "ignoring breakpoint when computating constant."       c++replComplete :: Haskeline.CompletionFunc IO+replComplete = loadComplete+  where+    loadComplete (prev, aft)+      | ":load " `isPrefixOf` reverse prev =+          Haskeline.completeFilename (prev, aft)+      | otherwise =+          Haskeline.noCompletion (prev, aft)  type Command = T.Text -> FutharkiM () 

@@ -5,6 +5,7 @@  import Control.Applicative.Lift (Errors, Lift (..), failure, runErrors) import Control.Concurrent+import Control.Concurrent.Async import Control.Exception import Control.Monad import Control.Monad.Except (ExceptT (..), MonadError, runExceptT, withExceptT)@@ -87,6 +88,10 @@     collectErrors Success errs = errs     collectErrors (Failure err) errs = err : errs +-- | The longest we are willing to wait for a test, in microseconds.+timeout :: Int+timeout = 5 * 60 * 1000000+ withProgramServer :: FilePath -> FilePath -> [String] -> (Server -> IO [TestResult]) -> TestM () withProgramServer program runner extra_options f = do   -- Explicitly prefixing the current directory is necessary for@@ -102,10 +107,13 @@       prog_ctx =         "Running " <> T.pack (unwords $ binpath : extra_options) -  context prog_ctx $-    pureTestResults $-      liftIO $-        withServer (futharkServerCfg to_run to_run_args) f+  context prog_ctx . pureTestResults . liftIO $+    withServer (futharkServerCfg to_run to_run_args) $ \server ->+      race (threadDelay timeout) (f server) >>= \case+        Left _ -> do+          abortServer server+          fail $ "test timeout after " <> show timeout <> " microseconds"+        Right r -> pure r  data TestMode   = -- | Only type check.@@ -481,7 +489,7 @@     onAction action = action     onIOs (InputOutputs entry runs) =       InputOutputs entry $ filter (not . any excluded . runTags) runs-    excluded = (`elem` configExclude config) . T.pack+    excluded = (`elem` configExclude config)  putStatusTable :: TestStatus -> IO () putStatusTable ts = hPutTable stdout rows 1@@ -528,13 +536,12 @@     if systemSeconds time_now - systemSeconds time >= period       then do         T.putStrLn $-          "("-            <> showText (testStatusFail ts)+          showText (testStatusFail ts)             <> " failed, "             <> showText (testStatusPass ts)             <> " passed, "             <> showText num_remain-            <> " to go)."+            <> " to go."         pure time_now       else pure time   where

@@ -56,15 +56,18 @@ compilePrimExp f (UnOpExp Complement {} x) = do   x' <- compilePrimExp f x   pure [C.cexp|~$exp:x'|]-compilePrimExp f (UnOpExp Not {} x) = do-  x' <- compilePrimExp f x-  pure [C.cexp|!$exp:x'|] compilePrimExp f (UnOpExp SSignum {} x) = do   x' <- compilePrimExp f x   pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0)|] compilePrimExp f (UnOpExp USignum {} x) = do   x' <- compilePrimExp f x   pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0) != 0|]+compilePrimExp f (UnOpExp (Neg Bool) x) = do+  x' <- compilePrimExp f x+  pure [C.cexp|!$exp:x'|]+compilePrimExp f (UnOpExp Neg {} x) = do+  x' <- compilePrimExp f x+  pure [C.cexp|-$exp:x'|] compilePrimExp f (UnOpExp op x) = do   x' <- compilePrimExp f x   pure [C.cexp|$id:(prettyString op)($exp:x')|]

@@ -18,25 +18,28 @@ import Text.PrettyPrint.Mainland qualified as MPP import Text.PrettyPrint.Mainland.Class qualified as MPP +render :: MPP.Doc -> String+render = MPP.pretty 8000+ -- | Prettyprint a C expression. expText :: C.Exp -> T.Text-expText = T.pack . MPP.pretty 8000 . MPP.ppr+expText = T.pack . render . MPP.ppr  -- | Prettyprint a list of C definitions. definitionsText :: [C.Definition] -> T.Text-definitionsText = T.unlines . map (T.pack . MPP.pretty 8000 . MPP.ppr)+definitionsText = T.unlines . map (T.pack . render . MPP.ppr)  -- | Prettyprint a single C type. typeText :: C.Type -> T.Text-typeText = T.pack . MPP.pretty 8000 . MPP.ppr+typeText = T.pack . render . MPP.ppr  -- | Prettyprint a single identifier. idText :: C.Id -> T.Text-idText = T.pack . MPP.pretty 8000 . MPP.ppr+idText = T.pack . render . MPP.ppr  -- | Prettyprint a single function. funcText :: C.Func -> T.Text-funcText = T.pack . MPP.pretty 8000 . MPP.ppr+funcText = T.pack . render . MPP.ppr  -- | Prettyprint a list of functions. funcsText :: [C.Func] -> T.Text

@@ -992,7 +992,8 @@ compileUnOp :: Imp.UnOp -> String compileUnOp op =   case op of-    Not -> "not"+    Neg Imp.Bool -> "not"+    Neg _ -> "-"     Complement {} -> "~"     Abs {} -> "abs"     FAbs {} -> "abs"

@@ -20,7 +20,6 @@ import Data.Bifunctor import Data.DList qualified as DL import Data.List (unzip4)-import Data.Loc (noLoc) import Data.Map qualified as M import Data.Maybe import Data.Text qualified as T@@ -415,9 +414,12 @@ compileExp (UnOpExp Complement {} x) = do   x' <- compileExp x   pure [C.cexp|~$exp:x'|]-compileExp (UnOpExp Not {} x) = do+compileExp (UnOpExp (Neg Bool) x) = do   x' <- compileExp x   pure [C.cexp|!$exp:x'|]+compileExp (UnOpExp Neg {} x) = do+  x' <- compileExp x+  pure [C.cexp|-$exp:x'|] compileExp (UnOpExp (FAbs Float32) x) = do   x' <- compileExp x   pure [C.cexp|(float)fabs($exp:x')|]

@@ -147,7 +147,6 @@ import Futhark.IR.SOACS (SOACS) import Futhark.Util import Futhark.Util.IntegralExp-import Futhark.Util.Loc (noLoc) import Futhark.Util.Pretty hiding (nest, space) import Language.Futhark.Warnings import Prelude hiding (mod, quot)

@@ -25,7 +25,7 @@ import Text.Blaze.Html5 (AttributeValue, Html, toHtml, (!)) import Text.Blaze.Html5 qualified as H import Text.Blaze.Html5.Attributes qualified as A-import Prelude hiding (abs)+import Prelude hiding (abs, mod)  docToHtml :: Doc a -> Html docToHtml = toHtml . docText@@ -63,28 +63,57 @@ -- are uninteresting.  These are for example type parameters. type NoLink = S.Set VName +-- | A mapping from unique names to the file in which they exist, and+-- the anchor (not necessarily globally unique) for linking to that+-- name.+type FileMap = M.Map VName (FilePath, String)++vnameToFileMap :: Imports -> FileMap+vnameToFileMap = mconcat . map forFile+  where+    forFile (file, FileModule _ file_env _prog _) =+      forEnv "" file_env+      where+        file' = makeRelative "/" $ includeToFilePath file+        vname prefix ns v =+          M.singleton (qualLeaf v) (file', canon ns $ prefix <> baseString (qualLeaf v))+        vname' prefix ((ns, _), v) = vname prefix ns v+        canon Term s = "term:" <> s+        canon Type s = "type:" <> s+        canon Signature s = "modtype:" <> s++        forEnv prefix env =+          mconcat (map (forType prefix) $ M.toList $ envTypeTable env)+            <> mconcat (map (forMod prefix) $ M.toList $ envModTable env)+            <> mconcat (map (forMty prefix) $ M.toList $ envModTypeTable env)+            <> mconcat (map (vname' prefix) $ M.toList $ envNameMap env)+        forMod prefix (name, ModEnv env) =+          forEnv (prefix <> baseString name <> ".") env+        forMod _ (_, ModFun {}) = mempty+        forMty prefix (name, MTy abs mod) =+          forMod prefix (name, mod)+            <> mconcat (map (vname prefix Type) (M.keys abs))+        forType prefix = vname prefix Type . qualName . fst+ data Context = Context   { ctxCurrent :: String,     ctxFileMod :: FileModule,     ctxImports :: Imports,     ctxNoLink :: NoLink,     ctxFileMap :: FileMap,-    -- | Local module types that show up in the-    -- interface.  These should be documented,-    -- but clearly marked local.+    -- | Local module types that show up in the interface. These+    -- should be documented, but clearly marked local.     ctxVisibleMTys :: S.Set VName   } -type FileMap = M.Map VName (FilePath, Namespace)+-- | We keep a mapping of the names we have actually documented, so we+-- can generate an index.+type Documented = M.Map VName IndexWhat  type DocM = ReaderT Context (WriterT Documented (Writer Warnings))  data IndexWhat = IndexValue | IndexFunction | IndexModule | IndexModuleType | IndexType --- | We keep a mapping of the names we have actually documented, so we--- can generate an index.-type Documented = M.Map VName IndexWhat- warn :: Loc -> Doc () -> DocM () warn loc s = lift $ lift $ tell $ singleWarning loc s @@ -111,78 +140,6 @@       <> (H.td ! A.class_ "spec_eql") b       <> (H.td ! A.class_ "spec_rhs") c -vnameToFileMap :: Imports -> FileMap-vnameToFileMap = mconcat . map forFile-  where-    forFile (file, FileModule abs file_env _prog _) =-      mconcat (map (vname Type) (M.keys abs))-        <> forEnv file_env-      where-        file' = makeRelative "/" $ includeToFilePath file-        vname ns v = M.singleton (qualLeaf v) (file', ns)-        vname' ((ns, _), v) = vname ns v--        forEnv env =-          mconcat (map vname' $ M.toList $ envNameMap env)-            <> mconcat (map forMty $ M.elems $ envModTypeTable env)-        forMod (ModEnv env) = forEnv env-        forMod ModFun {} = mempty-        forMty = forMod . mtyMod---- | @renderFiles important_imports imports@ produces HTML files--- documenting the type-checked program @imports@, with the files in--- @important_imports@ considered most important.  The HTML files must--- be written to the specific locations indicated in the return value,--- or the relative links will be wrong.-renderFiles :: [ImportName] -> Imports -> ([(FilePath, Html)], Warnings)-renderFiles important_imports imports = runWriter $ do-  (import_pages, documented) <- runWriterT $-    forM imports $ \(current, fm) ->-      let ctx =-            Context-              { ctxCurrent = makeRelative "/" $ includeToFilePath current,-                ctxFileMod = fm,-                ctxImports = imports,-                ctxNoLink = mempty,-                ctxFileMap = file_map,-                ctxVisibleMTys = progModuleTypes $ fileProg fm-              }-       in flip runReaderT ctx $ do-            (first_paragraph, maybe_abstract, maybe_sections) <- headerDoc $ fileProg fm--            synopsis <- (H.div ! A.id "module") <$> synopsisDecs (progDecs $ fileProg fm)--            description <- describeDecs $ progDecs $ fileProg fm--            pure-              ( current,-                ( H.docTypeHtml ! A.lang "en"-                    $ addBoilerplateWithNav-                      important_imports-                      imports-                      ("doc" </> includeToFilePath current)-                      (includeToString current)-                    $ H.main-                    $ maybe_abstract-                      <> selfLink "synopsis" (H.h2 "Synopsis")-                      <> (H.div ! A.id "overview") synopsis-                      <> selfLink "description" (H.h2 "Description")-                      <> description-                      <> maybe_sections,-                  first_paragraph-                )-              )--  pure $-    [ ("index.html", contentsPage important_imports $ map (fmap snd) import_pages),-      ("doc-index.html", indexPage important_imports imports documented file_map)-    ]-      ++ map (importHtml *** fst) import_pages-  where-    file_map = vnameToFileMap imports-    importHtml import_name =-      "doc" </> makeRelative "/" (fromString (includeToString import_name)) -<.> "html"- -- | The header documentation (which need not be present) can contain -- an abstract and further sections. headerDoc :: Prog -> DocM (Html, Html, Html)@@ -264,9 +221,9 @@           mapMaybe isDocumented $             M.toList fm -    isDocumented (k, (file, _)) = do+    isDocumented (k, (file, k_id)) = do       what <- M.lookup k documented-      Just (k, (file, what))+      Just (k, (file, (what, k_id)))      (letter_groups, letter_group_links) =       unzip $ map tbodyForNames $ groupBy sameInitial letter_names@@ -301,10 +258,11 @@     initialListEntry initial =       H.li $ H.a ! A.href (fromString $ '#' : initial) $ fromString initial -    linkTo (name, (file, what)) =+    linkTo (name, (file, (what, name_id))) =       let file' = makeRelative "/" file+          name_link = vnameLink' name_id "" file'           link =-            (H.a ! A.href (fromString (makeRelative "/" $ "doc" </> vnameLink' name "" file'))) $+            (H.a ! A.href (fromString (makeRelative "/" $ "doc" </> name_link))) $               fromString $                 baseString name           what' = case what of@@ -408,17 +366,24 @@   pure $ "... : " <> se' synopsisOpened _ = Nothing +vnameSynopsisDef :: VName -> DocM Html+vnameSynopsisDef vname = do+  (_, vname_id) <- vnameId vname+  pure $+    H.span ! A.id (fromString ("synopsis:" <> vname_id)) $+      H.a ! A.href (fromString ("#" ++ vname_id)) $+        renderName (baseName vname)+ synopsisValBind :: ValBind -> Maybe (DocM Html) synopsisValBind vb = Just $ do-  let name' = vnameSynopsisDef $ valBindName vb+  name' <- vnameSynopsisDef $ valBindName vb   (lhs, mhs, rhs) <- valBindHtml name' vb   pure $ specRow lhs (mhs <> " : ") rhs  valBindHtml :: Html -> ValBind -> DocM (Html, Html, Html) valBindHtml name (ValBind _ _ retdecl (Info rettype) tparams params _ _ _ _) = do-  let tparams' = mconcat $ map ((" " <>) . typeParamHtml) tparams-      noLink' =-        noLink $ map typeParamName tparams <> foldMap patNames params+  tparams' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) tparams+  let noLink' = noLink $ map typeParamName tparams <> foldMap patNames params   rettype' <- noLink' $ maybe (retTypeHtml rettype) typeExpHtml retdecl   params' <- noLink' $ mapM paramHtml params   pure@@ -429,7 +394,7 @@  synopsisModType :: Html -> ModTypeBind -> Maybe (DocM Html) synopsisModType prefix sb = Just $ do-  let name' = vnameSynopsisDef $ modTypeName sb+  name' <- vnameSynopsisDef $ modTypeName sb   fullRow <$> do     se' <- synopsisModTypeExp $ modTypeExp sb     pure $ prefix <> keyword "module type " <> name' <> " = " <> se'@@ -441,7 +406,7 @@     Just (s, _) -> Just $ proceed =<< synopsisModTypeExp s   where     proceed sig' = do-      let name' = vnameSynopsisDef name+      name' <- vnameSynopsisDef name       ps' <- modParamHtml ps       pure $ specRow (keyword "module " <> name') ": " (ps' <> sig') @@ -451,13 +416,14 @@  synopsisType :: TypeBind -> Maybe (DocM Html) synopsisType tb = Just $ do-  let name' = vnameSynopsisDef $ typeAlias tb+  name' <- vnameSynopsisDef $ typeAlias tb   fullRow <$> typeBindHtml name' tb  typeBindHtml :: Html -> TypeBind -> DocM Html typeBindHtml name' (TypeBind _ l tparams t _ _ _) = do   t' <- noLink (map typeParamName tparams) $ typeExpHtml t-  pure $ typeAbbrevHtml l name' tparams <> " = " <> t'+  abbrev <- typeAbbrevHtml l name' tparams+  pure $ abbrev <> " = " <> t'  renderEnv :: Env -> DocM Html renderEnv (Env vtable ttable sigtable modtable _) = do@@ -481,18 +447,16 @@ renderTypeBind :: (VName, TypeBinding) -> DocM Html renderTypeBind (name, TypeAbbr l tps tp) = do   tp' <- retTypeHtml $ toResRet Nonunique tp-  pure $ H.div $ typeAbbrevHtml l (vnameHtml name) tps <> " = " <> tp'+  name' <- vnameHtml name+  abbrev <- typeAbbrevHtml l name' tps+  pure $ H.div $ abbrev <> " = " <> tp'  synopsisValBindBind :: (VName, BoundV) -> DocM Html synopsisValBindBind (name, BoundV tps t) = do-  let tps' = map typeParamHtml tps+  tps' <- mapM typeParamHtml tps   t' <- typeHtml $ second (const Nonunique) t-  pure $-    keyword "val "-      <> vnameHtml name-      <> mconcat (map (" " <>) tps')-      <> ": "-      <> t'+  name' <- vnameHtml name+  pure $ keyword "val " <> name' <> mconcat (map (" " <>) tps') <> ": " <> t'  dietHtml :: Diet -> Html dietHtml Consume = "*"@@ -521,11 +485,12 @@   Scalar (Arrow _ pname d t1 t2) -> do     t1' <- typeHtml $ second (const Nonunique) t1     t2' <- retTypeHtml t2-    pure $ case pname of-      Named v ->-        parens (vnameHtml v <> ": " <> dietHtml d <> t1') <> " -> " <> t2'+    case pname of+      Named v -> do+        v' <- vnameHtml v+        pure $ parens (v' <> ": " <> dietHtml d <> t1') <> " -> " <> t2'       Unnamed ->-        dietHtml d <> t1' <> " -> " <> t2'+        pure $ dietHtml d <> t1' <> " -> " <> t2'   Scalar (Sum cs) -> pipes <$> mapM ppClause (sortConstrs cs)     where       ppClause (n, ts) = joinBy " " . (ppConstr n :) <$> mapM typeHtml ts@@ -535,7 +500,8 @@ retTypeHtml (RetType [] t) = typeHtml t retTypeHtml (RetType dims t) = do   t' <- typeHtml t-  pure $ "?" <> mconcat (map (brackets . vnameHtml) dims) <> "." <> t'+  dims' <- mapM vnameHtml dims+  pure $ "?" <> mconcat (map brackets dims') <> "." <> t'  prettyShape :: Shape Size -> DocM Html prettyShape (Shape ds) =@@ -547,16 +513,11 @@  modParamHtml :: [ModParamBase Info VName] -> DocM Html modParamHtml [] = pure mempty-modParamHtml (ModParam pname psig _ _ : mps) =-  liftM2 f (synopsisModTypeExp psig) (modParamHtml mps)-  where-    f se params =-      "("-        <> vnameHtml pname-        <> ": "-        <> se-        <> ") -> "-        <> params+modParamHtml (ModParam pname psig _ _ : mps) = do+  pname' <- vnameHtml pname+  psig' <- synopsisModTypeExp psig+  mps' <- modParamHtml mps+  pure $ "(" <> pname' <> ": " <> psig' <> ") -> " <> mps'  synopsisModTypeExp :: ModTypeExpBase Info VName -> DocM Html synopsisModTypeExp e = case e of@@ -567,7 +528,7 @@     s' <- synopsisModTypeExp s     t' <- typeExpHtml t     v' <- qualNameHtml v-    let ps' = mconcat $ map ((" " <>) . typeParamHtml) ps+    ps' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) ps     pure $ s' <> keyword " with " <> v' <> ps' <> " = " <> t'   ModTypeArrow Nothing e1 e2 _ ->     liftM2 f (synopsisModTypeExp e1) (synopsisModTypeExp e2)@@ -575,7 +536,7 @@       f e1' e2' = e1' <> " -> " <> e2'   ModTypeArrow (Just v) e1 e2 _ ->     do-      let name = vnameHtml v+      name <- vnameHtml v       e1' <- synopsisModTypeExp e1       e2' <- noLink [v] $ synopsisModTypeExp e2       pure $ "(" <> name <> ": " <> e1' <> ") -> " <> e2'@@ -583,49 +544,59 @@ keyword :: String -> Html keyword = (H.span ! A.class_ "keyword") . fromString -vnameHtml :: VName -> Html-vnameHtml (VName name tag) =-  H.span ! A.id (fromString (show tag)) $ renderName name+vnameHtml :: VName -> DocM Html+vnameHtml vname = do+  (_, vname_id) <- vnameId vname+  pure $ H.span ! A.id (fromString vname_id) $ renderName $ baseName vname +-- | The canonical (in-file) anchor ID for a VName, along with the+-- file in which it is defined.+vnameId :: VName -> DocM (FilePath, String)+vnameId vname = do+  current <- asks ctxCurrent+  asks $ fromMaybe (current, show (baseTag vname)) . M.lookup vname . ctxFileMap+ vnameDescDef :: VName -> IndexWhat -> DocM Html vnameDescDef v what = do   document v what-  pure $ H.a ! A.id (fromString (show (baseTag v))) $ renderName (baseName v)--vnameSynopsisDef :: VName -> Html-vnameSynopsisDef (VName name tag) =-  H.span ! A.id (fromString (show tag ++ "s")) $-    H.a ! A.href (fromString ("#" ++ show tag)) $-      renderName name+  (_, v_id) <- vnameId v+  pure $ H.a ! A.id (fromString v_id) $ renderName (baseName v) -vnameSynopsisRef :: VName -> Html-vnameSynopsisRef v =-  H.a-    ! A.class_ "synopsis_link"-    ! A.href (fromString ("#" ++ show (baseTag v) ++ "s"))+vnameSynopsisRef :: VName -> DocM Html+vnameSynopsisRef v = do+  (_, v_id) <- vnameId v+  pure+    $ H.a+      ! A.class_ "synopsis_link"+      ! A.href (fromString ("#" <> "synopsis:" <> v_id))     $ "↑"  synopsisSpec :: SpecBase Info VName -> DocM Html synopsisSpec spec = case spec of-  TypeAbbrSpec tpsig ->-    fullRow <$> typeBindHtml (vnameSynopsisDef $ typeAlias tpsig) tpsig-  TypeSpec l name ps _ _ ->-    pure $ fullRow $ keyword l' <> vnameSynopsisDef name <> mconcat (map ((" " <>) . typeParamHtml) ps)+  TypeAbbrSpec tpsig -> do+    def <- vnameSynopsisDef $ typeAlias tpsig+    fullRow <$> typeBindHtml def tpsig+  TypeSpec l name ps _ _ -> do+    name' <- vnameSynopsisDef name+    ps' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) ps+    pure $ fullRow $ keyword l' <> name' <> ps'     where       l' = case l of         Unlifted -> "type "         SizeLifted -> "type~ "         Lifted -> "type^ "   ValSpec name tparams rettype _ _ _ -> do-    let tparams' = map typeParamHtml tparams+    tparams' <- mapM typeParamHtml tparams     rettype' <- noLink (map typeParamName tparams) $ typeExpHtml rettype+    name' <- vnameSynopsisDef name     pure $       specRow-        (keyword "val " <> vnameSynopsisDef name)+        (keyword "val " <> name')         (mconcat (map (" " <>) tparams') <> ": ")         rettype'-  ModSpec name sig _ _ ->-    specRow (keyword "module " <> vnameSynopsisDef name) ": " <$> synopsisModTypeExp sig+  ModSpec name sig _ _ -> do+    name' <- vnameSynopsisDef name+    specRow (keyword "module " <> name') ": " <$> synopsisModTypeExp sig   IncludeSpec e _ -> fullRow . (keyword "include " <>) <$> synopsisModTypeExp e  typeExpHtml :: TypeExp Exp VName -> DocM Html@@ -638,7 +609,7 @@   TETuple ts _ -> parens . commas <$> mapM typeExpHtml ts   TERecord fs _ -> braces . commas <$> mapM ppField fs     where-      ppField (name, t) = do+      ppField (L _ name, t) = do         t' <- typeExpHtml t         pure $ toHtml (nameToString name) <> ": " <> t'   TEVar name _ -> qualNameHtml name@@ -652,11 +623,12 @@       TEArrow {} -> parens <$> typeExpHtml t1       _ -> typeExpHtml t1     t2' <- typeExpHtml t2-    pure $ case pname of-      Just v ->-        parens (vnameHtml v <> ": " <> t1') <> " -> " <> t2'+    case pname of+      Just v -> do+        v' <- vnameHtml v+        pure $ parens (v' <> ": " <> t1') <> " -> " <> t2'       Nothing ->-        t1' <> " -> " <> t2'+        pure $ t1' <> " -> " <> t2'   TESum cs _ -> pipes <$> mapM ppClause cs     where       ppClause (n, ts) = joinBy " " . (ppConstr n :) <$> mapM typeExpHtml ts@@ -682,25 +654,28 @@         then pure Nothing         else Just <$> vnameLink vname +-- | The link for a VName. vnameLink :: VName -> DocM String vnameLink vname = do   current <- asks ctxCurrent-  file <- asks $ maybe current fst . M.lookup vname . ctxFileMap-  pure $ vnameLink' vname current file+  (file, tag) <- vnameId vname+  pure $ vnameLink' tag current file -vnameLink' :: VName -> String -> String -> String-vnameLink' (VName _ tag) current file =+vnameLink' :: String -> FilePath -> FilePath -> String+vnameLink' tag current file =   if file == current-    then "#" ++ show tag-    else relativise file current -<.> ".html#" ++ show tag+    then "#" ++ tag+    else relativise file current -<.> ".html#" ++ tag  paramHtml :: Pat ParamType -> DocM Html paramHtml pat = do   let (pat_param, d, t) = patternParam pat   t' <- typeHtml $ second (const Nonunique) t-  pure $ case pat_param of-    Named v -> parens (vnameHtml v <> ": " <> dietHtml d <> t')-    Unnamed -> t'+  case pat_param of+    Named v -> do+      v' <- vnameHtml v+      pure $ parens $ v' <> ": " <> dietHtml d <> t'+    Unnamed -> pure t'  relativise :: FilePath -> FilePath -> FilePath relativise dest src =@@ -717,17 +692,20 @@ typeArgExpHtml (TypeArgExpSize d) = dimExpHtml d typeArgExpHtml (TypeArgExpType d) = typeExpHtml d -typeParamHtml :: TypeParam -> Html-typeParamHtml (TypeParamDim name _) =-  brackets $ vnameHtml name-typeParamHtml (TypeParamType l name _) =-  "'" <> fromString (prettyString l) <> vnameHtml name+typeParamHtml :: TypeParam -> DocM Html+typeParamHtml (TypeParamDim name _) = do+  name' <- vnameHtml name+  pure $ brackets name'+typeParamHtml (TypeParamType l name _) = do+  name' <- vnameHtml name+  pure $ "'" <> fromString (prettyString l) <> name' -typeAbbrevHtml :: Liftedness -> Html -> [TypeParam] -> Html-typeAbbrevHtml l name params =-  what <> name <> mconcat (map ((" " <>) . typeParamHtml) params)+typeAbbrevHtml :: Liftedness -> Html -> [TypeParam] -> DocM Html+typeAbbrevHtml l name params = do+  params' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) params+  pure $ what <> name <> params'   where-    what = keyword $ "type" ++ prettyString l ++ " "+    what = keyword $ "type" <> prettyString l <> " "  docHtml :: Maybe DocComment -> DocM Html docHtml (Just (DocComment doc loc)) =@@ -793,10 +771,9 @@   name' <- H.span ! A.class_ "decl_name" <$> vnameDescDef name what   decl_type <- f name'   doc' <- docHtml doc+  ref <- vnameSynopsisRef name   let decl_doc = H.dd ! A.class_ "desc_doc" $ doc'-      decl_header =-        (H.dt ! A.class_ "desc_header") $-          vnameSynopsisRef name <> decl_type+      decl_header = (H.dt ! A.class_ "desc_header") (ref <> decl_type)   pure $ decl_header <> decl_doc  describeGenericMod ::@@ -815,10 +792,10 @@     ModTypeSpecs specs _ -> (<>) <$> docHtml doc <*> describeSpecs specs     _ -> docHtml doc +  ref <- vnameSynopsisRef name+   let decl_doc = H.dd ! A.class_ "desc_doc" $ doc'-      decl_header =-        (H.dt ! A.class_ "desc_header") $-          vnameSynopsisRef name <> decl_type+      decl_header = (H.dt ! A.class_ "desc_header") $ ref <> decl_type   pure $ decl_header <> decl_doc  describeDecs :: [Dec] -> DocM Html@@ -867,7 +844,7 @@ describeSpec :: Spec -> DocM Html describeSpec (ValSpec name tparams t _ doc _) =   describeGeneric name what doc $ \name' -> do-    let tparams' = mconcat $ map ((" " <>) . typeParamHtml) tparams+    tparams' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) tparams     t' <- noLink (map typeParamName tparams) $ typeExpHtml t     pure $ keyword "val " <> name' <> tparams' <> ": " <> t'   where@@ -878,8 +855,7 @@ describeSpec (TypeAbbrSpec vb) =   describeGeneric (typeAlias vb) IndexType (typeDoc vb) (`typeBindHtml` vb) describeSpec (TypeSpec l name tparams doc _) =-  describeGeneric name IndexType doc $-    pure . (\name' -> typeAbbrevHtml l name' tparams)+  describeGeneric name IndexType doc $ \name' -> typeAbbrevHtml l name' tparams describeSpec (ModSpec name se doc _) =   describeGenericMod name IndexModule se doc $ \name' ->     case se of@@ -897,3 +873,56 @@             <> sig'       decl_doc = H.dd ! A.class_ "desc_doc" $ doc'   pure $ decl_header <> decl_doc++-- | @renderFiles important_imports imports@ produces HTML files+-- documenting the type-checked program @imports@, with the files in+-- @important_imports@ considered most important. The HTML files must+-- be written to the specific locations indicated in the return value,+-- or the relative links will be wrong.+renderFiles :: [ImportName] -> Imports -> ([(FilePath, Html)], Warnings)+renderFiles important_imports imports = runWriter $ do+  (import_pages, documented) <- runWriterT $ forM imports $ \(current, fm) -> do+    let ctx =+          Context+            { ctxCurrent = makeRelative "/" $ includeToFilePath current,+              ctxFileMod = fm,+              ctxImports = imports,+              ctxNoLink = mempty,+              ctxFileMap = file_map,+              ctxVisibleMTys = progModuleTypes $ fileProg fm+            }+    flip runReaderT ctx $ do+      (first_paragraph, maybe_abstract, maybe_sections) <- headerDoc $ fileProg fm++      synopsis <- (H.div ! A.id "module") <$> synopsisDecs (progDecs $ fileProg fm)++      description <- describeDecs $ progDecs $ fileProg fm++      pure+        ( current,+          ( H.docTypeHtml ! A.lang "en"+              $ addBoilerplateWithNav+                important_imports+                imports+                ("doc" </> includeToFilePath current)+                (includeToString current)+              $ H.main+              $ maybe_abstract+                <> selfLink "synopsis" (H.h2 "Synopsis")+                <> (H.div ! A.id "overview") synopsis+                <> selfLink "description" (H.h2 "Description")+                <> description+                <> maybe_sections,+            first_paragraph+          )+        )++  pure $+    [ ("index.html", contentsPage important_imports $ map (fmap snd) import_pages),+      ("doc-index.html", indexPage important_imports imports documented file_map)+    ]+      ++ map (importHtml *** fst) import_pages+  where+    file_map = vnameToFileMap imports+    importHtml import_name =+      "doc" </> makeRelative "/" (fromString (includeToString import_name)) -<.> "html"

@@ -0,0 +1,481 @@+module Futhark.Fmt.Monad+  ( Fmt,+    -- functions for building fmt+    nil,+    nest,+    stdNest,+    text,+    space,+    hardline,+    line,+    sep,+    brackets,+    braces,+    parens,+    (<|>),+    (<+>),+    (</>),+    (<:/>),+    hardIndent,+    indent,+    hardStdIndent,+    stdIndent,+    FmtM,+    popComments,+    runFormat,+    align,+    fmtCopyLoc,+    comment,+    sepArgs,+    localLayout,+    localLayoutList,+    sepDecs,+    fmtByLayout,+    addComments,+    sepComments,+    sepLineComments,+    sepLine,++    -- * Formatting styles+    commentStyle,+    constantStyle,+    keywordStyle,+    bindingStyle,+    infixStyle,+  )+where++import Control.Monad (liftM2)+import Control.Monad.Reader+  ( MonadReader (..),+    ReaderT (..),+  )+import Control.Monad.State+  ( MonadState (..),+    State,+    evalState,+    gets,+    modify,+  )+import Data.ByteString qualified as BS+import Data.List.NonEmpty qualified as NE+import Data.Loc (Loc (..), Located (..), locStart, posCoff, posLine)+import Data.Maybe (fromMaybe)+import Data.String+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Language.Futhark.Parser.Monad (Comment (..))+import Prettyprinter qualified as P+import Prettyprinter.Render.Terminal+  ( AnsiStyle,+    Color (..),+    bold,+    color,+    colorDull,+    italicized,+  )++-- These are right associative since we want to evaluate the monadic+-- computation from left to right. Since the left most expression is+-- printed first and our monad is checking if a comment should be+-- printed.++infixr 6 <:/>++infixr 6 <+>++infixr 6 </>++infixr 4 <|>++type Fmt = FmtM (P.Doc AnsiStyle)++instance Semigroup Fmt where+  (<>) = liftM2 (<>)++instance Monoid Fmt where+  mempty = nil++instance IsString Fmt where+  fromString s = text style s'+    where+      s' = fromString s+      style =+        if s' `elem` keywords+          then keywordStyle+          else mempty+      keywords =+        [ "true",+          "false",+          "if",+          "then",+          "else",+          "def",+          "let",+          "loop",+          "in",+          "val",+          "for",+          "do",+          "with",+          "local",+          "open",+          "include",+          "import",+          "type",+          "entry",+          "module",+          "while",+          "assert",+          "match",+          "case"+        ]++commentStyle, keywordStyle, constantStyle, bindingStyle, infixStyle :: AnsiStyle+commentStyle = italicized+keywordStyle = color Magenta <> bold+constantStyle = color Green+bindingStyle = colorDull Blue+infixStyle = colorDull Cyan++-- | This function allows to inspect the layout of an expression @a@ and if it+-- is singleline line then use format @s@ and if it is multiline format @m@.+fmtByLayout ::+  (Located a) => a -> Fmt -> Fmt -> Fmt+fmtByLayout a s m =+  s+    <|> ( case lineLayout a of+            Just SingleLine -> s+            _any -> m+        )++-- | This function determines the Layout of @a@ and updates the monads+-- environment to format in the appropriate style. It determines this+-- by checking if the location of @a@ spans over two or more lines.+localLayout :: (Located a) => a -> FmtM b -> FmtM b+localLayout a = local (\lo -> fromMaybe lo $ lineLayout a)++-- | This function determines the Layout of @[a]@ and if it is singleline then it+-- updates the monads enviroment to format singleline style otherwise format using+-- multiline style. It determines this by checking if the locations of @[a]@+-- start and end at any different line number.+localLayoutList :: (Located a) => [a] -> FmtM b -> FmtM b+localLayoutList a m = do+  lo <- ask+  case lo of+    MultiLine -> local (const $ fromMaybe lo $ lineLayoutList a) m+    SingleLine -> m++-- | This function uses the location of @a@ and prepends comments if+-- the comments location is less than the location of @a@. It format+-- @b@ in accordance with if @a@ is singleline or multiline using+-- 'localLayout'. It currently does not handle trailing comment+-- perfectly. See tests/fmt/traillingComments*.fut.+addComments :: (Located a) => a -> Fmt -> Fmt+addComments a b = localLayout a $ do+  c <- fmtComments a+  f <- b+  pure $ c <> f++prependComments :: (a -> Loc) -> (a -> Fmt) -> a -> Fmt+prependComments floc fmt a = do+  fmcs <- fcs+  f <- fmt a+  pure $ fromMaybe mempty fmcs <> f+  where+    fcs = do+      s <- get+      case comments s of+        c : cs | floc a /= NoLoc && floc a > locOf c -> do+          put $ s {comments = cs}+          mcs <- fcs+          pre' <- pre+          pure $ Just $ pre' <> fmtNoLine c <> maybe mempty (P.line <>) mcs+        _any -> pure Nothing+    fmtNoLine = P.pretty . commentText+    pre = do+      lastO <- gets lastOutput+      case lastO of+        Nothing -> nil+        Just Line -> nil+        Just _ -> modify (\s -> s {lastOutput = Just Line}) >> hardline++-- | The internal state of the formatter monad 'FmtM'.+data FmtState = FmtState+  { -- | The comments that will be inserted, ordered by increasing order in regards to location.+    comments :: [Comment],+    -- | The original source file that is being formatted.+    file :: BS.ByteString,+    -- | Keeps track of what type the last output was.+    lastOutput :: !(Maybe LastOutput)+  }+  deriving (Show, Eq, Ord)++-- | A data type to describe the last output used during formatting.+data LastOutput = Line | Space | Text | Comm deriving (Show, Eq, Ord)++-- | A data type to describe the layout the formatter is using currently.+data Layout = MultiLine | SingleLine deriving (Show, Eq)++-- | The format monad used to keep track of comments and layout. It is a a+-- combincation of a reader and state monad. The comments and reading from the+-- input file are the state monads job to deal with. While the reader monad+-- deals with the propagating the current layout.+type FmtM a = ReaderT Layout (State FmtState) a++fmtComment :: Comment -> Fmt+fmtComment c = comment $ commentText c++fmtCommentList :: [Comment] -> Fmt+fmtCommentList [] = nil+fmtCommentList (c : cs) =+  fst $ foldl f (fmtComment c, locOf c) cs+  where+    f (acc, loc) c' =+      if consecutive loc (locOf c')+        then (acc <> fmtComment c', locOf c')+        else (acc <> hardline <> fmtComment c', locOf c')++hasComment :: (Located a) => a -> FmtM Bool+hasComment a =+  gets $ not . null . takeWhile relevant . comments+  where+    relevant c = locOf a /= NoLoc && locOf a > locOf c++-- | Prepends comments.+fmtComments :: (Located a) => a -> Fmt+fmtComments a = do+  (here, later) <- gets $ span relevant . comments+  if null here+    then pure mempty+    else do+      modify $ \s -> s {comments = later}+      fmtCommentList here+        <> if consecutive (locOf here) (locOf a) then nil else hardline+  where+    relevant c = locOf a /= NoLoc && locOf a > locOf c++-- | Determines the layout of @a@ by checking if it spans a single line or two+-- or more lines.+lineLayout :: (Located a) => a -> Maybe Layout+lineLayout a =+  case locOf a of+    Loc start end ->+      if posLine start == posLine end+        then Just SingleLine+        else Just MultiLine+    NoLoc -> Nothing -- error "Formatting term without location."++-- | Determines the layout of @[a]@ by checking if it spans a single line or two+-- or more lines.+lineLayoutList :: (Located a) => [a] -> Maybe Layout+lineLayoutList as =+  case concatMap auxiliary as of+    [] -> Nothing+    (t : ts) | any (/= t) ts -> Just MultiLine+    _ -> Just SingleLine+  where+    auxiliary a =+      case locOf a of+        Loc start end -> [posLine start, posLine end]+        NoLoc -> [] -- error "Formatting term without location"++-- | Retrieves the last comments from the monad and concatenates them together.+popComments :: Fmt+popComments = do+  cs <- gets comments+  modify (\s -> s {comments = []})+  lastO <- gets lastOutput+  case lastO of+    Nothing ->+      fmtCommentList cs -- Happens when file has only comments.+    _+      | not $ null cs -> hardline <> fmtCommentList cs+      | otherwise -> nil++-- | Using the location of @a@ get the segment of text in the original file to+-- create a @Fmt@.+fmtCopyLoc :: (Located a) => AnsiStyle -> a -> Fmt+fmtCopyLoc style a = do+  f <- gets file+  case locOf a of+    Loc sPos ePos ->+      let sOff = posCoff sPos+          eOff = posCoff ePos+       in case T.decodeUtf8' $ BS.take (eOff - sOff) $ BS.drop sOff f of+            Left err -> error $ show err+            Right lit -> text style lit+    NoLoc -> error "Formatting term without location"++-- | Given a formatter @FmtM a@, a sequence of comments ordered in increasing+-- order by location, and the original text files content. Run the formatter and+-- create @a@.+runFormat :: FmtM a -> [Comment] -> T.Text -> a+runFormat format cs file = evalState (runReaderT format e) s+  where+    s =+      FmtState+        { comments = cs,+          file = T.encodeUtf8 file,+          lastOutput = Nothing+        }+    e = MultiLine++-- | An empty input.+nil :: Fmt+nil = pure mempty++-- | Indents everything after a line occurs if in multiline and if in singleline+-- then indent.+nest :: Int -> Fmt -> Fmt+nest i a = a <|> (P.nest i <$> a)++-- | A space.+space :: Fmt+space = modify (\s -> s {lastOutput = Just Space}) >> pure P.space++-- | Forces a line to be used regardless of layout, this should+-- ideally not be used.+hardline :: Fmt+hardline = do+  modify $ \s -> s {lastOutput = Just Line}+  pure P.line++-- | A line or a space depending on layout.+line :: Fmt+line = space <|> hardline++-- | Seperates element by a @s@ followed by a space in singleline layout and+-- seperates by a line followed by a @s@ in multine layout.+sepLine :: Fmt -> [Fmt] -> Fmt+sepLine s = sep (s <> space <|> hardline <> s)++-- | A comment.+comment :: T.Text -> Fmt+comment c = do+  modify (\s -> s {lastOutput = Just Line})+  pure $ P.annotate commentStyle (P.pretty (T.stripEnd c)) <> P.line++sep :: Fmt -> [Fmt] -> Fmt+sep _ [] = nil+sep s (a : as) = auxiliary a as+  where+    auxiliary acc [] = acc+    auxiliary acc (x : xs) = auxiliary (acc <> s <> x) xs++sepComments :: (a -> Loc) -> (a -> Fmt) -> Fmt -> [a] -> Fmt+sepComments _ _ _ [] = nil+sepComments floc fmt s (a : as) = auxiliary (fmt a) as+  where+    auxiliary acc [] = acc+    auxiliary acc (x : xs) =+      auxiliary (acc <> prependComments floc (\y -> s <> fmt y) x) xs++sepLineComments :: (a -> Loc) -> (a -> Fmt) -> Fmt -> [a] -> Fmt+sepLineComments floc fmt s =+  sepComments floc fmt (s <> space <|> hardline <> s)++-- | This is used for function arguments. It seperates multiline+-- arguments by lines and singleline arguments by spaces. We specially+-- handle the case where all the arguments are on a single line except+-- for the last one, which may continue to the next line.+sepArgs :: (Located a) => (a -> Fmt) -> NE.NonEmpty a -> Fmt+sepArgs fmt ls =+  localLayout locs $ align' $ sep line $ map fmtArg ls'+  where+    locs = map (locStart . locOf) ls'+    align' = case lineLayout locs of+      Just SingleLine -> id+      _ -> align+    fmtArg x = localLayout x $ fmt x+    ls' = NE.toList ls++-- | Nest but with the standard value of two spaces.+stdNest :: Fmt -> Fmt+stdNest = nest 2++-- | Aligns line by line.+align :: Fmt -> Fmt+align a = do+  modify (\s -> s {lastOutput = Just Line}) -- XXX?+  P.align <$> a++-- | Indents everything by @i@, should never be used.+hardIndent :: Int -> Fmt -> Fmt+hardIndent i a = P.indent i <$> a++-- | Indents if in multiline by @i@ if in singleline it does not indent.+indent :: Int -> Fmt -> Fmt+indent i a = a <|> hardIndent i a++-- | Hard indents with the standard size of two.+hardStdIndent :: Fmt -> Fmt+hardStdIndent = hardIndent 2++-- | Idents with the standard size of two.+stdIndent :: Fmt -> Fmt+stdIndent = indent 2++-- | Creates a piece of text, it should not contain any new lines.+text :: AnsiStyle -> T.Text -> Fmt+text style t = do+  modify (\s -> s {lastOutput = Just Text})+  pure $ P.annotate style $ P.pretty t++-- | Adds brackets.+brackets :: Fmt -> Fmt+brackets a = "[" <> a <> "]"++-- | Adds braces.+braces :: Fmt -> Fmt+braces a = "{" <> a <> "}"++-- | Add parenthesis.+parens :: Fmt -> Fmt+parens a = "(" <> a <> ")"++-- | If in a singleline layout then concatenate with 'nil' and in multiline+-- concatenate by a line.+(<:/>) :: Fmt -> Fmt -> Fmt+a <:/> b = a <> (nil <|> hardline) <> b++-- | Concatenate with a space between.+(<+>) :: Fmt -> Fmt -> Fmt+a <+> b = a <> space <> b++-- | Concatenate with a space if in singleline layout and concatenate by a+-- line in multiline.+(</>) :: Fmt -> Fmt -> Fmt+a </> b = a <> line <> b++-- | If in a singleline layout then choose @a@, if in a multiline layout choose+-- @b@.+(<|>) :: Fmt -> Fmt -> Fmt+a <|> b = do+  lo <- ask+  if lo == SingleLine+    then a+    else b++-- | Are these locations on consecutive lines?+consecutive :: Loc -> Loc -> Bool+consecutive (Loc _ end) (Loc beg _) = posLine end + 1 == posLine beg+consecutive _ _ = False++-- | If in singleline layout seperate by spaces. In a multiline layout seperate+-- by a single line if two neighbouring elements are singleline. Otherwise+-- sepereate by two lines.+sepDecs :: (Located a) => (a -> Fmt) -> [a] -> Fmt+sepDecs _ [] = nil+sepDecs fmt decs@(x : xs) =+  sep space (map fmt decs) <|> (fmt x <> auxiliary x xs)+  where+    auxiliary _ [] = nil+    auxiliary prev (y : ys) = p <> fmt y <> auxiliary y ys+      where+        p = do+          commented <- hasComment y+          case (commented, lineLayout y, lineLayout prev) of+            (False, Just SingleLine, Just SingleLine)+              | consecutive (locOf prev) (locOf y) -> hardline+            _any -> hardline <> hardline

@@ -0,0 +1,619 @@+module Futhark.Fmt.Printer+  ( fmtToText,+    fmtToDoc,+  )+where++import Data.Bifunctor (second)+import Data.Foldable+import Data.Loc (locStart)+import Data.Text qualified as T+import Futhark.Fmt.Monad+import Futhark.Util (showText)+import Futhark.Util.Pretty+  ( AnsiStyle,+    Doc,+    Pretty,+    docText,+  )+import Language.Futhark+import Language.Futhark.Parser+  ( SyntaxError (..),+    parseFutharkWithComments,+  )++lineIndent :: (Located a) => a -> Fmt -> Fmt -> Fmt+lineIndent l a b = fmtByLayout l (a <+> b) (a </> hardStdIndent (align b))++fmtName :: AnsiStyle -> Name -> Fmt+fmtName style = text style . nameToText++fmtBoundName :: Name -> Fmt+fmtBoundName name+  | operatorName name = parens $ fmtName bindingStyle name+  | otherwise = fmtName bindingStyle name++fmtPretty :: (Pretty a) => a -> Fmt+fmtPretty = text mempty . prettyText++class Format a where+  fmt :: a -> Fmt++instance Format DocComment where+  fmt (DocComment x loc) =+    addComments loc $ sep nil $ prefixes (T.lines x)+    where+      prefixes [] = []+      prefixes (l : ls) = comment (prefix "-- |" l) : map (comment . prefix "--") ls+      prefix p s = if T.null s then p else p <> " " <> s -- Avoid trailing whitespace.++instance Format (Maybe DocComment) where+  fmt = maybe nil fmt++fmtParamType :: Maybe Name -> UncheckedTypeExp -> Fmt+fmtParamType (Just n) te =+  parens $ fmtName mempty n <> ":" <+> fmt te+fmtParamType Nothing te = fmt te++fmtSumTypeConstr :: (Name, [UncheckedTypeExp]) -> Fmt+fmtSumTypeConstr (name, []) =+  "#" <> fmtName mempty name+fmtSumTypeConstr (name, fs) =+  "#" <> fmtName mempty name <+> sep space (map fmt fs)++instance Format Name where+  fmt = fmtName mempty++-- Format a tuple-like thing (expression, pattern, type).+fmtTuple :: (Located a) => [Fmt] -> a -> Fmt+fmtTuple xs loc =+  addComments loc $ fmtByLayout loc singleLine multiLine+  where+    singleLine = parens $ sep ", " xs+    multiLine = align $ "(" <+> sep (line <> "," <> space) xs </> ")"++-- Format a record-like thing (expression, pattern, type).+fmtRecord :: (Located a) => [Fmt] -> a -> Fmt+fmtRecord xs loc =+  addComments loc $ fmtByLayout loc singleLine multiLine+  where+    singleLine = braces $ sep ", " xs+    multiLine = align $ "{" <+> sep (line <> "," <> space) xs </> "}"++-- Format an array-like thing.+fmtArray :: (Located a) => [Fmt] -> a -> Fmt+fmtArray xs loc =+  addComments loc $ fmtByLayout loc singleLine multiLine+  where+    singleLine = brackets $ sep ", " xs+    multiLine =+      align $ "[" <+> sep (line <> "," <> space) xs </> "]"++instance Format UncheckedTypeExp where+  fmt (TEVar v loc) = addComments loc $ fmtQualName v+  fmt (TETuple ts loc) = fmtTuple (map (align . fmt) ts) loc+  fmt (TEParens te loc) = addComments loc $ parens $ fmt te+  fmt (TERecord fs loc) = fmtRecord (map fmtFieldType fs) loc+    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 (TEApply te tArgE loc) = addComments loc $ fmt te <+> fmt tArgE+  fmt (TEArrow name te0 te1 loc) =+    addComments loc $+      fmtParamType name te0 </> "->" <+> case te1 of+        TEArrow {} -> fmt te1+        _ -> align (fmt te1)+  fmt (TESum tes loc) =+    -- Comments can not be inserted correctly here because names do not+    -- have a location.+    addComments loc $ fmtByLayout loc singleLine multiLine+    where+      singleLine = sep " | " $ map fmtSumTypeConstr tes+      multiLine = sep line $ zipWith prefix [0 :: Int ..] tes+      prefix 0 te = "  " <> fmtSumTypeConstr te+      prefix _ te = "| " <> fmtSumTypeConstr te+  fmt (TEDim dims te loc) =+    addComments loc $ "?" <> dims' <> "." <> fmt te+    where+      dims' = sep nil $ map (brackets . fmt) dims++instance Format (TypeArgExp UncheckedExp Name) where+  fmt (TypeArgExpSize se) = fmt se+  fmt (TypeArgExpType te) = fmt te++instance Format UncheckedTypeBind where+  fmt (TypeBind name l ps e NoInfo dc loc) =+    addComments loc $+      fmt dc+        <> "type"+        <> fmt l+          <+> fmtName bindingStyle name+        <> (if null ps then nil else space)+        <> localLayoutList ps (align $ sep line $ map fmt ps)+          <+> "="+          </> stdIndent (fmt e)++instance Format (AttrAtom a) where+  fmt (AtomName name) = fmt name+  fmt (AtomInt int) = text constantStyle $ prettyText int++instance Format (AttrInfo a) where+  fmt attr = "#" <> brackets (fmtAttrInfo attr)+    where+      fmtAttrInfo (AttrAtom attr' loc) = addComments loc $ fmt attr'+      fmtAttrInfo (AttrComp name attrs loc) =+        addComments loc $+          fmt name+            <> parens (sep "," $ map fmtAttrInfo attrs)++instance Format Liftedness where+  fmt Unlifted = nil+  fmt SizeLifted = "~"+  fmt Lifted = "^"++instance Format UncheckedTypeParam where+  fmt (TypeParamDim name loc) =+    addComments loc $ brackets $ fmtName bindingStyle name+  fmt (TypeParamType l name loc) =+    addComments loc $ "'" <> fmt l <> fmtName bindingStyle name++instance Format (UncheckedPat t) where+  fmt (TuplePat pats loc) =+    fmtTuple (map fmt pats) loc+  fmt (RecordPat pats loc) =+    fmtRecord (map fmtFieldPat pats) loc+    where+      -- We detect the implicit form by whether the name and the 't'+      -- has the same location.+      fmtFieldPat (L nameloc name, t)+        | locOf nameloc == locOf t = fmt name+        | otherwise =+            lineIndent [nameloc, locOf t] (fmt name <+> "=") (fmt t)+  fmt (PatParens pat loc) =+    addComments loc $ "(" <> align (fmt pat) <:/> ")"+  fmt (Id name _ loc) = addComments loc $ fmtBoundName name+  fmt (Wildcard _t loc) = addComments loc "_"+  fmt (PatAscription pat t loc) = addComments loc $ fmt pat <> ":" <+> fmt t+  fmt (PatLit _e _ loc) = addComments loc $ fmtCopyLoc constantStyle loc+  fmt (PatConstr n _ [] loc) =+    addComments loc $ "#" <> fmt n+  fmt (PatConstr n _ pats loc) =+    addComments loc $ "#" <> fmt n </> align (sep line (map fmt pats))+  fmt (PatAttr attr pat loc) = addComments loc $ fmt attr <+> fmt pat++instance Format (FieldBase NoInfo Name) where+  fmt (RecordFieldExplicit (L nameloc name) e loc) =+    addComments loc $+      lineIndent [nameloc, locOf e] (fmt name <+> "=") (stdIndent (fmt e))+  fmt (RecordFieldImplicit (L _ name) _ loc) = addComments loc $ fmt name++instance Format UncheckedDimIndex where+  fmt (DimFix e) = fmt e+  fmt (DimSlice i j (Just s)) =+    maybe nil fmt i+      <> ":"+      <> maybe nil fmt j+      <> ":"+      <> fmt s+  fmt (DimSlice i (Just j) s) =+    maybe nil fmt i+      <> ":"+      <> fmt j+      <> maybe nil ((":" <>) . fmt) s+  fmt (DimSlice i Nothing Nothing) =+    maybe nil fmt i <> ":"++operatorName :: Name -> Bool+operatorName = (`elem` opchars) . T.head . nameToText+  where+    opchars :: String+    opchars = "+-*/%=!><|&^."++instance Format PrimValue where+  fmt pv =+    text constantStyle $ case pv of+      UnsignedValue (Int8Value v) ->+        showText (fromIntegral v :: Word8) <> "u8"+      UnsignedValue (Int16Value v) ->+        showText (fromIntegral v :: Word16) <> "u16"+      UnsignedValue (Int32Value v) ->+        showText (fromIntegral v :: Word32) <> "u32"+      UnsignedValue (Int64Value v) ->+        showText (fromIntegral v :: Word64) <> "u64"+      SignedValue v -> prettyText v+      BoolValue True -> "true"+      BoolValue False -> "false"+      FloatValue v -> prettyText v++instance Format UncheckedExp where+  fmt (Var name _ loc) = addComments loc $ fmtQualName name+  fmt (Hole _ loc) = addComments loc "???"+  fmt (Parens e loc) =+    addComments loc $ "(" <> align (fmt e) <> ")"+  fmt (QualParens (v, _qLoc) e loc) =+    addComments loc $+      fmtQualName v <> "." <> "(" <> align (fmt e) <> ")"+  fmt (Ascript e t loc) = addComments loc $ fmt e </> ":" <+> align (fmt t)+  fmt (Coerce e t _ loc) = addComments loc $ fmt e </> ":>" <+> align (fmt t)+  fmt (Literal _v loc) = addComments loc $ fmtCopyLoc constantStyle loc+  fmt (IntLit _v _ loc) = addComments loc $ fmtCopyLoc constantStyle loc+  fmt (FloatLit _v _ loc) = addComments loc $ fmtCopyLoc constantStyle loc+  fmt (TupLit es loc) = fmtTuple (map (align . fmt) es) loc+  fmt (RecordLit fs loc) = fmtRecord (map fmt fs) loc+  fmt (ArrayLit es _ loc) = fmtArray (map (align . fmt) es) loc+  fmt (StringLit _s loc) = addComments loc $ fmtCopyLoc constantStyle loc+  fmt (Project k e _ loc) = addComments loc $ fmt e <> "." <> fmt k+  fmt (Negate e loc) = addComments loc $ "-" <> fmt e+  fmt (Not e loc) = addComments loc $ "!" <> fmt e+  fmt (Update src idxs ve loc) =+    addComments loc $+      fmt src <+> "with" <+> idxs' <+> stdNest ("=" </> fmt ve)+    where+      idxs' = brackets $ sep ("," <> space) $ map fmt idxs+  fmt (RecordUpdate src fs ve _ loc) =+    addComments loc $+      fmt src <+> "with" <+> fs' <+> stdNest ("=" </> fmt ve)+    where+      fs' = sep "." $ fmt <$> fs+  fmt (Assert e1 e2 _ loc) =+    addComments loc $ "assert" <+> fmt e1 <+> fmt e2+  fmt (Lambda params body rettype _ loc) =+    addComments loc $+      "\\"+        <> sep space (map fmt params)+        <> maybe nil (((space <> ":") <+>) . fmt) rettype+          <+> stdNest ("->" </> fmt body)+  fmt (OpSection binop _ loc) =+    addComments loc $+      if operatorName (qualLeaf binop)+        then fmtQualName binop+        else parens $ "`" <> fmtQualName binop <> "`"+  fmt (OpSectionLeft binop _ x _ _ loc) =+    addComments loc $ parens $ fmt x <+> fmtBinOp binop+  fmt (OpSectionRight binop _ x _ _ loc) =+    addComments loc $ parens $ fmtBinOp binop <+> fmt x+  fmt (ProjectSection fields _ loc) =+    addComments loc $ parens $ "." <> sep "." (fmt <$> fields)+  fmt (IndexSection idxs _ loc) =+    addComments loc $ parens ("." <> idxs')+    where+      idxs' = brackets $ sep ("," <> space) $ map fmt idxs+  fmt (Constr n [] _ loc) =+    addComments loc $ "#" <> fmt n+  fmt (Constr n cs _ loc) =+    addComments loc $ "#" <> fmt n <+> align (sep line $ map fmt cs)+  fmt (Attr attr e loc) = addComments loc $ align $ fmt attr </> fmt e+  fmt (AppExp e _) = fmt e+  fmt (ArrayVal vs _ loc) = addComments loc $ fmtArray (map fmt vs) loc++fmtQualName :: QualName Name -> Fmt+fmtQualName (QualName names name)+  | operatorName name = parens $ pre <> fmt name+  | otherwise = pre <> fmt name+  where+    pre =+      if null names+        then nil+        else sep "." (map fmt names) <> "."++instance Format UncheckedCase where+  fmt (CasePat p e loc) =+    addComments loc $ "case" <+> fmt p <+> "->" </> stdIndent (fmt e)++instance Format (AppExpBase NoInfo Name) where+  fmt (BinOp (bop, _) _ (x, _) (y, _) loc) =+    addComments loc $ fmt x </> fmtBinOp bop <+> fmt y+  fmt (Match e cs loc) =+    addComments loc $ "match" <+> fmt e </> sep line (map fmt $ toList cs)+  -- need some way to omit the inital value expression, when this it's trivial+  fmt (Loop sizeparams pat (LoopInitImplicit NoInfo) form loopbody loc) =+    addComments loc $+      ("loop" `op` sizeparams')+        <+> localLayout+          [locOf pat, formloc]+          (fmt pat </> fmt form <+> "do")+        </> stdIndent (fmt loopbody)+    where+      formloc = case form of+        For i _ -> locOf i+        ForIn fpat _ -> locOf fpat+        While e -> locOf e+      op = if null sizeparams then (<>) else (<+>)+      sizeparams' = sep nil $ brackets . fmtName bindingStyle . toName <$> sizeparams+  fmt (Loop sizeparams pat (LoopInitExplicit initexp) form loopbody loc) =+    addComments loc $+      ("loop" `op` sizeparams')+        <+> align+          ( lineIndent+              [locOf pat, locOf initexp]+              (fmt pat <+> "=")+              (align $ fmt initexp)+          )+        </> fmt form+        <+> "do"+        </> stdIndent (fmt loopbody)+    where+      op = if null sizeparams then (<>) else (<+>)+      sizeparams' = sep nil $ brackets . fmtName bindingStyle . toName <$> sizeparams+  fmt (Index e idxs loc) =+    addComments loc $ (fmt e <>) $ brackets $ sepLine "," $ map fmt idxs+  fmt (LetPat sizes pat e body loc) =+    addComments loc $+      lineIndent [locOf pat, locOf e] ("let" <+> sub <+> "=") (fmt e)+        </> letBody body+    where+      sizes' = sep nil $ map fmt sizes+      sub+        | null sizes = fmt pat+        | otherwise = sizes' <+> fmt pat+  fmt (LetFun fname (tparams, params, retdecl, _, e) body loc) =+    addComments loc $+      lineIndent+        e+        ( "let"+            <+> fmtName bindingStyle fname+            <> sub+            <> retdecl'+            <> "="+        )+        (fmt e)+        </> letBody body+    where+      tparams' = sep space $ map fmt tparams+      params' = sep space $ map fmt params+      retdecl' =+        case retdecl of+          Just a -> ":" <+> fmt a <> space+          Nothing -> space+      sub+        | null tparams && null params = nil+        | null tparams = space <> params'+        | null params = space <> tparams'+        | otherwise = space <> tparams' <+> params'+  fmt (LetWith dest src idxs ve body loc)+    | dest == src =+        addComments loc $+          lineIndent+            ve+            ( "let"+                <+> fmt dest+                <> idxs'+                  <+> "="+            )+            (fmt ve)+            </> letBody body+    | otherwise =+        addComments loc $+          lineIndent+            ve+            ( "let"+                <+> fmt dest+                <+> "="+                <+> fmt src+                <+> "with"+                <+> idxs'+            )+            (fmt ve)+            </> letBody body+    where+      idxs' = brackets $ sep ", " $ map fmt idxs+  fmt (Range start maybe_step end loc) =+    addComments loc $ fmt start <> step <> end'+    where+      end' =+        case end of+          DownToExclusive e -> "..>" <> fmt e+          ToInclusive e -> "..." <> fmt e+          UpToExclusive e -> "..<" <> fmt e+      step = maybe nil ((".." <>) . fmt) maybe_step+  fmt (If c t f loc) =+    addComments loc $+      "if"+        <+> fmt c+        </> "then"+        <+> align (fmt t)+        </> "else"+        <> case f of+          AppExp If {} _ -> space <> fmt f+          _ -> space <> align (fmt f)+  fmt (Apply f args loc) =+    addComments loc $ fmt f <+> fmt_args+    where+      fmt_args = sepArgs fmt $ fmap snd args++letBody :: UncheckedExp -> Fmt+letBody body@(AppExp LetPat {} _) = fmt body+letBody body@(AppExp LetFun {} _) = fmt body+letBody body@(AppExp LetWith {} _) = fmt body+letBody body = addComments body $ "in" <+> align (fmt body)++instance Format (SizeBinder Name) where+  fmt (SizeBinder v loc) =+    addComments loc $ brackets $ fmtName bindingStyle v++instance Format (IdentBase NoInfo Name t) where+  fmt = fmtName bindingStyle . identName++instance Format (LoopFormBase NoInfo Name) where+  fmt (For i ubound) = "for" <+> fmt i <+> "<" <+> fmt ubound+  fmt (ForIn x e) = "for" <+> fmt x <+> "in" <+> fmt e+  fmt (While cond) = "while" <+> fmt cond++-- | This should always be simplified by location.+fmtBinOp :: QualName Name -> Fmt+fmtBinOp bop =+  case leading of+    Backtick -> "`" <> fmtQualName bop <> "`"+    _ -> text infixStyle (prettyText bop)+  where+    leading = leadingOperator $ toName $ qualLeaf bop++instance Format UncheckedValBind where+  fmt (ValBind entry name retdecl _rettype tparams args body docs attrs loc) =+    addComments loc $+      fmt docs+        <> attrs'+        <> (fun <+> fmtBoundName name)+        <> sub+        <> retdecl'+        <> "="+          </> stdIndent (fmt body)+    where+      attrs' = if null attrs then nil else sep space (map fmt attrs) <> hardline+      tparams' = localLayoutList tparams $ align $ sep line $ map fmt tparams+      args' = localLayoutList args $ align $ sep line $ map fmt args+      retdecl' =+        case retdecl of+          Just a -> space <> ":" <+> fmt a <> space+          Nothing -> space+      sub+        | null tparams && null args = nil+        | null tparams = space <> args'+        | null args = space <> tparams'+        | otherwise =+            localLayout [locOf tparams, locOf args] $+              space <> align (tparams' </> args')+      fun =+        case entry of+          Just _ -> "entry"+          _any -> "def"++instance Format (SizeExp UncheckedExp) where+  fmt (SizeExp d loc) = addComments loc $ brackets $ fmt d+  fmt (SizeExpAny loc) = addComments loc $ brackets nil++instance Format UncheckedSpec where+  fmt (TypeAbbrSpec tpsig) = fmt tpsig+  fmt (TypeSpec l name ps doc loc) =+    addComments loc $ fmt doc <> "type" <> fmt l <+> sub+    where+      sub+        | null ps = fmtName bindingStyle name+        | otherwise = fmtName bindingStyle name </> align (sep line $ map fmt ps)+  fmt (ValSpec name ps te _ doc loc) =+    addComments loc $ fmt doc <> "val" <+> sub <+> ":" </> stdIndent (fmt te)+    where+      sub+        | null ps = fmtName bindingStyle name+        | otherwise = fmtName bindingStyle name <+> align (sep line $ map fmt ps)+  fmt (ModSpec name mte doc loc) =+    addComments loc $ fmt doc <> "module" <+> fmtName bindingStyle name <> ":" <+> fmt mte+  fmt (IncludeSpec mte loc) = addComments loc $ "include" <+> fmt mte++typeWiths ::+  UncheckedModTypeExp ->+  (UncheckedModTypeExp, [TypeRefBase NoInfo Name])+typeWiths (ModTypeWith mte tr _) = second (tr :) $ typeWiths mte+typeWiths mte = (mte, [])++instance Format UncheckedModTypeExp where+  fmt (ModTypeVar v _ loc) = addComments loc $ fmtPretty v+  fmt (ModTypeParens mte loc) =+    addComments loc $ "(" <> align (fmt mte) <> ")"+  fmt (ModTypeSpecs sbs loc) =+    addComments loc $ "{" <:/> stdIndent (sepDecs fmt sbs) <:/> "}"+  fmt (ModTypeWith mte tr loc) =+    -- Special case multiple chained ModTypeWiths.+    let (root, withs) = typeWiths mte+     in addComments loc . localLayout loc $+          fmt root+            </> sep line (map fmtWith (withs ++ [tr]))+    where+      fmtWith (TypeRef v ps td _) =+        "with"+          <+> fmtPretty v+          `ps_op` sep space (map fmt ps)+          <+> "="+          <+> fmt td+        where+          ps_op = if null ps then (<>) else (<+>)+  fmt (ModTypeArrow (Just v) te0 te1 loc) =+    addComments loc $+      parens (fmtName bindingStyle v <> ":" <+> fmt te0) <+> align ("->" </> fmt te1)+  fmt (ModTypeArrow Nothing te0 te1 loc) =+    addComments loc $ fmt te0 <+> "->" <+> fmt te1++instance Format UncheckedModTypeBind where+  fmt (ModTypeBind pName pSig doc loc) =+    addComments loc $+      fmt doc+        <> "module"+          <+> "type"+          <+> fmtName bindingStyle pName+          <+> "="+        <> case pSig of+          ModTypeSpecs {} -> space <> fmt pSig+          _ -> line <> stdIndent (fmt pSig)++instance Format (ModParamBase NoInfo Name) where+  fmt (ModParam pName pSig _f loc) =+    addComments loc $ parens $ fmtName bindingStyle pName <> ":" <+> fmt pSig++instance Format UncheckedModBind where+  fmt (ModBind name ps sig me doc loc) =+    addComments loc $+      fmt doc+        <> "module"+          <+> localLayout+            [locStart (locOf loc), locOf ps]+            (fmtName bindingStyle name <> ps')+        <> fmtSig sig+        <> "="+        <> me'+    where+      me' = fmtByLayout me (line <> stdIndent (fmt me)) (space <> fmt me)+      fmtSig Nothing = space+      fmtSig (Just (s', _f)) =+        localLayout (map locOf ps ++ [locOf s']) $+          line <> stdIndent (":" <+> align (fmt s') <> space)+      ps' =+        case ps of+          [] -> nil+          _any -> line <> stdIndent (localLayoutList ps (align $ sep line $ map fmt ps))++-- All of these should probably be "extra" indented+instance Format UncheckedModExp where+  fmt (ModVar v loc) = addComments loc $ fmtQualName v+  fmt (ModParens f loc) =+    addComments loc $ "(" <:/> stdIndent (fmt f) <> ")"+  fmt (ModImport path _f loc) =+    addComments loc $ "import" <+> "\"" <> fmtPretty path <> "\""+  fmt (ModDecs decs loc) =+    addComments loc $+      "{" <:/> stdIndent (sepDecs fmt decs) <:/> "}"+  fmt (ModApply f a _f0 _f1 loc) = addComments loc $ fmt f <+> fmt a+  fmt (ModAscript me se _f loc) = addComments loc $ align (fmt me <> ":" </> fmt se)+  fmt (ModLambda param maybe_sig body loc) =+    addComments loc $+      "\\" <> fmt param <> sig <+> "->" </> stdIndent (fmt body)+    where+      sig =+        case maybe_sig of+          Nothing -> nil+          Just (sig', _) -> ":" <+> parens (fmt sig')++instance Format UncheckedDec where+  fmt (ValDec t) = fmt t+  fmt (TypeDec tb) = fmt tb+  fmt (ModTypeDec tb) = fmt tb+  fmt (ModDec tb) = fmt tb+  fmt (OpenDec tb loc) = addComments loc $ "open" <+> fmt tb+  fmt (LocalDec tb loc) = addComments loc $ "local" <+> fmt tb+  fmt (ImportDec path _tb loc) =+    addComments loc $ "import" <+> "\"" <> fmtPretty path <> "\""++instance Format UncheckedProg where+  fmt (Prog Nothing decs) = sepDecs fmt decs </> popComments+  fmt (Prog (Just dc) decs) = fmt dc </> sepDecs fmt decs </> popComments++-- | Given a filename and a futhark program, formats the program.+fmtToDoc :: String -> T.Text -> Either SyntaxError (Doc AnsiStyle)+fmtToDoc fname fcontent = do+  (prog, cs) <- parseFutharkWithComments fname fcontent+  pure $ runFormat (fmt prog) cs fcontent++-- | Given a filename and a futhark program, formats the program as+-- text.+fmtToText :: String -> T.Text -> Either SyntaxError T.Text+fmtToText fname fcontent = docText <$> fmtToDoc fname fcontent

@@ -30,7 +30,8 @@  import Data.Bifunctor (first, second) import Data.List (find, transpose)-import Data.Map qualified as M+import Data.Map.Strict qualified as M+import Data.Maybe (mapMaybe) import Futhark.IR.Prop (ASTRep, IsOp, NameInfo (..), Scope) import Futhark.IR.Prop.Names import Futhark.IR.Prop.Pat@@ -90,9 +91,18 @@   [Names] funcallAliases pes args = map onType   where-    getAls als is = mconcat $ map fst $ filter ((`elem` is) . snd) $ zip als [0 ..]-    arg_als = map (subExpAliases . fst) args-    res_als = map (oneName . patElemName) pes+    -- We assumes that the pals/rals lists are sorted, as this allows+    -- us to compute the intersections much more efficiently.+    argAls (i, (Var v, Observe)) = Just (i, v)+    argAls _ = Nothing+    arg_als = mapMaybe argAls $ zip [0 ..] args+    res_als = zip [0 ..] $ map patElemName pes+    pick (i : is) ((j, v) : jvs)+      | i == j = v : pick is jvs+      | i > j = pick (i : is) jvs+      | otherwise = pick is ((j, v) : jvs)+    pick _ _ = []+    getAls als is = namesFromList $ pick is als     onType (_t, RetAls pals rals) = getAls arg_als pals <> getAls res_als rals  mutualAliases :: Names -> [PatElem dec] -> [Names] -> [Names]

@@ -417,9 +417,11 @@ -- | Information about the possible aliases of a function result. data RetAls = RetAls   { -- | Which of the parameters may be aliased, numbered from zero.+    -- Must be sorted in increasing order.     paramAls :: [Int],     -- | Which of the other results may be aliased, numbered from-    -- zero.  This must be a reflexive relation.+    -- zero. This must be a reflexive relation. Must be sorted in+    -- increasing order.     otherAls :: [Int]   }   deriving (Eq, Ord, Show)

@@ -76,12 +76,12 @@   prog_decs0 <- ApplyTypeAbbrs.transformProg =<< Defunctorise.transformProg prog   maybeLog "Full Normalising"   prog_decs1 <- FullNormalise.transformProg prog_decs0+  maybeLog "Replacing records"+  prog_decs2 <- ReplaceRecords.transformProg prog_decs1   maybeLog "Lifting lambdas"-  prog_decs2 <- LiftLambdas.transformProg prog_decs1+  prog_decs3 <- LiftLambdas.transformProg prog_decs2   maybeLog "Monomorphising"-  prog_decs3 <- Monomorphise.transformProg prog_decs2-  maybeLog "Replacing records"-  prog_decs4 <- ReplaceRecords.transformProg prog_decs3+  prog_decs4 <- Monomorphise.transformProg prog_decs3   maybeLog "Defunctionalising"   prog_decs5 <- Defunctionalise.transformProg prog_decs4   maybeLog "Converting to core IR"

@@ -180,7 +180,7 @@     flattenPat' (E.TuplePat pats _) =       concat <$> mapM flattenPat' pats     flattenPat' (E.RecordPat fs loc) =-      flattenPat' $ E.TuplePat (map snd $ sortFields $ M.fromList fs) loc+      flattenPat' $ E.TuplePat (map snd $ sortFields $ M.fromList $ map (first unLoc) fs) loc     flattenPat' (E.PatAscription p _ _) =       flattenPat' p     flattenPat' (E.PatLit _ t loc) =

@@ -450,14 +450,14 @@   where     closureFromDynamicFun (vn, Binding _ (DynamicFun (clsr_env, sv) _)) =       let name = nameFromString $ prettyString vn-       in ( RecordFieldExplicit name clsr_env mempty,+       in ( RecordFieldExplicit (L noLoc name) clsr_env mempty,             (vn, Binding Nothing sv)           )     closureFromDynamicFun (vn, Binding _ sv) =       let name = nameFromString $ prettyString vn           tp' = structTypeFromSV sv        in ( RecordFieldExplicit-              name+              (L noLoc name)               (Var (qualName vn) (Info tp') mempty)               mempty,             (vn, Binding Nothing sv)@@ -489,8 +489,8 @@   where     defuncField (RecordFieldExplicit vn e loc') = do       (e', sv) <- defuncExp e-      pure (RecordFieldExplicit vn e' loc', (vn, sv))-    defuncField (RecordFieldImplicit vn (Info t) loc') = do+      pure (RecordFieldExplicit vn e' loc', (unLoc vn, sv))+    defuncField (RecordFieldImplicit (L _ vn) (Info t) loc') = do       sv <- lookupVar (toStruct t) vn       case sv of         -- If the implicit field refers to a dynamic function, we@@ -499,14 +499,17 @@         DynamicFun (e, sv') _ ->           let vn' = baseName vn            in pure-                ( RecordFieldExplicit vn' e loc',+                ( RecordFieldExplicit (L noLoc vn') e loc',                   (vn', sv')                 )         -- The field may refer to a functional expression, so we get the         -- type from the static value and not the one from the AST.         _ ->           let tp = Info $ structTypeFromSV sv-           in pure (RecordFieldImplicit vn tp loc', (baseName vn, sv))+           in pure+                ( RecordFieldImplicit (L noLoc vn) tp loc',+                  (baseName vn, sv)+                ) defuncExp e@(ArrayVal vs t loc) =   pure (ArrayVal vs t loc, Dynamic $ toParam Observe $ typeOf e) defuncExp (ArrayLit es t@(Info t') loc) = do@@ -585,8 +588,8 @@ defuncExp OpSectionRight {} = error "defuncExp: unexpected operator section." defuncExp ProjectSection {} = error "defuncExp: unexpected projection section." defuncExp IndexSection {} = error "defuncExp: unexpected projection section."-defuncExp (AppExp (Loop sparams pat e1 form e3 loc) res) = do-  (e1', sv1) <- defuncExp e1+defuncExp (AppExp (Loop sparams pat loopinit form e3 loc) res) = do+  (e1', sv1) <- defuncExp $ loopInitExp loopinit   let env1 = alwaysMatchPatSV pat sv1   (form', env2) <- case form of     For v e2 -> do@@ -599,7 +602,7 @@       e2' <- localEnv env1 $ defuncExp' e2       pure (While e2', mempty)   (e3', sv) <- localEnv (env1 <> env2) $ defuncExp e3-  pure (AppExp (Loop sparams pat e1' form' e3' loc) res, sv)+  pure (AppExp (Loop sparams pat (LoopInitExplicit e1') form' e3' loc) res, sv)   where     envFromIdent (Ident vn (Info tp) _) =       M.singleton vn $ Binding Nothing $ Dynamic $ toParam Observe tp@@ -1065,7 +1068,7 @@ buildEnvPat sizes env = RecordPat (map buildField $ M.toList env) mempty   where     buildField (vn, Binding _ sv) =-      ( nameFromString (prettyString vn),+      ( L noLoc $ nameFromText (prettyText vn),         if vn `elem` sizes           then Wildcard (Info $ paramTypeFromSV sv) mempty           else Id vn (Info $ paramTypeFromSV sv) mempty@@ -1119,7 +1122,7 @@ matchPatSV (TuplePat ps _) (RecordSV ls) =   mconcat <$> zipWithM (\p (_, sv) -> matchPatSV p sv) ps ls matchPatSV (RecordPat ps _) (RecordSV ls)-  | ps' <- sortOn fst ps,+  | ps' <- sortOn fst $ map (first unLoc) ps,     ls' <- sortOn fst ls,     map fst ps' == map fst ls' =       mconcat <$> zipWithM (\(_, p) (_, sv) -> matchPatSV p sv) ps' ls'

@@ -8,6 +8,7 @@  import Control.Monad import Control.Monad.State.Strict+import Data.Bifunctor (first) import Data.List (find, intersperse) import Data.Map qualified as M import Futhark.IR qualified as I@@ -15,7 +16,7 @@ import Futhark.Util (chunks) import Futhark.Util.Pretty (prettyTextOneLine) import Language.Futhark qualified as E hiding (TypeArg)-import Language.Futhark.Core (Name, Uniqueness (..), VName, nameFromText)+import Language.Futhark.Core (L (..), Name, Uniqueness (..), VName, nameFromText, unLoc) import Language.Futhark.Semantic qualified as E  -- | The types that are visible to the outside world.@@ -66,7 +67,7 @@     g (E.TERecord tes _) =       "{" <> mconcat (intersperse ", " (map onField tes)) <> "}"       where-        onField (k, te) = E.nameToText k <> ":" <> f te+        onField (L _ k, te) = E.nameToText k <> ":" <> f te     g (E.TESum cs _) =       mconcat (intersperse " | " (map onConstr cs))       where@@ -96,7 +97,7 @@   VisibleTypes ->   E.TypeExp E.Exp VName ->   Maybe (M.Map Name (E.TypeExp E.Exp VName))-isRecord _ (E.TERecord fs _) = Just $ M.fromList fs+isRecord _ (E.TERecord fs _) = Just $ M.fromList $ map (first unLoc) fs isRecord _ (E.TETuple fs _) = Just $ E.tupleFields fs isRecord types (E.TEVar v _) = isRecord types =<< findType (E.qualLeaf v) types isRecord _ _ = Nothing

@@ -316,7 +316,7 @@     letSubExp "range_invalid" $       I.BasicOp $         I.BinOp I.LogOr step_invalid bounds_invalid-  valid <- letSubExp "valid" $ I.BasicOp $ I.UnOp I.Not invalid+  valid <- letSubExp "valid" $ I.BasicOp $ I.UnOp (I.Neg I.Bool) invalid   cs <- assert "range_valid_c" valid errmsg loc    step_i64 <- asIntS Int64 step@@ -394,8 +394,8 @@   internalisePat desc sizes pat e $ internaliseExp desc body internaliseAppExp _ _ (E.LetFun ofname _ _ _) =   error $ "Unexpected LetFun " ++ prettyString ofname-internaliseAppExp desc _ (E.Loop sparams mergepat mergeexp form loopbody loc) = do-  ses <- internaliseExp "loop_init" mergeexp+internaliseAppExp desc _ (E.Loop sparams mergepat loopinit form loopbody loc) = do+  ses <- internaliseExp "loop_init" $ loopInitExp loopinit   ((loopbody', (form', shapepat, mergepat', mergeinit')), initstms) <-     collectStms $ handleForm ses form @@ -628,12 +628,12 @@ internaliseExp desc (E.RecordLit orig_fields _) =   concatMap snd . sortFields . M.unions <$> mapM internaliseField orig_fields   where-    internaliseField (E.RecordFieldExplicit name e _) =+    internaliseField (E.RecordFieldExplicit (L _ name) e _) =       M.singleton name <$> internaliseExp desc e-    internaliseField (E.RecordFieldImplicit name t loc) =+    internaliseField (E.RecordFieldImplicit (L _ name) t loc) =       internaliseField $         E.RecordFieldExplicit-          (baseName name)+          (L noLoc (baseName name))           (E.Var (E.qualName name) t loc)           loc internaliseExp desc (E.ArrayVal vs t _) =@@ -720,11 +720,9 @@   e' <- internaliseExp1 "negate_arg" e   et <- subExpType e'   case et of-    I.Prim (I.IntType t) ->-      letTupExp' desc $ I.BasicOp $ I.BinOp (I.Sub t I.OverflowWrap) (I.intConst t 0) e'-    I.Prim (I.FloatType t) ->-      letTupExp' desc $ I.BasicOp $ I.BinOp (I.FSub t) (I.floatConst t 0) e'-    _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in Negate"+    I.Prim pt ->+      letTupExp' desc $ I.BasicOp $ I.UnOp (I.Neg pt) e'+    _ -> error "Futhark.Internalise.internaliseExp: non-primitive type in Negate" internaliseExp desc (E.Not e _) = do   e' <- internaliseExp1 "not_arg" e   et <- subExpType e'@@ -732,7 +730,7 @@     I.Prim (I.IntType t) ->       letTupExp' desc $ I.BasicOp $ I.UnOp (I.Complement t) e'     I.Prim I.Bool ->-      letTupExp' desc $ I.BasicOp $ I.UnOp I.Not e'+      letTupExp' desc $ I.BasicOp $ I.UnOp (I.Neg I.Bool) e'     _ ->       error "Futhark.Internalise.internaliseExp: non-int/bool type in Not" internaliseExp desc (E.Update src slice ve loc) = do@@ -954,7 +952,7 @@     compares (E.TuplePat pats _) ses =       comparesMany pats ses     compares (E.RecordPat fs _) ses =-      comparesMany (map snd $ E.sortFields $ M.fromList fs) ses+      comparesMany (map snd $ E.sortFields $ M.fromList $ map (first unLoc) fs) ses     compares (E.PatAscription pat _ _) ses =       compares pat ses     compares pat [] =@@ -1083,7 +1081,7 @@   n <- letSubExp "n" =<< divRounding (toExp j_m_i) (toExp s')    zero_stride <- letSubExp "zero_stride" $ I.BasicOp $ I.CmpOp (CmpEq int64) s_sign zero-  nonzero_stride <- letSubExp "nonzero_stride" $ I.BasicOp $ I.UnOp I.Not zero_stride+  nonzero_stride <- letSubExp "nonzero_stride" $ I.BasicOp $ I.UnOp (I.Neg I.Bool) zero_stride    -- Bounds checks depend on whether we are slicing forwards or   -- backwards.  If forwards, we must check '0 <= i && i <= j'.  If@@ -1320,7 +1318,7 @@     letSubExp "zero" $       I.BasicOp $         CmpOp (CmpEq (IntType t)) x (intConst t 0)-  nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp I.Not zero+  nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp (I.Neg I.Bool) zero   c <- assert "nonzero_cert" nonzero "division by zero" loc   certifying c m @@ -1427,7 +1425,7 @@   simpleCmpOp desc (I.CmpEq $ internalisePrimType t) x y internaliseBinOp _ desc E.NotEqual x y t _ = do   eq <- letSubExp (desc ++ "true") $ I.BasicOp $ I.CmpOp (I.CmpEq $ internalisePrimType t) x y-  fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp I.Not eq+  fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp (I.Neg I.Bool) eq internaliseBinOp _ desc E.Less x y (E.Signed t) _ =   simpleCmpOp desc (I.CmpSlt t) x y internaliseBinOp _ desc E.Less x y (E.Unsigned t) _ =@@ -1552,7 +1550,7 @@           cmp_f =<< letSubExp "eq" =<< eAll rs       where         isEqlOp "!=" = Just $ \eq ->-          letTupExp' desc $ I.BasicOp $ I.UnOp I.Not eq+          letTupExp' desc $ I.BasicOp $ I.UnOp (I.Neg I.Bool) eq         isEqlOp "==" = Just $ \eq ->           pure [eq]         isEqlOp _ = Nothing@@ -2033,21 +2031,18 @@   argts' <- mapM subExpType args'   case rettype_fun $ zip args' argts' of     Nothing ->-      error $-        concat-          [ "Cannot apply ",-            prettyString fname,-            " to ",-            show (length args'),-            " arguments\n ",-            prettyString args',-            "\nof types\n ",-            prettyString argts',-            "\nFunction has ",-            show (length fun_params),-            " parameters\n ",-            prettyString fun_params-          ]+      error . unlines $+        [ "Cannot apply "+            <> prettyString fname+            <> " to "+            <> show (length args')+            <> " arguments",+          " " <> prettyString args',+          "of types",+          " " <> prettyString argts',+          "Function has " <> show (length fun_params) <> " parameters",+          " " <> prettyString fun_params+        ]     Just ts -> do       safety <- askSafety       attrs <- asks envAttrs

@@ -170,8 +170,8 @@     f (RecordFieldExplicit n e floc) = do       e' <- getOrdering False e       pure $ RecordFieldExplicit n e' floc-    f (RecordFieldImplicit v t _) =-      f $ RecordFieldExplicit (baseName v) (Var (qualName v) t loc) loc+    f (RecordFieldImplicit (L vloc v) t _) =+      f $ RecordFieldExplicit (L vloc (baseName v)) (Var (qualName v) t loc) loc getOrdering _ (ArrayVal vs t loc) =   pure $ ArrayVal vs t loc getOrdering _ (ArrayLit es ty loc)@@ -300,13 +300,13 @@   ef' <- transformBody ef   nameExp final $ AppExp (If cond' et' ef' loc) resT getOrdering final (AppExp (Loop sizes pat einit form body loc) resT) = do-  einit' <- getOrdering False einit+  einit' <- getOrdering False $ loopInitExp einit   form' <- case form of     For ident e -> For ident <$> getOrdering True e     ForIn fpat e -> ForIn fpat <$> getOrdering True e     While e -> While <$> transformBody e   body' <- transformBody body-  nameExp final $ AppExp (Loop sizes pat einit' form' body' loc) resT+  nameExp final $ AppExp (Loop sizes pat (LoopInitExplicit einit') form' body' loc) resT getOrdering final (AppExp (BinOp (op, oloc) opT (el, Info elp) (er, Info erp) loc) (Info resT)) = do   expr' <- case (isOr, isAnd) of     (True, _) -> do

@@ -168,11 +168,11 @@         <$> bindingLetPat [] case_pat (transformExp case_e)         <*> pure case_loc transformExp (AppExp (Loop sizes pat args form body loc) appres) = do-  args' <- transformExp args+  args' <- transformExp $ loopInitExp args   bindingParams sizes [pat] $ do     form' <- astMap transformSubExps form     body' <- bindingForm form' $ transformExp body-    pure $ AppExp (Loop sizes pat args' form' body' loc) appres+    pure $ AppExp (Loop sizes pat (LoopInitExplicit args') form' body' loc) appres transformExp e@(Var v (Info t) _) =   -- Note that function-typed variables can only occur in expressions,   -- not in other places where VNames/QualNames can occur.

@@ -513,8 +513,8 @@     <*> transformAppRes res   where     onArg (Info ext, e) = (ext,) <$> transformExp e-transformAppExp (Loop sparams pat e1 form body loc) res = do-  e1' <- transformExp e1+transformAppExp (Loop sparams pat loopinit form body loc) res = do+  e1' <- transformExp $ loopInitExp loopinit    let dimArgs = S.fromList sparams   pat' <- withArgs dimArgs $ transformPat pat@@ -540,7 +540,7 @@   -- sizes for them.   (pat_sizes, pat'') <- sizesForPat pat'   res' <- transformAppRes res-  pure $ AppExp (Loop (sparams' ++ pat_sizes) pat'' e1' form' body' loc) (Info res')+  pure $ AppExp (Loop (sparams' ++ pat_sizes) pat'' (LoopInitExplicit e1') form' body' loc) (Info res') transformAppExp (BinOp (fname, _) (Info t) (e1, d1) (e2, d2) loc) res = do   (AppRes ret ext) <- transformAppRes res   fname' <- transformFName loc fname (toStruct t)@@ -633,11 +633,11 @@   where     transformField (RecordFieldExplicit name e loc') =       RecordFieldExplicit name <$> transformExp e <*> pure loc'-    transformField (RecordFieldImplicit v t _) = do+    transformField (RecordFieldImplicit (L vloc v) t _) = do       t' <- traverse transformType t       transformField $         RecordFieldExplicit-          (baseName v)+          (L vloc (baseName v))           (Var (qualName v) t' loc)           loc transformExp (ArrayVal vs t loc) =

@@ -7,39 +7,49 @@ import Control.Monad import Control.Monad.Reader import Control.Monad.State+import Data.Bifunctor+import Data.Bitraversable import Data.Map.Strict qualified as M import Futhark.MonadFreshNames import Language.Futhark import Language.Futhark.Traversals  -- Mapping from record names to the variable names that contain the--- fields.  This is used because the monomorphiser also expands all--- record patterns.+-- fields, as well as an expression for the entire record. This is+-- used because the monomorphiser also expands all, record patterns. type RecordReplacements = M.Map VName RecordReplacement -type RecordReplacement = M.Map Name (VName, StructType)+type RecordReplacement = (M.Map Name (VName, StructType), Exp)  newtype Env = Env   { envRecordReplacements :: RecordReplacements   } +data S = S+  { stateNameSource :: VNameSource,+    stateStructTypeMemo :: M.Map StructType StructType,+    stateParamTypeMemo :: M.Map ParamType ParamType+  }+ -- The monomorphization monad. newtype RecordM a-  = RecordM (ReaderT Env (State VNameSource) a)+  = RecordM (ReaderT Env (State S) a)   deriving     ( Functor,       Applicative,       Monad,-      MonadReader Env+      MonadReader Env,+      MonadState S     )  instance MonadFreshNames RecordM where-  getNameSource = RecordM get-  putNameSource = RecordM . put+  getNameSource = RecordM $ gets stateNameSource+  putNameSource src = RecordM $ modify $ \s -> s {stateNameSource = src}  runRecordM :: VNameSource -> RecordM a -> (a, VNameSource) runRecordM src (RecordM m) =-  runState (runReaderT m (Env mempty)) src+  second stateNameSource $+    runState (runReaderT m (Env mempty)) (S src mempty mempty)  withRecordReplacements :: RecordReplacements -> RecordM a -> RecordM a withRecordReplacements rr = local $ \env ->@@ -50,86 +60,142 @@  wildcard :: TypeBase Size u -> SrcLoc -> Pat (TypeBase Size u) wildcard (Scalar (Record fs)) loc =-  RecordPat (zip (M.keys fs) $ map ((`Wildcard` loc) . Info) $ M.elems fs) loc+  RecordPat (zip (map (L noLoc) (M.keys fs)) $ map ((`Wildcard` loc) . Info) $ M.elems fs) loc wildcard t loc =   Wildcard (Info t) loc -transformPat :: Pat (TypeBase Size u) -> RecordM (Pat (TypeBase Size u), RecordReplacements)-transformPat (Id v (Info (Scalar (Record fs))) loc) = do+memoParamType :: ParamType -> RecordM ParamType -> RecordM ParamType+memoParamType t m = do+  prev <- gets $ M.lookup t . stateParamTypeMemo+  case prev of+    Just t' -> pure t'+    Nothing -> do+      t' <- m+      modify $ \s -> s {stateParamTypeMemo = M.insert t t' $ stateParamTypeMemo s}+      pure t'++memoStructType :: StructType -> RecordM StructType -> RecordM StructType+memoStructType t m = do+  prev <- gets $ M.lookup t . stateStructTypeMemo+  case prev of+    Just t' -> pure t'+    Nothing -> do+      t' <- m+      modify $ \s -> s {stateStructTypeMemo = M.insert t t' $ stateStructTypeMemo s}+      pure t'++-- No need to keep memoisation cache between top level functions.+memoClear :: RecordM ()+memoClear = modify $ \s ->+  s+    { stateStructTypeMemo = mempty,+      stateParamTypeMemo = mempty+    }++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   let fs' = M.toList fs   (fs_ks, fs_ts) <- fmap unzip $     forM fs' $ \(f, ft) ->       (,) <$> newVName (nameToString f) <*> pure ft   pure     ( RecordPat-        (zip (map fst fs') (zipWith3 Id fs_ks (map Info fs_ts) $ repeat loc))+        (zip (map (L noLoc . fst) fs') (zipWith3 Id fs_ks (map Info fs_ts) $ repeat loc))         loc,-      M.singleton v $ M.fromList $ zip (map fst fs') $ zip fs_ks $ map toStruct fs_ts+      M.singleton+        v+        ( M.fromList $ zip (map fst fs') $ zip fs_ks $ map toStruct fs_ts,+          RecordLit (zipWith3 toField (map fst fs') fs_ks fs_ts) loc+        )     )-transformPat (Id v t loc) =-  pure (Id v t loc, mempty)-transformPat (TuplePat pats loc) = do-  (pats', rrs) <- mapAndUnzipM transformPat pats+  where+    toField f f_v f_t =+      let f_v' = Var (qualName f_v) (Info $ toStruct f_t) loc+       in RecordFieldExplicit (L noLoc f) f_v' loc+transformPat onType (Id v t loc) = do+  t' <- traverse onType t+  pure (Id v t' loc, mempty)+transformPat onType (TuplePat pats loc) = do+  (pats', rrs) <- mapAndUnzipM (transformPat onType) pats   pure (TuplePat pats' loc, mconcat rrs)-transformPat (RecordPat fields loc) = do+transformPat onType (RecordPat fields loc) = do   let (field_names, field_pats) = unzip fields-  (field_pats', rrs) <- mapAndUnzipM transformPat field_pats+  (field_pats', rrs) <- mapAndUnzipM (transformPat onType) field_pats   pure (RecordPat (zip field_names field_pats') loc, mconcat rrs)-transformPat (PatParens pat loc) = do-  (pat', rr) <- transformPat pat+transformPat onType (PatParens pat loc) = do+  (pat', rr) <- transformPat onType pat   pure (PatParens pat' loc, rr)-transformPat (PatAttr attr pat loc) = do-  (pat', rr) <- transformPat pat+transformPat onType (PatAttr attr pat loc) = do+  (pat', rr) <- transformPat onType pat   pure (PatAttr attr pat' loc, rr)-transformPat (Wildcard (Info t) loc) =-  pure (wildcard t loc, mempty)-transformPat (PatAscription pat _ _) =-  transformPat pat-transformPat (PatLit e t loc) = pure (PatLit e t loc, mempty)-transformPat (PatConstr name t all_ps loc) = do-  (all_ps', rrs) <- mapAndUnzipM transformPat all_ps+transformPat onType (Wildcard (Info t) loc) = do+  t' <- onType t+  pure (wildcard t' loc, mempty)+transformPat onType (PatAscription pat _ _) =+  transformPat onType pat+transformPat _ (PatLit e t loc) =+  pure (PatLit e t loc, mempty)+transformPat onType (PatConstr name t all_ps loc) = do+  (all_ps', rrs) <- mapAndUnzipM (transformPat onType) all_ps   pure (PatConstr name t all_ps' loc, mconcat rrs) +transformParamType :: ParamType -> RecordM ParamType+transformParamType t = memoParamType t $ bitraverse transformExp pure t++transformStructType :: StructType -> RecordM StructType+transformStructType t = memoStructType t $ bitraverse transformExp pure t+ transformExp :: Exp -> RecordM Exp transformExp (Project n e t loc) = do   maybe_fs <- case e of     Var qn _ _ -> lookupRecordReplacement (qualLeaf qn)     _ -> pure Nothing   case maybe_fs of-    Just m+    Just (m, _)       | Just (v, _) <- M.lookup n m ->           pure $ Var (qualName v) t loc     _ -> do       e' <- transformExp e       pure $ Project n e' t loc-transformExp e@(Var fname _ loc) = do+transformExp (Var fname t loc) = do   maybe_fs <- lookupRecordReplacement $ qualLeaf fname   case maybe_fs of-    Just fs -> do-      let toField (f, (f_v, f_t)) = do-            let f_v' = Var (qualName f_v) (Info f_t) loc-            pure $ RecordFieldExplicit f f_v' loc-      RecordLit <$> mapM toField (M.toList fs) <*> pure loc+    Just (_, e) -> pure e     Nothing ->-      pure e+      Var fname <$> traverse transformStructType t <*> pure loc transformExp (AppExp (LetPat sizes pat e body loc) res) = do   e' <- transformExp e-  (pat', rr) <- transformPat pat+  (pat', rr) <- transformPat transformStructType pat   body' <- withRecordReplacements rr $ transformExp body   pure $ AppExp (LetPat sizes pat' e' body' loc) res-transformExp (AppExp (LetFun {}) _) = do-  error "transformExp: LetFun is not supposed to occur"-transformExp (Lambda {}) =-  error "transformExp: Lambda is not supposed to occur"+transformExp (AppExp (LetFun fname (tparams, params, retdecl, ret, funbody) body loc) res) = do+  (params', rrs) <- mapAndUnzipM (transformPat transformParamType) params+  funbody' <- withRecordReplacements (mconcat rrs) $ transformExp funbody+  body' <- transformExp body+  pure $ AppExp (LetFun fname (tparams, params', retdecl, ret, funbody') body' loc) res+transformExp (Lambda params body retdecl ret loc) = do+  (params', rrs) <- mapAndUnzipM (transformPat transformParamType) params+  body' <- withRecordReplacements (mconcat rrs) $ transformExp body+  pure $ Lambda params' body' retdecl ret loc transformExp e = astMap m e   where     m = identityMapper {mapOnExp = transformExp}  onValBind :: ValBind -> RecordM ValBind onValBind vb = do-  (params', rrs) <- mapAndUnzipM transformPat $ valBindParams vb+  (params', rrs) <- mapAndUnzipM (transformPat transformParamType) $ valBindParams vb   e' <- withRecordReplacements (mconcat rrs) $ transformExp $ valBindBody vb-  pure $ vb {valBindBody = e', valBindParams = params'}+  ret <- traverse (bitraverse transformExp pure) $ valBindRetType vb+  memoClear+  pure $+    vb+      { valBindBody = e',+        valBindParams = params',+        valBindRetType = ret+      }  -- | Monomorphise a list of top-level declarations. A module-free input program -- is expected, so only value declarations and type declaration are accepted.

@@ -87,7 +87,7 @@           Sub _ _ -> Just (s, o - valueIntegral v)           Mul _ _ -> Just (s * valueIntegral v, o * valueIntegral v)           _ -> Nothing-    reduce _ (UnOpExp Not _) = Nothing+    reduce _ (UnOpExp (Neg Bool) _) = Nothing     reduce _ (UnOpExp (Complement _) _) = Nothing     reduce _ (UnOpExp (Abs _) _) = Nothing     reduce _ (UnOpExp _ sub_op) = reduceStrideAndOffset sub_op

@@ -134,7 +134,7 @@     onBody :: Maybe Used -> Body SOACS -> State (M.Map Name Used) ()     onBody u = mapM_ (onStm u) . bodyStms     onStm u stm = onExp u (stmExp stm) $> stm-    onExp (Just u) (Apply fname _ _ _) = modify $ M.insert fname u+    onExp (Just u) (Apply fname _ _ _) = modify $ M.insertWith max fname u     onExp Nothing Apply {} = pure ()     onExp u e = walkExpM (walker u) e     onSOAC u soac = void $ traverseSOACStms (const (traverse (onStm u'))) soac

@@ -297,7 +297,7 @@     Match [cond'] [Case [Just (BoolValue True)] taken_body] untaken_body $       MatchDec if_ts MatchFallback protectIf _ _ taken (Let pat aux (BasicOp (Assert cond msg loc))) = do-  not_taken <- letSubExp "loop_not_taken" $ BasicOp $ UnOp Not taken+  not_taken <- letSubExp "loop_not_taken" $ BasicOp $ UnOp (Neg Bool) taken   cond' <- letSubExp "protect_assert_disj" $ BasicOp $ BinOp LogOr not_taken cond   auxing aux $ letBind pat $ BasicOp $ Assert cond' msg loc protectIf protect _ taken (Let pat aux (Op op))@@ -380,7 +380,7 @@   letSubExp "matching_just_this"     =<< eBinOp       LogAnd-      (eUnOp Not (eAny prior_matches))+      (eUnOp (Neg Bool) (eAny prior_matches))       (eSubExp =<< matching (zip ses this))  -- | We are willing to hoist potentially unsafe statements out of

@@ -224,7 +224,7 @@           p_and_eq_x_y <-             letSubExp "p_and_eq_x_y" $ BasicOp $ BinOp LogAnd p eq_x_y           not_p <--            letSubExp "not_p" $ BasicOp $ UnOp Not p+            letSubExp "not_p" $ BasicOp $ UnOp (Neg Bool) p           not_p_and_eq_x_z <-             letSubExp "p_and_eq_x_y" $ BasicOp $ BinOp LogAnd not_p eq_x_z           letBind pat $

@@ -74,6 +74,8 @@         all (worthInlining . untyped) inds'',         arr `ST.available` vtable,         all (`ST.elem` vtable) (unCerts cs),+        not consuming,+        not $ consumed arr,         Just inds''' <- mapM okIdx inds'' -> do           Just $ IndexResult cs arr . Slice <$> sequence inds'''       where

@@ -80,7 +80,7 @@           (pure $ BasicOp $ BinOp LogAnd cond tres)           ( eBinOp               LogAnd-              (pure $ BasicOp $ UnOp Not cond)+              (pure $ BasicOp $ UnOp (Neg Bool) cond)               (pure $ BasicOp $ SubExp fres)           )       certifying (tcs <> fcs) $ letBind pat e@@ -102,7 +102,7 @@         else           if zeroIshInt t && oneIshInt f             then Simplify $ do-              cond_neg <- letSubExp "cond_neg" $ BasicOp $ UnOp Not cond+              cond_neg <- letSubExp "cond_neg" $ BasicOp $ UnOp (Neg Bool) cond               letBind pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond_neg             else Skip -- Simplify

@@ -51,7 +51,7 @@   | Just (BasicOp (ConvOp BToI {} b), cs) <- look v =       case valueIntegral x :: Int of         1 -> Just (SubExp b, cs)-        0 -> Just (UnOp Not b, cs)+        0 -> Just (UnOp (Neg Bool) b, cs)         _ -> Just (SubExp (Constant (BoolValue False)), cs) simplifyCmpOp _ _ _ = Nothing @@ -176,11 +176,11 @@   | isCt1 e1 = resIsSubExp e2   | isCt1 e2 = resIsSubExp e1   | Var v <- e1,-    Just (BasicOp (UnOp Not e1'), v_cs) <- defOf v,+    Just (BasicOp (UnOp (Neg Bool) e1'), v_cs) <- defOf v,     e1' == e2 =       Just (SubExp $ Constant $ BoolValue False, v_cs)   | Var v <- e2,-    Just (BasicOp (UnOp Not e2'), v_cs) <- defOf v,+    Just (BasicOp (UnOp (Neg Bool) e2'), v_cs) <- defOf v,     e2' == e1 =       Just (SubExp $ Constant $ BoolValue False, v_cs) simplifyBinOp defOf _ (BinOp LogOr e1 e2)@@ -189,11 +189,11 @@   | isCt1 e1 = constRes $ BoolValue True   | isCt1 e2 = constRes $ BoolValue True   | Var v <- e1,-    Just (BasicOp (UnOp Not e1'), v_cs) <- defOf v,+    Just (BasicOp (UnOp (Neg Bool) e1'), v_cs) <- defOf v,     e1' == e2 =       Just (SubExp $ Constant $ BoolValue True, v_cs)   | Var v <- e2,-    Just (BasicOp (UnOp Not e2'), v_cs) <- defOf v,+    Just (BasicOp (UnOp (Neg Bool) e2'), v_cs) <- defOf v,     e2' == e1 =       Just (SubExp $ Constant $ BoolValue True, v_cs) simplifyBinOp defOf _ (BinOp (SMax it) e1 e2)@@ -226,8 +226,8 @@ simplifyUnOp :: SimpleRule rep simplifyUnOp _ _ (UnOp op (Constant v)) =   constRes =<< doUnOp op v-simplifyUnOp defOf _ (UnOp Not (Var v))-  | Just (BasicOp (UnOp Not v2), v_cs) <- defOf v =+simplifyUnOp defOf _ (UnOp (Neg Bool) (Var v))+  | Just (BasicOp (UnOp (Neg Bool) v2), v_cs) <- defOf v =       Just (SubExp v2, v_cs) simplifyUnOp _ _ _ =   Nothing

@@ -53,12 +53,9 @@ -- | Description of a test to be carried out on a Futhark program. -- The Futhark program is stored separately. data ProgramTest = ProgramTest-  { testDescription ::-      T.Text,-    testTags ::-      [T.Text],-    testAction ::-      TestAction+  { testDescription :: T.Text,+    testTags :: [T.Text],+    testAction :: TestAction   }   deriving (Show) @@ -109,7 +106,7 @@  -- | A condition for execution, input, and expected result. data TestRun = TestRun-  { runTags :: [String],+  { runTags :: [T.Text],     runInput :: Values,     runExpectedResult :: ExpectedResult Success,     runIndex :: Int,@@ -201,10 +198,17 @@     pDescLine = restOfLine <* sep     pDescriptionSeparator = void $ "==" *> sep +lTagName :: Parser () -> Parser T.Text+lTagName sep =+  lexeme sep $+    takeWhile1P (Just "tag-constituent character") tagConstituent+ parseTags :: Parser () -> Parser [T.Text]-parseTags sep = lexeme' "tags" *> inBraces sep (many parseTag) <|> pure []-  where-    parseTag = T.pack <$> lexeme sep (some $ satisfy tagConstituent)+parseTags sep =+  choice+    [ lexeme' "tags" *> inBraces sep (many (lTagName sep)),+      pure []+    ]  tagConstituent :: Char -> Bool tagConstituent c = isAlphaNum c || c == '_' || c == '-'@@ -233,11 +237,11 @@   (lexeme' "entry:" *> many entry <* sep) <|> pure ["main"]   where     constituent c = not (isSpace c) && c /= '}'-    entry = lexeme' $ T.pack <$> some (satisfy constituent)+    entry = lexeme' $ takeWhile1P Nothing constituent -parseRunTags :: Parser [String]-parseRunTags = many . try . lexeme' $ do-  s <- some $ satisfy tagConstituent+parseRunTags :: Parser () -> Parser [T.Text]+parseRunTags sep = many . try . lexeme' $ do+  s <- lTagName sep   guard $ s `notElem` ["input", "structure", "warning"]   pure s @@ -253,7 +257,7 @@         <|> pure []     parseRunCase i = do       name <- optional $ parseStringLiteral sep-      tags <- parseRunTags+      tags <- parseRunTags sep       void $ lexeme sep "input"       input <-         if "random" `elem` tags@@ -360,7 +364,7 @@ parseMetrics :: Parser () -> Parser AstMetrics parseMetrics sep =   inBraces sep . fmap (AstMetrics . M.fromList) . many $-    (,) <$> (T.pack <$> lexeme sep (some (satisfy constituent))) <*> parseNatural sep+    (,) <$> lexeme sep (takeWhile1P Nothing constituent) <*> parseNatural sep   where     constituent c = isAlpha c || c == '/' 

@@ -60,10 +60,11 @@   colours <- hIsTerminalDevice h   if colours     then Prettyprinter.Render.Terminal.renderIO h (layouter d)-    else Prettyprinter.Render.Text.hPutDoc h d+    else Prettyprinter.Render.Text.renderIO h (layouter d)   where     layouter =-      layoutSmart defaultLayoutOptions {layoutPageWidth = Unbounded}+      removeTrailingWhitespace+        . layoutSmart defaultLayoutOptions {layoutPageWidth = Unbounded}  -- | Like 'hPutDoc', but with a final newline. hPutDocLn :: Handle -> Doc AnsiStyle -> IO ()@@ -87,7 +88,7 @@ docTextForHandle :: Handle -> Doc AnsiStyle -> IO T.Text docTextForHandle h d = do   colours <- hIsTerminalDevice h-  let sds = layoutSmart defaultLayoutOptions d+  let sds = removeTrailingWhitespace $ layoutSmart defaultLayoutOptions d   pure $     if colours       then Prettyprinter.Render.Terminal.renderStrict sds@@ -111,7 +112,8 @@ docText = Prettyprinter.Render.Text.renderStrict . layouter   where     layouter =-      layoutSmart defaultLayoutOptions {layoutPageWidth = Unbounded}+      removeTrailingWhitespace+        . layoutSmart defaultLayoutOptions {layoutPageWidth = Unbounded}  -- | Convert a 'Doc' to a 'String', through 'docText'. Intended for -- debugging.

@@ -9,6 +9,9 @@     SrcLoc,     Loc,     Located (..),+    noLoc,+    L (..),+    unLoc,     srclocOf,     locStr,     locStrRel,

@@ -53,7 +53,7 @@   RecordLit fs _ -> foldMap freeInExpField fs     where       freeInExpField (RecordFieldExplicit _ e _) = freeInExp e-      freeInExpField (RecordFieldImplicit vn t _) = ident $ Ident vn t mempty+      freeInExpField (RecordFieldImplicit (L _ vn) t _) = ident $ Ident vn t mempty   ArrayVal {} -> mempty   ArrayLit es t _ ->     foldMap freeInExp es <> freeInType (unInfo t)@@ -87,7 +87,7 @@   IndexSection idxs _ _ -> foldMap freeInDimIndex idxs   AppExp (Loop sparams pat e1 form e3 _) _ ->     let (e2fv, e2ident) = formVars form-     in freeInExp e1+     in freeInExp (loopInitExp e1)           <> ( (e2fv <> freeInExp e3)                  `freeWithoutL` (sparams <> patNames pat <> e2ident)              )

@@ -452,7 +452,7 @@     zip ps (map snd $ sortFields vs) patternMatch env (RecordPat ps _) (ValueRecord vs) =   foldM (\env' (p, v) -> patternMatch env' p v) env $-    M.intersectionWith (,) (M.fromList ps) vs+    M.intersectionWith (,) (M.fromList $ map (first unLoc) ps) vs patternMatch env (PatParens p _) v = patternMatch env p v patternMatch env (PatAscription p _ _) v =   patternMatch env p v@@ -882,8 +882,8 @@   eval (valEnv (M.singleton (identName dest) (Just t, dest')) <> env) body   where     oob = bad loc env "Update out of bounds"-evalAppExp env (Loop sparams pat init_e form body _) = do-  init_v <- eval env init_e+evalAppExp env (Loop sparams pat loopinit form body _) = do+  init_v <- eval env $ loopInitExp loopinit   case form of     For iv bound -> do       bound' <- asSigned <$> eval env bound@@ -945,12 +945,6 @@         Just v' -> pure v'         Nothing -> match v cs' -zeroOfType :: PrimType -> Value-zeroOfType (Signed it) = ValuePrim $ SignedValue $ P.intValue it (0 :: Int)-zeroOfType (Unsigned it) = ValuePrim $ UnsignedValue $ P.intValue it (0 :: Int)-zeroOfType (FloatType ft) = ValuePrim $ FloatValue $ P.floatValue ft (0 :: Int)-zeroOfType Bool = ValuePrim $ BoolValue False- eval :: Env -> Exp -> EvalM Value eval _ (Literal v _) = pure $ ValuePrim v eval env (Hole (Info t) loc) =@@ -965,10 +959,10 @@ eval env (RecordLit fields _) =   ValueRecord . M.fromList <$> mapM evalField fields   where-    evalField (RecordFieldExplicit k e _) = do+    evalField (RecordFieldExplicit (L _ k) e _) = do       v <- eval env e       pure (k, v)-    evalField (RecordFieldImplicit k t loc) = do+    evalField (RecordFieldImplicit (L _ k) t loc) = do       v <- eval env $ Var (qualName k) t loc       pure (baseName k, v) eval _ (StringLit vs _) =@@ -1022,13 +1016,9 @@     Scalar (Prim (FloatType ft)) ->       pure $ ValuePrim $ FloatValue $ floatValue ft v     _ -> error $ "eval: nonsensical type for float literal: " <> prettyString t-eval env (Negate e loc) =-  -- -x = 0-x-  case typeOf e of-    Scalar (Prim pt) -> do-      ev <- eval env e-      apply2 loc env intrinsicsMinus (zeroOfType pt) ev-    t -> error $ "Cannot negate expression of type  " <> prettyString t+eval env (Negate e loc) = do+  ev <- eval env e+  apply loc env intrinsicsNeg ev eval env (Not e loc) =   apply loc env intrinsicsNot =<< eval env e eval env (Update src is v loc) =@@ -1493,8 +1483,24 @@             (getU, putU, P.doUnOp $ P.Complement Int16, adUnOp $ AD.OpUn $ P.Complement Int16),             (getU, putU, P.doUnOp $ P.Complement Int32, adUnOp $ AD.OpUn $ P.Complement Int32),             (getU, putU, P.doUnOp $ P.Complement Int64, adUnOp $ AD.OpUn $ P.Complement Int64),-            (getB, putB, P.doUnOp P.Not, adUnOp $ AD.OpUn P.Not)+            (getB, putB, P.doUnOp $ P.Neg P.Bool, adUnOp $ AD.OpUn $ P.Neg P.Bool)           ]+    def "neg" =+      Just $+        unopDef+          [ (getS, putS, P.doUnOp $ P.Neg $ P.IntType Int8, adUnOp $ AD.OpUn $ P.Neg $ P.IntType Int8),+            (getS, putS, P.doUnOp $ P.Neg $ P.IntType Int16, adUnOp $ AD.OpUn $ P.Neg $ P.IntType Int16),+            (getS, putS, P.doUnOp $ P.Neg $ P.IntType Int32, adUnOp $ AD.OpUn $ P.Neg $ P.IntType Int32),+            (getS, putS, P.doUnOp $ P.Neg $ P.IntType Int64, adUnOp $ AD.OpUn $ P.Neg $ P.IntType Int64),+            (getU, putU, P.doUnOp $ P.Neg $ P.IntType Int8, adUnOp $ AD.OpUn $ P.Neg $ P.IntType Int8),+            (getU, putU, P.doUnOp $ P.Neg $ P.IntType Int16, adUnOp $ AD.OpUn $ P.Neg $ P.IntType Int16),+            (getU, putU, P.doUnOp $ P.Neg $ P.IntType Int32, adUnOp $ AD.OpUn $ P.Neg $ P.IntType Int32),+            (getU, putU, P.doUnOp $ P.Neg $ P.IntType Int64, adUnOp $ AD.OpUn $ P.Neg $ P.IntType Int64),+            (getF, putF, P.doUnOp $ P.Neg $ P.FloatType Float16, adUnOp $ AD.OpUn $ P.Neg $ P.FloatType Float16),+            (getF, putF, P.doUnOp $ P.Neg $ P.FloatType Float32, adUnOp $ AD.OpUn $ P.Neg $ P.FloatType Float32),+            (getF, putF, P.doUnOp $ P.Neg $ P.FloatType Float64, adUnOp $ AD.OpUn $ P.Neg $ P.FloatType Float64),+            (getB, putB, P.doUnOp $ P.Neg P.Bool, adUnOp $ AD.OpUn $ P.Neg P.Bool)+          ]     def "+" = arithOp (`P.Add` P.OverflowWrap) P.FAdd     def "-" = arithOp (`P.Sub` P.OverflowWrap) P.FSub     def "*" = arithOp (`P.Mul` P.OverflowWrap) P.FMul@@ -2107,8 +2113,8 @@     Just (TermValue _ v) -> v     _ -> error $ "intrinsicVal: " <> prettyString name -intrinsicsMinus :: Value-intrinsicsMinus = intrinsicVal "-"+intrinsicsNeg :: Value+intrinsicsNeg = intrinsicVal "neg"  intrinsicsNot :: Value intrinsicsNot = intrinsicVal "!"

@@ -18,7 +18,6 @@     primNegate,     applyExp,     arrayLitExp,-    patternExp,     addDocSpec,     addAttrSpec,     addDoc,@@ -137,19 +136,6 @@       where         index = AppExp (Index e (is ++ map DimFix xs) xloc) NoInfo     op f x = pure $ mkApplyUT f x--patternExp :: UncheckedPat t -> ParserMonad UncheckedExp-patternExp (Id v _ loc) = pure $ Var (qualName v) NoInfo loc-patternExp (TuplePat pats loc) = TupLit <$> mapM patternExp pats <*> pure loc-patternExp (Wildcard _ loc) = parseErrorAt loc $ Just "cannot have wildcard here."-patternExp (PatLit _ _ loc) = parseErrorAt loc $ Just "cannot have literal here."-patternExp (PatConstr _ _ _ loc) = parseErrorAt loc $ Just "cannot have constructor here."-patternExp (PatAttr _ p _) = patternExp p-patternExp (PatAscription pat _ _) = patternExp pat-patternExp (PatParens pat _) = patternExp pat-patternExp (RecordPat fs loc) = RecordLit <$> mapM field fs <*> pure loc-  where-    field (name, pat) = RecordFieldExplicit name <$> patternExp pat <*> pure loc  binOpName :: L Token -> (QualName Name, Loc) binOpName (L loc (SYMBOL _ qs op)) = (QualName qs op, loc)

@@ -508,10 +508,10 @@          | TypeExpAtom            { TypeArgExpType $1 } -FieldType :: { (Name, UncheckedTypeExp) }-FieldType : FieldId ':' TypeExp { (fst $1, $3) }+FieldType :: { (L Name, UncheckedTypeExp) }+FieldType : FieldId ':' TypeExp { ($1, $3) } -FieldTypes :: { [(Name, UncheckedTypeExp)] }+FieldTypes :: { [(L Name, UncheckedTypeExp)] } FieldTypes :                          { [] }            | FieldType                { [$1] }            | FieldType ',' FieldTypes { $1 : $3 }@@ -578,19 +578,23 @@        { Update $1 $4 $7 (srcspan $1 $>) }       | Exp2 with FieldAccesses_ '=' Exp2-       { RecordUpdate $1 (map fst $3) $5 NoInfo (srcspan $1 $>) }--     | '\\' FunParams1 maybeAscription(TypeExpTerm) '->' Exp %prec letprec-       { Lambda (fst $2 : snd $2) $5 $3 NoInfo (srcspan $1 $>) }+       { RecordUpdate $1 (map unLoc $3) $5 NoInfo (srcspan $1 $>) }       | ApplyList {% applyExp $1 }  ApplyList :: { NE.NonEmpty UncheckedExp }           : Atom ApplyList %prec juxtprec             { NE.cons $1 $2 }-          | Atom %prec juxtprec+          | LastArg             { NE.singleton $1 } +LastArg :: { UncheckedExp }+        : '\\' FunParams1 maybeAscription(TypeExpTerm) '->' Exp %prec letprec+          { Lambda (fst $2 : snd $2) $5 $3 NoInfo (srcspan $1 $>) }+        | Atom %prec juxtprec+          { $1 }++ Atom :: { UncheckedExp } Atom : PrimLit        { Literal (fst $1) (srclocOf (snd $1)) }      | Constr         { Constr (fst $1) [] NoInfo (srclocOf (snd $1)) }@@ -662,16 +666,16 @@         | Exps1_ ','     { $1 }         | Exp            { [$1] } -FieldAccesses :: { [(Name, Loc)] }+FieldAccesses :: { [L Name] }                : '.' FieldId FieldAccesses { $2 : $3 }                |                           { [] } -FieldAccesses_ :: { [(Name, Loc)] }-               : FieldId FieldAccesses { (fst $1, snd $1) : $2 }+FieldAccesses_ :: { [L Name] }+               : FieldId FieldAccesses { $1 : $2 }  Field :: { FieldBase NoInfo Name }-       : FieldId '=' Exp { RecordFieldExplicit (fst $1) $3 (srcspan (snd $1) $>) }-       | id              { let L loc (ID s) = $1 in RecordFieldImplicit s NoInfo (srclocOf loc) }+       : FieldId '=' Exp { RecordFieldExplicit $1 $3 (srcspan $1 $>) }+       | id              { let L loc (ID s) = $1 in RecordFieldImplicit (L loc s) NoInfo (srclocOf loc) }  Fields :: { [FieldBase NoInfo Name] }        : Field ',' Fields { $1 : $3 }@@ -748,7 +752,7 @@     { OpSection (fst $2) NoInfo (srcspan $1 $>) }    | '(' '.' FieldAccesses_ ')'-    { ProjectSection (map fst $3) NoInfo (srcspan $1 $>) }+    { ProjectSection (map unLoc $3) NoInfo (srcspan $1 $>) }    | '(' '.' '[' DimIndices ']' ')'     { IndexSection $4 NoInfo (srcspan $1 $>) }@@ -767,9 +771,9 @@  LoopExp :: { UncheckedExp }          : loop Pat LoopForm do Exp %prec ifprec-           {% fmap (\t -> AppExp (Loop [] (fmap (toParam Observe) $2) t $3 $5 (srcspan $1 $>)) NoInfo) (patternExp $2) }+           { AppExp (Loop [] (fmap (toParam Observe) $2) (LoopInitImplicit NoInfo) $3 $5 (srcspan $1 $>)) NoInfo }          | loop Pat '=' Exp LoopForm do Exp %prec ifprec-           { AppExp (Loop [] (fmap (toParam Observe) $2) $4 $5 $7 (srcspan $1 $>)) NoInfo }+           { AppExp (Loop [] (fmap (toParam Observe) $2) (LoopInitExplicit $4) $5 $7 (srcspan $1 $>)) NoInfo }  MatchExp :: { UncheckedExp }           : match Exp Cases@@ -826,19 +830,19 @@               : InnerPat                { [$1] }               | ConstrFields InnerPat   { $1 ++ [$2] } -CFieldPat :: { (Name, PatBase NoInfo Name StructType) }+CFieldPat :: { (L Name, PatBase NoInfo Name StructType) }                : FieldId '=' Pat-               { (fst $1, $3) }+               { ($1, $3) }                | FieldId ':' TypeExp-               { (fst $1, PatAscription (Id (fst $1) NoInfo (srclocOf (snd $1))) $3 (srcspan (snd $1) $>)) }+               { ($1, PatAscription (Id (unLoc $1) NoInfo (srclocOf $1)) $3 (srcspan $1 $>)) }                | FieldId-               { (fst $1, Id (fst $1) NoInfo (srclocOf (snd $1))) }+               { ($1, Id (unLoc $1) NoInfo (srclocOf $1)) } -CFieldPats :: { [(Name, PatBase NoInfo Name StructType)] }+CFieldPats :: { [(L Name, PatBase NoInfo Name StructType)] }                 : CFieldPats1 { $1 }                 |             { [] } -CFieldPats1 :: { [(Name, PatBase NoInfo Name StructType)] }+CFieldPats1 :: { [(L Name, PatBase NoInfo Name StructType)] }                  : CFieldPat ',' CFieldPats1 { $1 : $3 }                  | CFieldPat ','             { [$1] }                  | CFieldPat                 { [$1] }@@ -852,11 +856,16 @@              | floatlit { let L loc (FLOATLIT x) = $1 in (PatLitFloat x, loc) }  PatLiteral :: { (PatLit, Loc) }-             : PatLiteralNoNeg           { $1 }-             | '-' NumLit %prec bottom   { (PatLitPrim (primNegate (fst $2)), snd $2) }-             | '-' intlit %prec bottom   { let L loc (INTLIT x) = $2 in (PatLitInt (negate x), loc) }-             | '-' natlit %prec bottom   { let L loc (NATLIT _ x) = $2 in (PatLitInt (negate x), loc) }-             | '-' floatlit              { let L loc (FLOATLIT x) = $2 in (PatLitFloat (negate x), loc) }+             : PatLiteralNoNeg+               { $1 }+             | '-' NumLit %prec bottom+               { (PatLitPrim (primNegate (fst $2)), locOf (srcspan $1 (snd $2))) }+             | '-' intlit %prec bottom+               { let L loc (INTLIT x) = $2 in (PatLitInt (negate x), locOf (srcspan $1 $>)) }+             | '-' natlit %prec bottom+               { let L loc (NATLIT _ x) = $2 in (PatLitInt (negate x), locOf (srcspan $1 $>)) }+             | '-' floatlit+               { let L loc (FLOATLIT x) = $2 in (PatLitFloat (negate x), locOf (srcspan $1 $>)) }  LoopForm :: { LoopFormBase NoInfo Name } LoopForm : for VarId '<' Exp@@ -885,9 +894,9 @@ VarId :: { IdentBase NoInfo Name StructType } VarId : id { let L loc (ID name) = $1 in Ident name NoInfo (srclocOf loc) } -FieldId :: { (Name, Loc) }-         : id     { let L loc (ID name) = $1 in (name, loc) }-         | natlit { let L loc (NATLIT x _) = $1 in (x, loc) }+FieldId :: { L Name }+         : id     { let L loc (ID name) = $1 in L loc name }+         | natlit { let L loc (NATLIT x _) = $1 in L loc x }  maybeAscription(p) : ':' p { Just $2 }                    |       { Nothing }

@@ -173,7 +173,7 @@   pretty (TETuple ts _) = parens $ commasep $ map pretty ts   pretty (TERecord fs _) = braces $ commasep $ map ppField fs     where-      ppField (name, t) = pretty (nameToString name) <> colon <+> pretty t+      ppField (L _ name, t) = prettyName name <> colon <+> pretty t   pretty (TEVar name _) = pretty name   pretty (TEParens te _) = parens $ pretty te   pretty (TEApply t arg _) = pretty t <+> pretty arg@@ -361,7 +361,7 @@   pretty $ show $ map (chr . fromIntegral) s prettyExp _ (Project k e _ _) = pretty e <> "." <> pretty k prettyExp _ (Negate e _) = "-" <> pretty e-prettyExp _ (Not e _) = "-" <> pretty e+prettyExp _ (Not e _) = "!" <> pretty e prettyExp _ (Update src idxs ve _) =   pretty src     <+> "with"@@ -421,12 +421,16 @@   pretty (AttrComp f attrs _) = pretty f <> parens (commasep $ map pretty attrs)  instance (Eq vn, IsName vn, Annot f) => Pretty (FieldBase f vn) where-  pretty (RecordFieldExplicit name e _) = pretty name <> equals <> pretty e-  pretty (RecordFieldImplicit name _ _) = prettyName name+  pretty (RecordFieldExplicit (L _ name) e _) = pretty name <> equals <> pretty e+  pretty (RecordFieldImplicit (L _ name) _ _) = prettyName name  instance (Eq vn, IsName vn, Annot f) => Pretty (CaseBase f vn) where   pretty (CasePat p e _) = "case" <+> pretty p <+> "->" </> indent 2 (pretty e) +instance (Eq vn, IsName vn, Annot f) => Pretty (LoopInitBase f vn) where+  pretty (LoopInitImplicit e) = maybe "_" pretty $ unAnnot e+  pretty (LoopInitExplicit e) = pretty e+ instance (Eq vn, IsName vn, Annot f) => Pretty (LoopFormBase f vn) where   pretty (For i ubound) =     "for" <+> pretty i <+> "<" <+> align (pretty ubound)@@ -449,7 +453,7 @@   pretty (TuplePat pats _) = parens $ commasep $ map pretty pats   pretty (RecordPat fs _) = braces $ commasep $ map ppField fs     where-      ppField (name, t) = pretty (nameToString name) <> equals <> pretty t+      ppField (L _ name, t) = prettyName name <> equals <> pretty t   pretty (Wildcard t _) = case unAnnot t of     Just t' -> parens $ "_" <> colon <+> pretty t'     Nothing -> "_"

@@ -378,8 +378,8 @@ -- operator and what is a built-in function.  Perhaps these should all -- go away eventually. data UnOp-  = -- | E.g., @! True == False@.-    Not+  = -- | Flip sign. Logical negation for booleans.+    Neg PrimType   | -- | E.g., @~(~1) = 1@.     Complement IntType   | -- | @abs(-2) = 2@.@@ -580,8 +580,8 @@ -- | A list of all unary operators for all types. allUnOps :: [UnOp] allUnOps =-  Not-    : map Complement [minBound .. maxBound]+  map Neg [minBound .. maxBound]+    ++ map Complement [minBound .. maxBound]     ++ map Abs [minBound .. maxBound]     ++ map FAbs [minBound .. maxBound]     ++ map SSignum [minBound .. maxBound]@@ -659,7 +659,9 @@ -- | Apply an 'UnOp' to an operand.  Returns 'Nothing' if the -- application is mistyped. doUnOp :: UnOp -> PrimValue -> Maybe PrimValue-doUnOp Not (BoolValue b) = Just $ BoolValue $ not b+doUnOp (Neg _) (BoolValue b) = Just $ BoolValue $ not b+doUnOp (Neg _) (FloatValue v) = Just $ FloatValue $ doFNeg v+doUnOp (Neg _) (IntValue v) = Just $ IntValue $ doIntNeg v doUnOp Complement {} (IntValue v) = Just $ IntValue $ doComplement v doUnOp Abs {} (IntValue v) = Just $ IntValue $ doAbs v doUnOp FAbs {} (FloatValue v) = Just $ FloatValue $ doFAbs v@@ -668,6 +670,17 @@ doUnOp FSignum {} (FloatValue v) = Just $ FloatValue $ doFSignum v doUnOp _ _ = Nothing +doFNeg :: FloatValue -> FloatValue+doFNeg (Float16Value x) = Float16Value $ negate x+doFNeg (Float32Value x) = Float32Value $ negate x+doFNeg (Float64Value x) = Float64Value $ negate x++doIntNeg :: IntValue -> IntValue+doIntNeg (Int8Value x) = Int8Value $ -x+doIntNeg (Int16Value x) = Int16Value $ -x+doIntNeg (Int32Value x) = Int32Value $ -x+doIntNeg (Int64Value x) = Int64Value $ -x+ -- | E.g., @~(~1) = 1@. doComplement :: IntValue -> IntValue doComplement v = intValue (intValueType v) $ complement $ intToInt64 v@@ -1130,7 +1143,7 @@ unOpType :: UnOp -> PrimType unOpType (SSignum t) = IntType t unOpType (USignum t) = IntType t-unOpType Not = Bool+unOpType (Neg t) = t unOpType (Complement t) = IntType t unOpType (Abs t) = IntType t unOpType (FAbs t) = FloatType t@@ -1839,7 +1852,7 @@       (from, to) = convOpType op  instance Pretty UnOp where-  pretty Not = "not"+  pretty (Neg t) = "neg_" <> pretty t   pretty (Abs t) = taggedI "abs" t   pretty (FAbs t) = taggedF "fabs" t   pretty (SSignum t) = taggedI "ssignum" t

@@ -460,8 +460,8 @@ typeOf (RecordLit fs _) =   Scalar $ Record $ M.fromList $ map record fs   where-    record (RecordFieldExplicit name e _) = (name, typeOf e)-    record (RecordFieldImplicit name (Info t) _) = (baseName name, t)+    record (RecordFieldExplicit (L _ name) e _) = (name, typeOf e)+    record (RecordFieldImplicit (L _ name) (Info t) _) = (baseName name, t) typeOf (ArrayLit _ (Info t) _) = t typeOf (ArrayVal vs t loc) =   Array mempty (Shape [sizeFromInteger (genericLength vs) loc]) (Prim t)@@ -596,7 +596,8 @@ patternType (PatParens p _) = patternType p patternType (Id _ (Info t) _) = t patternType (TuplePat pats _) = Scalar $ tupleRecord $ map patternType pats-patternType (RecordPat fs _) = Scalar $ Record $ patternType <$> M.fromList fs+patternType (RecordPat fs _) =+  Scalar $ Record $ patternType <$> M.fromList (map (first unLoc) fs) patternType (PatAscription p _ _) = patternType p patternType (PatLit _ (Info t) _) = t patternType (PatConstr _ (Info t) _ _) = t@@ -1065,8 +1066,6 @@             )           ++           -- This overrides the ! from Primitive.--          -- This overrides the ! from Primitive.           [ ( "!",               IntrinsicOverloadedFun                 ( map Signed [minBound .. maxBound]@@ -1075,6 +1074,16 @@                 )                 [Nothing]                 Nothing+            ),+            ( "neg",+              IntrinsicOverloadedFun+                ( map Signed [minBound .. maxBound]+                    ++ map Unsigned [minBound .. maxBound]+                    ++ map FloatType [minBound .. maxBound]+                    ++ [Bool]+                )+                [Nothing]+                Nothing             )           ]           ++@@ -1409,9 +1418,9 @@   | length fs1 == length fs2 =       zipWithM onFields fs1 fs2   where-    onFields (RecordFieldExplicit n1 fe1 _) (RecordFieldExplicit n2 fe2 _)+    onFields (RecordFieldExplicit (L _ n1) fe1 _) (RecordFieldExplicit (L _ n2) fe2 _)       | n1 == n2 = Just (fe1, fe2)-    onFields (RecordFieldImplicit vn1 ty1 _) (RecordFieldImplicit vn2 ty2 _) =+    onFields (RecordFieldImplicit (L _ vn1) ty1 _) (RecordFieldImplicit (L _ vn2) ty2 _) =       Just (Var (qualName vn1) ty1 mempty, Var (qualName vn2) ty2 mempty)     onFields _ _ = Nothing similarExps (ArrayLit es1 _ _) (ArrayLit es2 _ _)

@@ -59,6 +59,7 @@     ExpBase (..),     FieldBase (..),     CaseBase (..),+    LoopInitBase (..),     LoopFormBase (..),     PatLit (..),     PatBase (..),@@ -87,6 +88,7 @@     DecBase (..),      -- * Miscellaneous+    L (..),     NoInfo (..),     Info (..),     QualName (..),@@ -94,6 +96,7 @@     mkApplyUT,     sizeFromName,     sizeFromInteger,+    loopInitExp,   ) where @@ -461,7 +464,7 @@   = TEVar (QualName vn) SrcLoc   | TEParens (TypeExp d vn) SrcLoc   | TETuple [TypeExp d vn] SrcLoc-  | TERecord [(Name, TypeExp d vn)] SrcLoc+  | TERecord [(L Name, TypeExp d vn)] SrcLoc   | TEArray (SizeExp d) (TypeExp d vn) SrcLoc   | TEUnique (TypeExp d vn) SrcLoc   | TEApply (TypeExp d vn) (TypeArgExp d vn) SrcLoc@@ -722,8 +725,8 @@   | If (ExpBase f vn) (ExpBase f vn) (ExpBase f vn) SrcLoc   | Loop       [VName] -- Size parameters.-      (PatBase f vn ParamType) -- Merge variable pattern.-      (ExpBase f vn) -- Initial values of merge variables.+      (PatBase f vn ParamType) -- Loop parameter pattern.+      (LoopInitBase f vn) -- Possibly initial value.       (LoopFormBase f vn) -- Do or while loop.       (ExpBase f vn) -- Loop body.       SrcLoc@@ -808,9 +811,9 @@     ArrayLit [ExpBase f vn] (f StructType) SrcLoc   | -- | Array value constants, where the elements are known to be     -- constant primitives. This is a fast-path variant of 'ArrayLit'-    -- that will never be constructed by the parser, but may result-    -- from normalisation later on. Has exactly the same semantics as-    -- an 'ArrayLit'.+    -- that will in some cases be constructed by the parser, and also+    -- result from normalisation later on. Has exactly the same+    -- semantics as an 'ArrayLit'.     ArrayVal [PrimValue] PrimType SrcLoc   | -- | An attribute applied to the following expression.     Attr (AttrInfo vn) (ExpBase f vn) SrcLoc@@ -906,8 +909,8 @@  -- | An entry in a record literal. data FieldBase f vn-  = RecordFieldExplicit Name (ExpBase f vn) SrcLoc-  | RecordFieldImplicit vn (f StructType) SrcLoc+  = RecordFieldExplicit (L Name) (ExpBase f vn) SrcLoc+  | RecordFieldImplicit (L vn) (f StructType) SrcLoc  deriving instance Show (FieldBase Info VName) @@ -943,6 +946,28 @@ instance Located (CaseBase f vn) where   locOf (CasePat _ _ loc) = locOf loc +-- | Initial value for the loop. If none is provided, then an+-- expression will be synthesised based on the parameter.+data LoopInitBase f vn+  = LoopInitExplicit (ExpBase f vn)+  | LoopInitImplicit (f (ExpBase f vn))++deriving instance Show (LoopInitBase Info VName)++deriving instance (Show vn) => Show (LoopInitBase NoInfo vn)++deriving instance Eq (LoopInitBase NoInfo VName)++deriving instance Eq (LoopInitBase Info VName)++deriving instance Ord (LoopInitBase NoInfo VName)++deriving instance Ord (LoopInitBase Info VName)++instance Located (LoopInitBase Info vn) where+  locOf (LoopInitExplicit e) = locOf e+  locOf (LoopInitImplicit (Info e)) = locOf e+ -- | Whether the loop is a @for@-loop or a @while@-loop. data LoopFormBase f vn   = For (IdentBase f vn StructType) (ExpBase f vn)@@ -972,7 +997,7 @@ -- parameters, @let@ expressions, etc). data PatBase f vn t   = TuplePat [PatBase f vn t] SrcLoc-  | RecordPat [(Name, PatBase f vn t)] SrcLoc+  | RecordPat [(L Name, PatBase f vn t)] SrcLoc   | PatParens (PatBase f vn t) SrcLoc   | Id vn (f t) SrcLoc   | Wildcard (f t) SrcLoc -- Nothing, i.e. underscore.@@ -1351,6 +1376,10 @@   AppExp (Apply f (args <> NE.singleton (NoInfo, x)) (srcspan loc x)) NoInfo mkApplyUT f x =   AppExp (Apply f (NE.singleton (NoInfo, x)) (srcspan f x)) NoInfo++loopInitExp :: LoopInitBase Info VName -> ExpBase Info VName+loopInitExp (LoopInitExplicit e) = e+loopInitExp (LoopInitImplicit (Info e)) = e  --- Some prettyprinting definitions are here because we need them in --- the Attributes module.

@@ -109,10 +109,10 @@       <*> ((,) <$> mapOnExp tv x <*> pure xext)       <*> ((,) <$> mapOnExp tv y <*> pure yext)       <*> pure loc-  astMap tv (Loop sparams mergepat mergeexp form loopbody loc) =+  astMap tv (Loop sparams mergepat loopinit form loopbody loc) =     Loop sparams       <$> astMap tv mergepat-      <*> mapOnExp tv mergeexp+      <*> astMap tv loopinit       <*> astMap tv form       <*> mapOnExp tv loopbody       <*> pure loc@@ -223,6 +223,12 @@   astMap tv (AppExp e res) =     AppExp <$> astMap tv e <*> astMap tv res +instance ASTMappable (LoopInitBase Info VName) where+  astMap tv (LoopInitExplicit e) =+    LoopInitExplicit <$> mapOnExp tv e+  astMap tv (LoopInitImplicit (Info e)) =+    LoopInitImplicit . Info <$> mapOnExp tv e+ instance ASTMappable (LoopFormBase Info VName) where   astMap tv (For i bound) = For <$> astMap tv i <*> mapOnExp tv bound   astMap tv (ForIn pat e) = ForIn <$> astMap tv pat <*> mapOnExp tv e@@ -361,9 +367,9 @@ instance ASTMappable (FieldBase Info VName) where   astMap tv (RecordFieldExplicit name e loc) =     RecordFieldExplicit name <$> mapOnExp tv e <*> pure loc-  astMap tv (RecordFieldImplicit name t loc) =+  astMap tv (RecordFieldImplicit (L nameloc name) t loc) =     RecordFieldImplicit-      <$> (qualLeaf <$> mapOnName tv (QualName [] name))+      <$> (L nameloc <$> (qualLeaf <$> mapOnName tv (QualName [] name)))       <*> traverse (mapOnStructType tv) t       <*> pure loc @@ -416,6 +422,10 @@ bareDimIndex (DimSlice x y z) =   DimSlice (bareExp <$> x) (bareExp <$> y) (bareExp <$> z) +bareLoopInit :: LoopInitBase Info VName -> LoopInitBase NoInfo VName+bareLoopInit (LoopInitExplicit e) = LoopInitExplicit $ bareExp e+bareLoopInit (LoopInitImplicit _) = LoopInitImplicit NoInfo+ bareLoopForm :: LoopFormBase Info VName -> LoopFormBase NoInfo VName bareLoopForm (For (Ident i _ loc) e) = For (Ident i NoInfo loc) (bareExp e) bareLoopForm (ForIn pat e) = ForIn (barePat pat) (bareExp e)@@ -490,11 +500,11 @@       case appexp of         Match e cases loc ->           Match (bareExp e) (fmap bareCase cases) loc-        Loop _ mergepat mergeexp form loopbody loc ->+        Loop _ mergepat loopinit form loopbody loc ->           Loop             []             (barePat mergepat)-            (bareExp mergeexp)+            (bareLoopInit loopinit)             (bareLoopForm form)             (bareExp loopbody)             loc

@@ -229,7 +229,7 @@   mconcat $     zipWith       matchPat-      (map snd (sortFields (M.fromList fs1)))+      (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@@ -557,7 +557,7 @@ -- 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, Exp, LoopFormBase Info VName, Exp)+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.@@ -631,9 +631,12 @@       checkMergeReturn (PatAscription p _ _) t =         checkMergeReturn p t       checkMergeReturn (RecordPat pfs patloc) (Scalar (Record tfs)) =-        RecordPat . M.toList <$> sequence pfs' <*> pure patloc+        RecordPat . map unshuffle . M.toList <$> sequence pfs' <*> pure patloc         where-          pfs' = M.intersectionWith checkMergeReturn (M.fromList pfs) tfs+          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@@ -664,7 +667,11 @@   param' <- convergeLoopParam loop_loc param (M.keysSet body_cons) body_als    let param_t = patternType param'-  ((arg', arg_als), arg_cons) <- contain $ checkArg [] param_t arg+  ((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   free_bound <- boundFreeInExp body @@ -726,10 +733,11 @@       error $ "checkArgs: " <> prettyString t  ---checkExp (AppExp (Loop sparams pat args form body loc) appres) = do-  ((pat', args', form', body'), als) <- checkLoop (locOf loc) (pat, args, form, body)+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' args' form' body' loc) appres,+    ( AppExp (Loop sparams pat' loopinit' form' body' loc) appres,       als     ) @@ -943,10 +951,10 @@   where     checkField (RecordFieldExplicit name e floc) = do       (e', e_als) <- checkExp e-      pure (RecordFieldExplicit name e' floc, (name, e_als))+      pure (RecordFieldExplicit name e' floc, (unLoc name, e_als))     checkField (RecordFieldImplicit name t floc) = do-      name_als <- observeVar (locOf floc) name $ unInfo t-      pure (RecordFieldImplicit name t floc, (baseName name, name_als))+      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

@@ -8,6 +8,7 @@   ) where +import Data.Bifunctor (first) import Data.List qualified as L import Data.Map.Strict qualified as M import Data.Maybe@@ -64,7 +65,7 @@   MatchConstr (ConstrRecord fnames) (map patternToMatch ps) $     patternStructType p   where-    (fnames, ps) = unzip $ sortFields $ M.fromList fs+    (fnames, ps) = unzip $ sortFields $ M.fromList $ map (first unLoc) fs patternToMatch (PatConstr c (Info t) args _) =   MatchConstr (Constr c) (map patternToMatch args) t 

@@ -260,8 +260,11 @@   where     resolveField (RecordFieldExplicit k e floc) =       RecordFieldExplicit k <$> resolveExp e <*> pure floc-    resolveField (RecordFieldImplicit vn NoInfo floc) =-      RecordFieldImplicit <$> resolveName vn floc <*> pure NoInfo <*> pure floc+    resolveField (RecordFieldImplicit (L vnloc vn) NoInfo floc) =+      RecordFieldImplicit+        <$> (L vnloc <$> resolveName vn floc)+        <*> pure NoInfo+        <*> pure floc resolveExp (Project k e NoInfo loc) =   Project k <$> resolveExp e <*> pure NoInfo <*> pure loc resolveExp (Constr k es NoInfo loc) =@@ -302,6 +305,21 @@ sizeBinderToParam :: SizeBinder Name -> UncheckedTypeParam sizeBinderToParam (SizeBinder v loc) = TypeParamDim v loc +patternExp :: UncheckedPat t -> TypeM (ExpBase NoInfo VName)+patternExp (Id v _ loc) =+  Var <$> resolveQualName (qualName v) loc <*> pure NoInfo <*> pure loc+patternExp (TuplePat pats loc) = TupLit <$> mapM patternExp pats <*> pure loc+patternExp (Wildcard _ loc) = typeError loc mempty "Cannot have wildcard here."+patternExp (PatLit _ _ loc) = typeError loc mempty "Cannot have literal here."+patternExp (PatConstr _ _ _ loc) = typeError loc mempty "Cannot have constructor here."+patternExp (PatAttr _ p _) = patternExp p+patternExp (PatAscription pat _ _) = patternExp pat+patternExp (PatParens pat _) = patternExp pat+patternExp (RecordPat fs loc) = RecordLit <$> mapM field fs <*> pure loc+  where+    field (L nameloc name, pat) =+      RecordFieldExplicit (L nameloc name) <$> patternExp pat <*> pure (srclocOf loc)+ resolveAppExp :: AppExpBase NoInfo Name -> TypeM (AppExpBase NoInfo VName) resolveAppExp (Apply f args loc) =   Apply <$> resolveExp f <*> traverse (traverse resolveExp) args <*> pure loc@@ -351,8 +369,10 @@   pure $ BinOp (f', floc) finfo (e1', info1) (e2', info2) loc resolveAppExp (Index e1 slice loc) =   Index <$> resolveExp e1 <*> resolveSlice slice <*> pure loc-resolveAppExp (Loop sizes pat e form body loc) = do-  e' <- resolveExp e+resolveAppExp (Loop sizes pat loopinit form body loc) = do+  e' <- case loopinit of+    LoopInitExplicit e -> LoopInitExplicit <$> resolveExp e+    LoopInitImplicit NoInfo -> LoopInitExplicit <$> patternExp pat   case form of     For (Ident i _ iloc) bound -> do       bound' <- resolveExp bound

@@ -369,13 +369,13 @@   RecordLit <$> evalStateT (mapM checkField fs) mempty <*> pure loc   where     checkField (RecordFieldExplicit f e rloc) = do-      errIfAlreadySet f rloc-      modify $ M.insert f rloc+      errIfAlreadySet (unLoc f) rloc+      modify $ M.insert (unLoc f) rloc       RecordFieldExplicit f <$> lift (checkExp e) <*> pure rloc     checkField (RecordFieldImplicit name NoInfo rloc) = do-      errIfAlreadySet (baseName name) rloc-      t <- lift $ lookupVar rloc $ qualName name-      modify $ M.insert (baseName name) rloc+      errIfAlreadySet (baseName (unLoc name)) rloc+      t <- lift $ lookupVar rloc $ qualName $ unLoc name+      modify $ M.insert (baseName (unLoc name)) rloc       pure $ RecordFieldImplicit name (Info t) rloc      errIfAlreadySet f rloc = do@@ -798,12 +798,12 @@   (t', retext) <- sliceShape Nothing slice' t   let ft = Scalar $ Arrow mempty Unnamed Observe t $ RetType retext $ toRes Nonunique t'   pure $ IndexSection slice' (Info ft) loc-checkExp (AppExp (Loop _ mergepat mergeexp form loopbody loc) _) = do-  ((sparams, mergepat', mergeexp', form', loopbody'), appres) <--    checkLoop checkExp (mergepat, mergeexp, form, loopbody) loc+checkExp (AppExp (Loop _ mergepat loopinit form loopbody loc) _) = do+  ((sparams, mergepat', loopinit', form', loopbody'), appres) <-+    checkLoop checkExp (mergepat, loopinit, form, loopbody) loc   pure $     AppExp-      (Loop sparams mergepat' mergeexp' form' loopbody' loc)+      (Loop sparams mergepat' loopinit' form' loopbody' loc)       (Info appres) checkExp (Constr name es NoInfo loc) = do   t <- newTypeVar loc "t"@@ -872,7 +872,7 @@       pretty' (TuplePat pats _) = parens $ commasep $ map pretty' pats       pretty' (RecordPat fs _) = braces $ commasep $ map ppField fs         where-          ppField (name, t) = pretty (nameToString name) <> equals <> pretty' t+          ppField (L _ name, t) = pretty (nameToString name) <> equals <> pretty' t       pretty' Wildcard {} = "_"       pretty' (PatLit e _ _) = pretty e       pretty' (PatConstr n _ ps _) = "#" <> pretty n <+> sep (map pretty' ps)

@@ -102,11 +102,11 @@  -- | An un-checked loop. type UncheckedLoop =-  (PatBase NoInfo VName ParamType, ExpBase NoInfo VName, LoopFormBase NoInfo VName, ExpBase NoInfo VName)+  (PatBase NoInfo VName ParamType, LoopInitBase NoInfo VName, LoopFormBase NoInfo VName, ExpBase NoInfo VName)  -- | A loop that has been type-checked. type CheckedLoop =-  ([VName], Pat ParamType, Exp, LoopFormBase Info VName, Exp)+  ([VName], Pat ParamType, LoopInitBase Info VName, LoopFormBase Info VName, Exp)  checkForImpossible :: Loc -> S.Set VName -> ParamType -> TermTypeM () checkForImpossible loc known_before pat_t = do@@ -133,14 +133,18 @@   UncheckedLoop ->   SrcLoc ->   TermTypeM (CheckedLoop, AppRes)-checkLoop checkExp (mergepat, mergeexp, form, loopbody) loc = do-  mergeexp' <- checkExp mergeexp+checkLoop checkExp (mergepat, loopinit, form, loopbody) loc = do+  loopinit' <- checkExp $ case loopinit of+    LoopInitExplicit e -> e+    LoopInitImplicit _ ->+      -- Should have been filled out in Names+      error "Unspected LoopInitImplicit"   known_before <- M.keysSet <$> getConstraints   zeroOrderType-    (mkUsage mergeexp "use as loop variable")+    (mkUsage loopinit' "use as loop variable")     "type used as loop variable"     . toStruct-    =<< expTypeFully mergeexp'+    =<< expTypeFully loopinit'    -- The handling of dimension sizes is a bit intricate, but very   -- similar to checking a function, followed by checking a call to@@ -166,7 +170,7 @@   (merge_t, new_dims_map) <-     -- dim handling (1)     allDimsFreshInType (mkUsage loc "loop parameter type inference") Nonrigid "loop_d"-      =<< expTypeFully mergeexp'+      =<< expTypeFully loopinit'   let new_dims_to_initial_dim = M.toList new_dims_map       new_dims = map fst new_dims_to_initial_dim @@ -292,7 +296,7 @@               )    -- dim handling (4)-  wellTypedLoopArg Initial sparams mergepat' mergeexp'+  wellTypedLoopArg Initial sparams mergepat' loopinit'    (loopt, retext) <-     freshDimsInType@@ -302,6 +306,6 @@       sparams       (patternType mergepat')   pure-    ( (sparams, mergepat', mergeexp', form', loopbody'),+    ( (sparams, mergepat', LoopInitExplicit loopinit', form', loopbody'),       AppRes (toStruct loopt) retext     )

@@ -11,9 +11,10 @@ import Control.Monad import Data.Bifunctor import Data.Either-import Data.List (find, isPrefixOf, sort)+import Data.List (find, isPrefixOf, sort, sortBy) import Data.Map.Strict qualified as M import Data.Maybe+import Data.Ord (comparing) import Data.Set qualified as S import Futhark.Util.Pretty hiding (group, space) import Language.Futhark@@ -154,29 +155,29 @@ checkPat' sizes (TuplePat ps loc) NoneInferred =   TuplePat <$> mapM (\p -> checkPat' sizes p NoneInferred) ps <*> pure loc checkPat' _ (RecordPat p_fs _) _-  | Just (f, fp) <- find (("_" `isPrefixOf`) . nameToString . fst) p_fs =-      typeError fp mempty $+  | Just (L loc f, _) <- find (("_" `isPrefixOf`) . nameToString . unLoc . fst) p_fs =+      typeError loc mempty $         "Underscore-prefixed fields are not allowed."           </> "Did you mean"           <> dquotes (pretty (drop 1 (nameToString f)) <> "=_")           <> "?" checkPat' sizes p@(RecordPat p_fs loc) (Ascribed t)   | Scalar (Record t_fs) <- t,-    sort (map fst p_fs) == sort (M.keys t_fs) =-      RecordPat . M.toList <$> check t_fs <*> pure loc+    p_fs' <- sortBy (comparing fst) p_fs,+    t_fs' <- sortBy (comparing fst) (M.toList t_fs),+    map fst t_fs' == map (unLoc . fst) p_fs' =+      RecordPat <$> zipWithM check p_fs' t_fs' <*> pure loc   | otherwise = do-      p_fs' <- traverse (const $ newTypeVar loc "t") $ M.fromList p_fs+      p_fs' <- traverse (const $ newTypeVar loc "t") $ M.fromList $ map (first unLoc) p_fs -      when (sort (M.keys p_fs') /= sort (map fst p_fs)) $+      when (sort (M.keys p_fs') /= sort (map (unLoc . fst) p_fs)) $         typeError loc mempty $           "Duplicate fields in record pattern" <+> pretty p <> "."        unify (mkUsage loc "matching a record pattern") (Scalar (Record p_fs')) (toStruct t)       checkPat' sizes p $ Ascribed $ toParam Observe $ Scalar (Record p_fs')   where-    check t_fs =-      traverse (uncurry (checkPat' sizes)) $-        M.intersectionWith (,) (M.fromList p_fs) (fmap Ascribed t_fs)+    check (L f_loc f, p_f) (_, t_f) = (L f_loc f,) <$> checkPat' sizes p_f (Ascribed t_f) checkPat' sizes (RecordPat fs loc) NoneInferred =   RecordPat . M.toList     <$> traverse (\p -> checkPat' sizes p NoneInferred) (M.fromList fs)

@@ -126,7 +126,9 @@   pure     ( TERecord (M.toList fs') loc,       fs_svars,-      RetType (foldMap retDims ts_s) $ Scalar $ Record $ M.map retType ts_s,+      RetType (foldMap retDims ts_s) . Scalar . Record $+        M.mapKeys unLoc $+          M.map retType ts_s,       L.foldl' max Unlifted ls     ) --