diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/docs/conf.py b/docs/conf.py --- a/docs/conf.py +++ b/docs/conf.py @@ -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", diff --git a/docs/index.rst b/docs/index.rst --- a/docs/index.rst +++ b/docs/index.rst @@ -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 diff --git a/docs/man/futhark-fmt.rst b/docs/man/futhark-fmt.rst new file mode 100644 --- /dev/null +++ b/docs/man/futhark-fmt.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)` diff --git a/docs/man/futhark-ispc.rst b/docs/man/futhark-ispc.rst --- a/docs/man/futhark-ispc.rst +++ b/docs/man/futhark-ispc.rst @@ -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 ==== diff --git a/docs/man/futhark-profile.rst b/docs/man/futhark-profile.rst --- a/docs/man/futhark-profile.rst +++ b/docs/man/futhark-profile.rst @@ -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 -------------- diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -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 diff --git a/prelude/ad.fut b/prelude/ad.fut --- a/prelude/ad.fut +++ b/prelude/ad.fut @@ -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 diff --git a/prelude/array.fut b/prelude/array.fut --- a/prelude/array.fut +++ b/prelude/array.fut @@ -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.. #[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) diff --git a/prelude/functional.fut b/prelude/functional.fut --- a/prelude/functional.fut +++ b/prelude/functional.fut @@ -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. diff --git a/prelude/math.fut b/prelude/math.fut --- a/prelude/math.fut +++ b/prelude/math.fut @@ -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) diff --git a/prelude/soacs.fut b/prelude/soacs.fut --- a/prelude/soacs.fut +++ b/prelude/soacs.fut @@ -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.. 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 diff --git a/prelude/zip.fut b/prelude/zip.fut --- a/prelude/zip.fut +++ b/prelude/zip.fut @@ -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) diff --git a/src/Futhark/AD/Derivatives.hs b/src/Futhark/AD/Derivatives.hs --- a/src/Futhark/AD/Derivatives.hs +++ b/src/Futhark/AD/Derivatives.hs @@ -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 diff --git a/src/Futhark/Analysis/PrimExp.hs b/src/Futhark/Analysis/PrimExp.hs --- a/src/Futhark/Analysis/PrimExp.hs +++ b/src/Futhark/Analysis/PrimExp.hs @@ -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 diff --git a/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs --- a/src/Futhark/CLI/Bench.hs +++ b/src/Futhark/CLI/Bench.hs @@ -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 () diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs --- a/src/Futhark/CLI/Dev.hs +++ b/src/Futhark/CLI/Dev.hs @@ -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 diff --git a/src/Futhark/CLI/Doc.hs b/src/Futhark/CLI/Doc.hs --- a/src/Futhark/CLI/Doc.hs +++ b/src/Futhark/CLI/Doc.hs @@ -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 diff --git a/src/Futhark/CLI/Fmt.hs b/src/Futhark/CLI/Fmt.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Fmt.hs @@ -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 "" s of + Left (SyntaxError loc err) -> do + T.hPutStr stderr $ locText loc <> ":\n" <> prettyText err + exitFailure + Right fmt -> pure fmt diff --git a/src/Futhark/CLI/Main.hs b/src/Futhark/CLI/Main.hs --- a/src/Futhark/CLI/Main.hs +++ b/src/Futhark/CLI/Main.hs @@ -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 diff --git a/src/Futhark/CLI/Profile.hs b/src/Futhark/CLI/Profile.hs --- a/src/Futhark/CLI/Profile.hs +++ b/src/Futhark/CLI/Profile.hs @@ -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 () [] "" 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 diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs --- a/src/Futhark/CLI/REPL.hs +++ b/src/Futhark/CLI/REPL.hs @@ -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 () diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs --- a/src/Futhark/CLI/Test.hs +++ b/src/Futhark/CLI/Test.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericC/Code.hs b/src/Futhark/CodeGen/Backends/GenericC/Code.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Code.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Code.hs @@ -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')|] diff --git a/src/Futhark/CodeGen/Backends/GenericC/Pretty.hs b/src/Futhark/CodeGen/Backends/GenericC/Pretty.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Pretty.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Pretty.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs --- a/src/Futhark/CodeGen/Backends/GenericPython.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython.hs @@ -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" diff --git a/src/Futhark/CodeGen/Backends/MulticoreISPC.hs b/src/Futhark/CodeGen/Backends/MulticoreISPC.hs --- a/src/Futhark/CodeGen/Backends/MulticoreISPC.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreISPC.hs @@ -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')|] diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -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) diff --git a/src/Futhark/Doc/Generator.hs b/src/Futhark/Doc/Generator.hs --- a/src/Futhark/Doc/Generator.hs +++ b/src/Futhark/Doc/Generator.hs @@ -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" diff --git a/src/Futhark/Fmt/Monad.hs b/src/Futhark/Fmt/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Fmt/Monad.hs @@ -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 diff --git a/src/Futhark/Fmt/Printer.hs b/src/Futhark/Fmt/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Fmt/Printer.hs @@ -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 diff --git a/src/Futhark/IR/Prop/Aliases.hs b/src/Futhark/IR/Prop/Aliases.hs --- a/src/Futhark/IR/Prop/Aliases.hs +++ b/src/Futhark/IR/Prop/Aliases.hs @@ -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] diff --git a/src/Futhark/IR/Syntax.hs b/src/Futhark/IR/Syntax.hs --- a/src/Futhark/IR/Syntax.hs +++ b/src/Futhark/IR/Syntax.hs @@ -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) diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -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" diff --git a/src/Futhark/Internalise/Bindings.hs b/src/Futhark/Internalise/Bindings.hs --- a/src/Futhark/Internalise/Bindings.hs +++ b/src/Futhark/Internalise/Bindings.hs @@ -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) = diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs --- a/src/Futhark/Internalise/Defunctionalise.hs +++ b/src/Futhark/Internalise/Defunctionalise.hs @@ -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' diff --git a/src/Futhark/Internalise/Entry.hs b/src/Futhark/Internalise/Entry.hs --- a/src/Futhark/Internalise/Entry.hs +++ b/src/Futhark/Internalise/Entry.hs @@ -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 diff --git a/src/Futhark/Internalise/Exps.hs b/src/Futhark/Internalise/Exps.hs --- a/src/Futhark/Internalise/Exps.hs +++ b/src/Futhark/Internalise/Exps.hs @@ -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 diff --git a/src/Futhark/Internalise/FullNormalise.hs b/src/Futhark/Internalise/FullNormalise.hs --- a/src/Futhark/Internalise/FullNormalise.hs +++ b/src/Futhark/Internalise/FullNormalise.hs @@ -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 diff --git a/src/Futhark/Internalise/LiftLambdas.hs b/src/Futhark/Internalise/LiftLambdas.hs --- a/src/Futhark/Internalise/LiftLambdas.hs +++ b/src/Futhark/Internalise/LiftLambdas.hs @@ -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. diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -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) = diff --git a/src/Futhark/Internalise/ReplaceRecords.hs b/src/Futhark/Internalise/ReplaceRecords.hs --- a/src/Futhark/Internalise/ReplaceRecords.hs +++ b/src/Futhark/Internalise/ReplaceRecords.hs @@ -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. diff --git a/src/Futhark/Optimise/ArrayLayout/Layout.hs b/src/Futhark/Optimise/ArrayLayout/Layout.hs --- a/src/Futhark/Optimise/ArrayLayout/Layout.hs +++ b/src/Futhark/Optimise/ArrayLayout/Layout.hs @@ -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 diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs --- a/src/Futhark/Optimise/InliningDeadFun.hs +++ b/src/Futhark/Optimise/InliningDeadFun.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs --- a/src/Futhark/Optimise/Simplify/Engine.hs +++ b/src/Futhark/Optimise/Simplify/Engine.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs b/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs --- a/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +++ b/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs @@ -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 $ diff --git a/src/Futhark/Optimise/Simplify/Rules/Index.hs b/src/Futhark/Optimise/Simplify/Rules/Index.hs --- a/src/Futhark/Optimise/Simplify/Rules/Index.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Index.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Rules/Match.hs b/src/Futhark/Optimise/Simplify/Rules/Match.hs --- a/src/Futhark/Optimise/Simplify/Rules/Match.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Match.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Rules/Simple.hs b/src/Futhark/Optimise/Simplify/Rules/Simple.hs --- a/src/Futhark/Optimise/Simplify/Rules/Simple.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Simple.hs @@ -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 diff --git a/src/Futhark/Test/Spec.hs b/src/Futhark/Test/Spec.hs --- a/src/Futhark/Test/Spec.hs +++ b/src/Futhark/Test/Spec.hs @@ -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 == '/' diff --git a/src/Futhark/Util/Pretty.hs b/src/Futhark/Util/Pretty.hs --- a/src/Futhark/Util/Pretty.hs +++ b/src/Futhark/Util/Pretty.hs @@ -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. diff --git a/src/Language/Futhark/Core.hs b/src/Language/Futhark/Core.hs --- a/src/Language/Futhark/Core.hs +++ b/src/Language/Futhark/Core.hs @@ -9,6 +9,9 @@ SrcLoc, Loc, Located (..), + noLoc, + L (..), + unLoc, srclocOf, locStr, locStrRel, diff --git a/src/Language/Futhark/FreeVars.hs b/src/Language/Futhark/FreeVars.hs --- a/src/Language/Futhark/FreeVars.hs +++ b/src/Language/Futhark/FreeVars.hs @@ -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) ) diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -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 "!" diff --git a/src/Language/Futhark/Parser/Monad.hs b/src/Language/Futhark/Parser/Monad.hs --- a/src/Language/Futhark/Parser/Monad.hs +++ b/src/Language/Futhark/Parser/Monad.hs @@ -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) diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -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 } diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -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 -> "_" diff --git a/src/Language/Futhark/Primitive.hs b/src/Language/Futhark/Primitive.hs --- a/src/Language/Futhark/Primitive.hs +++ b/src/Language/Futhark/Primitive.hs @@ -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 diff --git a/src/Language/Futhark/Prop.hs b/src/Language/Futhark/Prop.hs --- a/src/Language/Futhark/Prop.hs +++ b/src/Language/Futhark/Prop.hs @@ -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 _ _) diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -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. diff --git a/src/Language/Futhark/Traversals.hs b/src/Language/Futhark/Traversals.hs --- a/src/Language/Futhark/Traversals.hs +++ b/src/Language/Futhark/Traversals.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Consumption.hs b/src/Language/Futhark/TypeChecker/Consumption.hs --- a/src/Language/Futhark/TypeChecker/Consumption.hs +++ b/src/Language/Futhark/TypeChecker/Consumption.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Match.hs b/src/Language/Futhark/TypeChecker/Match.hs --- a/src/Language/Futhark/TypeChecker/Match.hs +++ b/src/Language/Futhark/TypeChecker/Match.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Names.hs b/src/Language/Futhark/TypeChecker/Names.hs --- a/src/Language/Futhark/TypeChecker/Names.hs +++ b/src/Language/Futhark/TypeChecker/Names.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -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) diff --git a/src/Language/Futhark/TypeChecker/Terms/Loop.hs b/src/Language/Futhark/TypeChecker/Terms/Loop.hs --- a/src/Language/Futhark/TypeChecker/Terms/Loop.hs +++ b/src/Language/Futhark/TypeChecker/Terms/Loop.hs @@ -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 ) diff --git a/src/Language/Futhark/TypeChecker/Terms/Pat.hs b/src/Language/Futhark/TypeChecker/Terms/Pat.hs --- a/src/Language/Futhark/TypeChecker/Terms/Pat.hs +++ b/src/Language/Futhark/TypeChecker/Terms/Pat.hs @@ -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) diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs --- a/src/Language/Futhark/TypeChecker/Types.hs +++ b/src/Language/Futhark/TypeChecker/Types.hs @@ -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 ) --